Add invitation logic and clean up DBProg error handling.

[?]

Jun 19, 2015, 10:20 PM

2XQD6KKKD6QVHFHAEMVE3XXY7X2T7BLTLL7XIILZAXNJJH2YONUQC

Dependencies

[2] V2VDN77H Enable postgres configuration via environment variable for Heroku.
[3] JEOPOOPT Dockerfile now builds correctly.
[4] ZITLSTYX Fix problems with SQL queries & depreciation function parsing.
[5] OBFPJS2G Project successfully builds and tests under nix.
[6] A6HKMINB Attempting to improve JSON handling.
[7] 7KZP4RHZ Switch from Data.Time to Data.Thyme
[8] GKGVYBZG Added JSON serialization to TimeLog
[9] 4IQVQL4T Added client for payouts endpoint.
[10] MXLZBRQN Trickle.
[11] TLQ72DSJ Lenses, sqlite-simple
[12] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[13] HE3JTXO3 Added client call to payouts.
[14] JKMHA2QG SQLite support is now relatively sane.
[15] 5XFJNUAZ Start of addition of project infrastructure.
[16] 5W5M56VJ Move library code to 'lib'
[17] PBD7LZYQ Postgres & auth are beginning to function.
[18] WFZDMVUX Rename ADB -> QDB
[19] W35DDBFY Factor common JSON conversions up into client lib module.
[20] Z7KS5XHH Very WIP. Wow.
[21] 4U7F3CPI THE GREAT RENAMING OF THINGS!
[22] SPJCFHXW Update shell scripts to point to https://aftok.com and prompt for input.
[23] LAROLAYU WIP
[24] TZQJVHBA Add auction functions to ADB.
[25] WO2MINIF Auctions now compile!
[26] LUM4VQJI Increment.
[27] 7XN3I3QJ Add 'loggedIntervals' endpoint.
[28] LD4GLVSF More database stuff.
[29] NJZ3DKZY THEY CAN TALK!
[30] BROSTG5K Beginning of modularization of server.
[31] I2KHGVD4 Require project permissions for access to most data.
[32] O5FVTOM6 Undo JSON silliness, enable a couple more routes.
[33] GCVQD44V Create amends endpoint, switch to UUID primary keys
[34] QMRKFEPG Refactor QDB to use a free monad algebra instead.
[35] FRPWIKCN Added log event parsing to Quixotic.Database.SQLite
[36] MWUPXTBF A few steps down a road to be abandoned.
[37] WZUHEZSB Start of migration back toward snap.
[38] 75N3UJ4J More progression toward lenses.
[39] XMONXALY Fix sqlite/readWorkIndex table name
[40] BXGLKYRX Added primitive user registration handler.
[41] EMVTF2IW WIP moving back to snap.
[42] 64VI73NP Server now compiles using abstracted SQLite
[43] VJPT6HDR Fix remaining type errors after addition of login handler.
[44] 5DRIWGLU Improving TimeLog specs
[45] TCOAKCGG Completed conversion to snap.
[46] IZEVQF62 Work in progress replacing sqlite with postgres.
[47] NVOCQVAS Initial failing tests.
[48] RPAJLHMT Change to use UUIDs instead of ints for primary keys.
[49] TNR3TEHK Switch to Postgres + snaplet arch compiles.
[50] 4ZLEDBK7 Initial attempts at dockerizing, cabal isn't cooperating.
[*] KNSI575V Cleanup of EventLog types.
[*] ADMKQQGC Initial empty Snap project.
[*] EQXRXRZD Changed to use tasty instead of test-framework

Change contents

replacement in Dockerfile at line 12

[5.437]→[3.27:129](∅→∅)

apt-get install -y --no-install-recommends cabal-install-1.22 ghc-7.8.4 happy-1.19.4 alex-3.1.3 \

[5.437]

[3.129]

apt-get install -y --no-install-recommends cabal-install-1.22 ghc-7.10.2 happy-1.19.5 alex-3.1.4 \
replacement in Dockerfile at line 16

[5.770]→[3.215:328](∅→∅)

ENV PATH /root/.cabal/bin:/opt/cabal/1.22/bin:/opt/ghc/7.8.4/bin:/opt/happy/1.19.4/bin:/opt/alex/3.1.3/bin:$PATH

[5.770]

[3.328]

ENV PATH /root/.cabal/bin:/opt/cabal/1.22/bin:/opt/ghc/7.10.2/bin:/opt/happy/1.19.5/bin:/opt/alex/3.1.4/bin:$PATH
replacement in aftok.cabal at line 12

[5.426]→[5.3048:3071](∅→∅)

Cabal-version: >= 1.18

[5.426]

[5.449]

Cabal-version: >= 1.22
replacement in aftok.cabal at line 33

[5.1607]→[5.2368:2558](∅→∅)

base >= 4 && < 5
, classy-prelude >= 0.10.1
, aeson >= 0.8.0.2
, attoparsec >= 0.12.1.2
, base64-bytestring >= 1.0.0.1

[5.1607]

[5.3072]

base >= 4.8.0
, classy-prelude == 0.12.*
, aeson == 0.8.*
, attoparsec == 0.12.*
, base64-bytestring == 1.0.*
replacement in aftok.cabal at line 41

[5.1161]→[5.2587:2624](∅→∅)

, containers >= 0.5.5.1

[5.1161]

[5.2624]

, containers >= 0.5.6
replacement in aftok.cabal at line 43

[5.2656]→[5.2656:2726](∅→∅)

, either >= 4.3.1
, errors >= 1.4.7

[5.2656]

[5.35]

, either >= 4.4.1
, errors >= 1.4 && < 1.5
replacement in aftok.cabal at line 46

[5.46]→[5.2726:2794](∅→∅),[5.2726]→[5.2726:2794](∅→∅)

, groups >= 0.4
, heaps >= 0.3.1

[5.46]

[5.2794]

, groups >= 0.4 && < 0.5
, heaps >= 0.3.1 && < 0.4
edit in aftok.cabal at line 49

[5.2841]

[5.47]

, HsOpenSSL >= 0.11 && < 0.12
replacement in aftok.cabal at line 51

[5.68]→[5.2841:2913](∅→∅),[5.2841]→[5.2841:2913](∅→∅),[5.1474]→[5.1892:1909](∅→∅),[5.2913]→[5.1892:1909](∅→∅),[5.5120]→[5.1892:1909](∅→∅),[5.1892]→[5.1892:1909](∅→∅),[5.1909]→[5.2914:2996](∅→∅)

, lens >= 4.4.0.2
, network-bitcoin >= 1.7.0
, old-locale
, postgresql-simple >= 0.4.9 && < 0.5
, safe >= 0.3.8

[5.68]

[5.1511]

, lens >= 4.11 && < 4.12
, network-bitcoin >= 1.8 && < 1.9
, old-locale >= 1.0
, postgresql-simple >= 0.4.10 && < 0.5
, safe >= 0.3.9 && < 0.4
edit in aftok.cabal at line 58

[5.7126]→[5.2997:3044](∅→∅),[5.1528]→[5.2997:3044](∅→∅)

, sqlite-simple >= 0.4.8 && < 0.5
replacement in aftok.cabal at line 59

[5.1599]→[5.3045:3113](∅→∅),[5.3113]→[5.7127:7160](∅→∅)

, text >= 1.2
, thyme >= 0.3.5
, uuid >= 1.3

[5.1599]

[5.2887]

, text >= 1.2.1 && < 1.3
, thyme >= 0.3.5 && < 0.4
, uuid >= 1.3.10 && < 1.4
replacement in aftok.cabal at line 63

[5.1084]→[5.1070:1081](∅→∅),[5.1200]→[5.1070:1081](∅→∅),[5.2906]→[5.1070:1081](∅→∅),[5.1070]→[5.1070:1081](∅→∅)

, wreq

[5.2906]

[5.1311]

, wreq >= 0.4
replacement in aftok.cabal at line 83

[5.2188]→[5.1600:1621](∅→∅)

, hspec >= 1.8.1

[5.2188]

[5.1621]

, hspec >= 2.1.7
replacement in aftok.cabal at line 86

[5.1651]→[5.1651:1675](∅→∅)

, QuickCheck >= 2.7

[5.1651]

[5.1675]

, QuickCheck >= 2.8
replacement in aftok.cabal at line 108

[5.504]→[5.1277:1319](∅→∅),[5.1277]→[5.1277:1319](∅→∅)

, classy-prelude >= 0.10.2

[5.504]

[5.131]

, classy-prelude
edit in aftok.cabal at line 112

[5.161]

[5.3150]

, HStringTemplate >= 0.8.3
edit in aftok.cabal at line 114

[5.3169]

[5.41]

, HsOpenSSL
replacement in aftok.cabal at line 116

[5.52]→[5.7249:7297](∅→∅),[5.92]→[5.244:294](∅→∅),[5.7297]→[5.244:294](∅→∅),[5.244]→[5.244:294](∅→∅)

, mtl >= 2 && < 3
, MonadCatchIO-transformers >= 0.2.1 && < 0.4

[5.52]

[5.3183]

, mtl >= 2.2 && < 3
, MonadCatchIO-transformers >= 0.3 && < 0.4
replacement in aftok.cabal at line 121

[5.7326]→[5.7376:7427](∅→∅),[5.7376]→[5.7376:7427](∅→∅),[5.2334]→[5.443:545](∅→∅),[5.7427]→[5.443:545](∅→∅),[5.443]→[5.443:545](∅→∅),[5.545]→[5.7428:7467](∅→∅)

, snap >= 0.13 && < 0.14
, snap-core >= 0.9 && < 0.10
, snap-server >= 0.9 && < 0.10
, snaplet-postgresql-simple >= 0.6

[5.7326]

[5.7327]

, sendgrid-haskell >= 1.0
, snap >= 0.14
, snap-core >= 0.9 && < 0.11
, snap-server >= 0.9 && < 0.11
, snaplet-postgresql-simple >= 0.6 && < 0.11
replacement in aftok.cabal at line 129

[5.7369]→[5.7369:7402](∅→∅)

, uuid >= 1.3

[5.7369]

[5.3217]

, uuid
edit in lib/Aftok/Auction.hs at line 9

[5.20]

[5.3]

import Data.Thyme.Clock as C
replacement in lib/Aftok/Auction.hs at line 19

[5.141]→[5.60:88](∅→∅)

, _auctionEnd :: UTCTime

[5.141]

[5.5319]

, _auctionEnd :: C.UTCTime
replacement in lib/Aftok/Auction.hs at line 30

[5.165]→[5.165:192](∅→∅)

, _bidTime :: UTCTime

[5.165]

[5.106]

, _bidTime :: C.UTCTime
file deletion: SQLite.hs (----------)SQLite.hs (----------)SQLite.hs (----------)

[5.40]→[5.62:95](∅→∅),[5.95]→[5.3612:3612](∅→∅),[5.988]→[5.1203:1236](∅→∅),[5.1236]→[5.3612:3612](∅→∅),[5.3590]→[5.4900:4933](∅→∅),[5.4933]→[5.3612:3612](∅→∅)

{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}

module Aftok.Database.SQLite (sqliteQDB) where

import ClassyPrelude
import Control.Lens
import Data.Hourglass
import Database.SQLite.Simple
import Database.SQLite.Simple.ToField
import qualified Text.Read as R

import Aftok
import Aftok.Auctions
import Aftok.Projects
import Aftok.Database
import Aftok.TimeLog
import Aftok.Users

newtype PLogEntry = PLogEntry LogEntry
makePrisms ''PLogEntry

instance ToRow PLogEntry where
toRow (PLogEntry (LogEntry a e)) =
toRow (a ^. address, e ^. (eventType . to eventName), e ^. eventTime)

instance FromRow PLogEntry where
fromRow =
let workEventParser = WorkEvent <$> (field >>= nameEvent) <*> field
logEntryParser = LogEntry <$> (fmap BtcAddr field) <*> workEventParser
in fmap PLogEntry logEntryParser

newtype PAuction = PAuction Auction
makePrisms ''PAuction

instance FromRow PAuction where
fromRow =
let auctionParser = Auction <$> fmap R.read field <*> field
in fmap PAuction auctionParser

newtype PBid = PBid Bid
makePrisms ''PBid

instance FromRow PBid where
fromRow =
let bidParser = Bid <$> fmap UserId field <*> fmap Seconds field <*> fmap R.read field <*> field
in fmap PBid bidParser

newtype PSeconds = PSeconds Seconds

instance ToField PSeconds where
toField (PSeconds (Seconds i)) = toField i

newtype PUserId = PUserId UserId

instance ToField PUserId where
toField (PUserId (UserId i)) = toField i

newtype PAuctionId = PAuctionId AuctionId

instance ToField PAuctionId where
toField (PAuctionId (AuctionId i)) = toField i

-- TODO: Record the user id
recordEvent' :: ProjectId -> UserId -> LogEntry -> ReaderT Connection IO ()
recordEvent' _ _ logEntry = do
conn <- ask
lift $ execute conn
"INSERT INTO work_events (btc_addr, event_type, event_time) VALUES (?, ?, ?)"
(logEntry ^. (from _PLogEntry))

readWorkIndex' :: ProjectId -> ReaderT Connection IO WorkIndex
readWorkIndex' _ = do
conn <- ask
rows <- lift $ query_ conn
"SELECT btc_addr, event_type, event_time from work_events"
lift . pure . workIndex $ fmap (^. _PLogEntry) rows

newAuction' :: ProjectId -> Auction -> ReaderT Connection IO AuctionId
newAuction' _ auc = do
conn <- ask
lift $ execute conn
"INSERT INTO auctions (raise_amount, end_time) VALUES (?, ?)"
(show $ auc ^. raiseAmount, auc ^. auctionEnd)
lift . fmap AuctionId $ lastInsertRowId conn

readAuction' :: AuctionId -> ReaderT Connection IO (Maybe Auction)
readAuction' aucId = do
conn <- ask
rows <- lift $ query conn
"SELECT raise_amount, end_time FROM auctions WHERE ROWID = ?"
(Only $ PAuctionId aucId)
lift . return . headMay $ fmap (^. _PAuction) rows

recordBid' :: AuctionId -> Bid -> ReaderT Connection IO ()
recordBid' aucId bid = do
conn <- ask
lift $ execute conn
"INSERT INTO bids (auction_id, user_id, bid_seconds, bid_amount, bid_time) values (?, ?, ?, ?, ?)"
( PAuctionId aucId
, PUserId $ bid ^. bidUser
, PSeconds $ bid ^. bidSeconds
, show $ bid ^. bidAmount
, bid ^. bidTime
)

readBids' :: AuctionId -> ReaderT Connection IO [Bid]
readBids' aucId = do
conn <- ask
rows <- lift $ query conn
"SELECT user_id, bid_seconds, bid_amount, bid_time FROM bids WHERE auction_id = ?"
(Only $ PAuctionId aucId)
lift . return $ fmap (^. _PBid) rows

createUser' :: User -> ReaderT Connection IO UserId
createUser' u = do
conn <- ask
lift $ execute conn
"INSERT INTO users (btc_addr, email) VALUES (?, ?)"
(u ^. (userAddress . address), u ^. userEmail)
lift . fmap UserId $ lastInsertRowId conn

sqliteQDB :: QDB (ReaderT Connection IO)
sqliteQDB = QDB
{ recordEvent = recordEvent'
, readWorkIndex = readWorkIndex'
, newAuction = newAuction'
, readAuction = readAuction'
, recordBid = recordBid'
, readBids = readBids'
, createUser = createUser'
, findUser = \_ -> pure Nothing
, findUserByUserName = \_ -> pure Nothing
}
replacement in lib/Aftok/Database/PostgreSQL.hs at line 3

[5.566]→[5.125:175](∅→∅)

module Aftok.Database.PostgreSQL (QDBM(..)) where

[5.566]

[5.622]

module Aftok.Database.PostgreSQL (QDBM(), runQDBM) where
edit in lib/Aftok/Database/PostgreSQL.hs at line 10

[5.117]

[5.713]

import Control.Monad.Trans.Either
replacement in lib/Aftok/Database/PostgreSQL.hs at line 29

[5.1124]→[5.203:264](∅→∅)

newtype QDBM a = QDBM { runQDBM :: ReaderT Connection IO a }

[5.1124]

[5.264]

newtype QDBM a = QDBM (ReaderT Connection (EitherT DBError IO) a)
edit in lib/Aftok/Database/PostgreSQL.hs at line 32

[5.1124]

[52.39]

instance MonadIO QDBM where
liftIO = QDBM . lift . lift

runQDBM :: Connection -> QDBM a -> EitherT DBError IO a
runQDBM conn (QDBM r) = runReaderT r conn
edit in lib/Aftok/Database/PostgreSQL.hs at line 69

[5.1462]

[5.1462]

emailParser :: FieldParser Email
emailParser f v = Email <$> fromField f v
edit in lib/Aftok/Database/PostgreSQL.hs at line 80

[5.51]→[5.1605:1606](∅→∅),[5.136]→[5.1605:1606](∅→∅),[5.1605]→[5.1605:1606](∅→∅),[5.2338]→[5.170:271](∅→∅)

newtype PPid = PPid ProjectId
instance ToField PPid where
toField (PPid (ProjectId i)) = toField i
edit in lib/Aftok/Database/PostgreSQL.hs at line 84

[5.2483]→[5.2483:2484](∅→∅),[5.2484]→[5.105:223](∅→∅)

newtype PUTCTime = PUTCTime C.UTCTime
instance ToField PUTCTime where
toField (PUTCTime t) = toField $ fromThyme t
replacement in lib/Aftok/Database/PostgreSQL.hs at line 99

[5.669]→[5.669:724](∅→∅)

Auction <$> fieldWith btcParser
<*> field

[5.669]

[5.2729]

Auction <$> (fromRational <$> field)
<*> fieldWith utcParser
replacement in lib/Aftok/Database/PostgreSQL.hs at line 107

[5.862]→[5.862:878](∅→∅)

<*> field

[5.862]

[5.2828]

<*> fieldWith utcParser
replacement in lib/Aftok/Database/PostgreSQL.hs at line 113

[5.993]→[5.993:1010](∅→∅)

<*> field

[5.993]

[5.2934]

<*> (Email <$> field)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 123

[5.1189]→[5.1189:1210](∅→∅)

<*> field

[5.1189]

[5.1210]

<*> fieldWith utcParser
edit in lib/Aftok/Database/PostgreSQL.hs at line 127

[5.314]

[5.461]

invitationParser :: RowParser Invitation
invitationParser =
Invitation <$> fieldWith pidParser
<*> fieldWith uidParser
<*> fieldWith emailParser
<*> fieldWith utcParser
<*> fmap (fmap toThyme) field
replacement in lib/Aftok/Database/PostgreSQL.hs at line 143

[5.1439]→[5.1439:1465](∅→∅)

lift $ execute conn q d

[5.1439]

[5.620]

lift . lift $ execute conn q d
replacement in lib/Aftok/Database/PostgreSQL.hs at line 148

[5.3186]→[5.1547:1579](∅→∅)

ids <- lift $ query conn q d

[5.3186]

[5.1579]

ids <- lift . lift $ query conn q d
edit in lib/Aftok/Database/PostgreSQL.hs at line 153

[5.580]

[5.1320]

conn <- ask
lift . lift $ queryWith p conn q d

transactQDBM :: QDBM a -> QDBM a
transactQDBM (QDBM rt) = QDBM $ do
replacement in lib/Aftok/Database/PostgreSQL.hs at line 159

[5.1334]→[5.1695:1725](∅→∅)

lift $ queryWith p conn q d

[5.1334]

[5.1361]

lift . EitherT $ withTransaction conn (runEitherT $ runReaderT rt conn)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 185

[5.1479]→[5.1479:1512](∅→∅)

(pid, uid, PUTCTime e)

[5.1479]

[5.1512]

(pid, uid, fromThyme e)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 190

[5.1737]→[5.1737:1782](∅→∅)

(pid, uid, PUTCTime s, PUTCTime e)

[5.1737]

[5.1782]

(pid, uid, fromThyme s, fromThyme e)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 194

[5.1971]→[5.1971:2004](∅→∅)

(pid, uid, PUTCTime s)

[5.1971]

[5.2004]

(pid, uid, fromThyme s)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 212

[5.4598]→[5.2765:2799](∅→∅)

dbEval (ReadWorkIndex pid) = do

[5.4598]

[5.2799]

dbEval (ReadWorkIndex (ProjectId pid)) = do
replacement in lib/Aftok/Database/PostgreSQL.hs at line 215

[5.2942]→[5.2942:2966](∅→∅)

(Only $ PPid pid)

[5.2942]

[5.2966]

(Only $ pid)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 222

[5.3162]→[5.3162:3239](∅→∅)

(pid ^. (_ProjectId), auc ^. (raiseAmount.to PBTC), auc ^. auctionEnd)

[5.3162]

[5.5182]

(pid ^. (_ProjectId), auc ^. (raiseAmount.to PBTC), auc ^. (auctionEnd.to fromThyme))
replacement in lib/Aftok/Database/PostgreSQL.hs at line 238

[5.3768]→[5.3768:3791](∅→∅)

, bid ^. bidTime

[5.3768]

[5.3791]

, bid ^. (bidTime.to fromThyme)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 249

[5.4109]→[5.4109:4200](∅→∅)

(user' ^. (username._UserName), user' ^. (userAddress._BtcAddr), user' ^. userEmail)

[5.4109]

[5.704]

(user' ^. (username._UserName), user' ^. (userAddress._BtcAddr), user' ^. userEmail._Email)
edit in lib/Aftok/Database/PostgreSQL.hs at line 262

[5.4565]

[5.3741]

dbEval (CreateInvitation (ProjectId pid) (UserId uid) (Email e) t) = do
invCode <- liftIO randomInvCode
void $ pexec
"INSERT INTO invitations (project_id, invitor_id, invitee_email, invitation_key, invitation_time) \
\VALUES (?, ?, ?, ?, ?)"
(pid, uid, e, renderInvCode invCode, fromThyme t)
pure invCode
edit in lib/Aftok/Database/PostgreSQL.hs at line 271

[5.3742]

[5.4566]

dbEval (FindInvitation ic) = do
invitations <- pquery invitationParser
"SELECT project_id, invitor_id, invitee_email, invitation_time, acceptance_time \
\FROM invitations WHERE invitation_key = ?"
(Only $ renderInvCode ic)
pure $ headMay invitations

dbEval (AcceptInvitation (UserId uid) ic t) = transactQDBM $ do
void $ pexec
"UPDATE invitations SET acceptance_time = ? WHERE invitation_key = ?"
(fromThyme t, renderInvCode ic)
void $ pexec
"INSERT INTO project_companions (project_id, user_id, invited_by, joined_at) \
\SELECT i.project_id, ?, i.invitor_id, ? \
\FROM invitations i \
\WHERE i.invitation_key = ?"
(uid, fromThyme t, renderInvCode ic)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 293

[5.4751]→[5.4751:4842](∅→∅)

(p ^. projectName, p ^. inceptionDate, p ^. (initiator._UserId), toJSON $ p ^. depf)

[5.4751]

[5.946]

(p ^. projectName, p ^. (inceptionDate.to fromThyme), p ^. (initiator._UserId), toJSON $ p ^. depf)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 314

[5.1045]→[5.5685:5854](∅→∅)

-- FIXME, these are just placeholders
dbEval (OpForbidden _ reason _) = fail $ show reason
dbEval (SubjectNotFound _) = fail "Subject of operation was not found."

[5.1045]

dbEval (RaiseDBError err _) = QDBM . lift $ left err
replacement in lib/Aftok/Database.hs at line 1

[5.4936]→[5.5856:5879](∅→∅)

{-# LANGUAGE GADTs #-}

[5.4936]

[5.426]

{-# LANGUAGE GADTs, DeriveDataTypeable #-}
edit in lib/Aftok/Database.hs at line 7

[5.5900]

[5.6576]

import Data.AffineSpace
import Data.Thyme.Clock as C
edit in lib/Aftok/Database.hs at line 33

[5.6534]

[5.6534]

CreateInvitation :: ProjectId -> InvitingUID -> Email -> C.UTCTime -> DBOp InvitationCode
FindInvitation :: InvitationCode -> DBOp (Maybe Invitation)
AcceptInvitation :: UserId -> InvitationCode -> C.UTCTime -> DBOp ()
replacement in lib/Aftok/Database.hs at line 48

[5.7075]→[5.7075:7204](∅→∅)

OpForbidden :: forall x. UserId -> OpForbiddenReason -> DBOp x -> DBOp x
SubjectNotFound :: forall x. DBOp x -> DBOp x

[5.7075]

[5.7204]

RaiseDBError :: forall x. DBError -> DBOp x -> DBOp x
replacement in lib/Aftok/Database.hs at line 52

[5.7295]→[5.7295:7338](∅→∅)

deriving (Eq, Show)

[5.7295]

[5.7338]

| InvitationExpired
| InvitationAlreadyAccepted
deriving (Eq, Show, Typeable)

data DBError = OpForbidden UserId OpForbiddenReason
| SubjectNotFound
deriving (Eq, Show, Typeable)

instance Exception DBError

raiseOpForbidden :: UserId -> OpForbiddenReason -> DBOp x -> DBOp x
raiseOpForbidden uid r = RaiseDBError (OpForbidden uid r)

raiseSubjectNotFound :: DBOp x -> DBOp x
raiseSubjectNotFound = RaiseDBError SubjectNotFound
edit in lib/Aftok/Database.hs at line 97

[5.8080]→[5.8080:8254](∅→∅)

addUserToProject :: ProjectId -> InvitingUID -> InvitedUID -> DBProg ()
addUserToProject pid current new =
withProjectAuth pid current $ AddUserToProject pid current new
replacement in lib/Aftok/Database.hs at line 103

[5.8438]→[5.8438:8488](∅→∅)

else OpForbidden uid UserNotProjectMember act

[5.8438]

[5.1389]

else raiseOpForbidden uid UserNotProjectMember act

addUserToProject :: ProjectId -> InvitingUID -> InvitedUID -> DBProg ()
addUserToProject pid current new =
withProjectAuth pid current $ AddUserToProject pid current new

createInvitation :: ProjectId -> InvitingUID -> Email -> C.UTCTime -> DBProg InvitationCode
createInvitation pid current email t =
withProjectAuth pid current $ CreateInvitation pid current email t

findInvitation :: InvitationCode -> DBProg (Maybe Invitation)
findInvitation ic = fc $ FindInvitation ic

acceptInvitation :: UserId -> InvitationCode -> C.UTCTime -> DBProg ()
acceptInvitation uid ic t = do
inv <- findInvitation ic
let act = AcceptInvitation uid ic t
case inv of
Nothing ->
fc $ raiseSubjectNotFound act
Just i | t .-. (i ^. invitationTime) > fromSeconds (60 * 60 * 72 :: Int) ->
fc $ raiseOpForbidden uid InvitationExpired act
Just i | isJust (i ^. acceptanceTime) ->
fc $ raiseOpForbidden uid InvitationAlreadyAccepted act
Just i ->
withProjectAuth (i ^. projectId) (i ^. invitingUser) act
replacement in lib/Aftok/Database.hs at line 134

[5.8631]→[5.8631:8691](∅→∅)

createEvent p u l = withProjectAuth p u $ CreateEvent p u l

[5.8631]

[5.8691]

createEvent p u l = withProjectAuth p u $ CreateEvent p u l
replacement in lib/Aftok/Database.hs at line 140

[5.8841]→[5.8841:8934](∅→∅)

forbidden = OpForbidden uid UserNotEventLogger act
missing = SubjectNotFound act

[5.8841]

[5.8934]

forbidden = raiseOpForbidden uid UserNotEventLogger act
missing = raiseSubjectNotFound act
replacement in lib/Aftok/Json.hs at line 83

[5.9375]→[5.5170:5274](∅→∅),[5.1552]→[5.5170:5274](∅→∅)

qdbProjectJSON (projectId, project) = v1 $
object [ "projectId" .= (tshow $ projectId ^. _ProjectId)

[5.9375]

[5.5274]

qdbProjectJSON (pid, project) = v1 $
object [ "projectId" .= (tshow $ pid ^. _ProjectId)
edit in lib/Aftok.hs at line 10

[5.10687]

[5.10687]

import Data.ByteString.Base64.URL as B64
edit in lib/Aftok.hs at line 12

[5.10704]

[5.2203]

import Data.Thyme.Clock as C
replacement in lib/Aftok.hs at line 14

[5.2220]→[5.2691:2720](∅→∅),[5.1838]→[5.2691:2720](∅→∅)

import Network.Bitcoin (BTC)

[5.2220]

[5.2592]

import OpenSSL.Random
edit in lib/Aftok.hs at line 34

[5.2868]

[5.2868]

newtype Email = Email Text deriving (Show, Eq)
makePrisms ''Email
replacement in lib/Aftok.hs at line 40

[5.2939]→[5.2939:2962](∅→∅)

, _userEmail :: Text

[5.2939]

[5.2962]

, _userEmail :: Email
edit in lib/Aftok.hs at line 47

[5.3065]

[5.3065]

type ProjectName = Text
replacement in lib/Aftok.hs at line 49

[5.3088]→[5.3088:3143](∅→∅)

{ _projectName :: Text
, _inceptionDate :: UTCTime

[5.3088]

[5.3143]

{ _projectName :: ProjectName
, _inceptionDate :: C.UTCTime
replacement in lib/Aftok.hs at line 56

[5.3194]→[5.3194:3223](∅→∅),[5.3223]→[5.1024:1060](∅→∅),[5.1060]→[5.3251:3399](∅→∅),[5.3251]→[5.3251:3399](∅→∅)

data Invitation = Invitation
{ _invitationProject :: ProjectId
, _currentMember :: UserId
, _sentAt :: UTCTime
, _expiresAt :: UTCTime
, _toAddr :: BtcAddr
, _amount :: BTC
}
makeLenses ''Invitation

[5.3194]

[5.3399]

newtype InvitationCode = InvitationCode ByteString deriving (Eq)
makePrisms ''InvitationCode

randomInvCode :: IO InvitationCode
randomInvCode = InvitationCode <$> randBytes 256
replacement in lib/Aftok.hs at line 62

[5.3400]→[5.6964:7025](∅→∅)

newtype InvitationId = InvitationId UUID deriving (Show, Eq)

[5.3400]

[5.3442]

parseInvCode :: Text -> Either String InvitationCode
parseInvCode t = do
code <- B64.decode . encodeUtf8 $ t
if length code == 256
then Right $ InvitationCode code
else Left "Invitation code appears to be invalid."
replacement in lib/Aftok.hs at line 69

[5.3443]→[5.3443:3567](∅→∅)

data Acceptance = Acceptance
{ _acceptedInvitation :: InvitationId
, _blockHeight :: Integer
, _observedAt :: UTCTime

[5.3443]

[5.3567]

renderInvCode :: InvitationCode -> Text
renderInvCode (InvitationCode bs) = decodeUtf8 $ B64.encode bs

data Invitation = Invitation
{ _projectId :: ProjectId
, _invitingUser :: UserId
, _invitedEmail :: Email
, _invitationTime :: C.UTCTime
, _acceptanceTime :: Maybe C.UTCTime
replacement in lib/Aftok.hs at line 79

[5.3571]→[5.3571:3595](∅→∅)

makeLenses ''Acceptance

[5.3571]

[5.10914]

makeLenses ''Invitation
edit in server/Aftok/QConfig.hs at line 8

[2.4683]

[2.4683]

import qualified Network.Sendgrid.Api as Sendgrid
replacement in server/Aftok/QConfig.hs at line 10

[2.4709]→[2.4709:4736](∅→∅)

import System.IO(FilePath)

[2.4709]

[2.4736]

import System.IO (FilePath)
edit in server/Aftok/QConfig.hs at line 16

[2.4839]→[2.4839:4840](∅→∅)
edit in server/Aftok/QConfig.hs at line 22

[2.5002]

[2.5079]

, sendgridAuth :: Sendgrid.Authentication
, templatePath :: System.IO.FilePath
edit in server/Aftok/QConfig.hs at line 40

[2.5653]

[2.5811]

<*> readSendgridAuth cfg
<*> C.require cfg "templatePath"

readSendgridAuth :: CT.Config -> IO Sendgrid.Authentication
readSendgridAuth cfg =
Sendgrid.Authentication <$> C.require cfg "sendgridUser"
<*> C.require cfg "sendgridKey"
replacement in server/Aftok/Snaplet/Auth.hs at line 7

[5.11710]→[5.1947:1993](∅→∅),[5.310]→[5.1947:1993](∅→∅)

import Data.Attoparsec.ByteString (parseOnly)

[5.11710]

[5.423]

import Data.UUID(fromASCIIBytes)
import Data.Attoparsec.ByteString(parseOnly, takeByteString)
replacement in server/Aftok/Snaplet/Auth.hs at line 41

[5.2162]→[5.11804:11872](∅→∅),[5.2100]→[5.2252:2346](∅→∅),[5.11872]→[5.2252:2346](∅→∅),[5.2252]→[5.2252:2346](∅→∅),[5.2346]→[5.11873:11997](∅→∅)

requireProjectId :: Handler App App ProjectId
requireProjectId = do
pidMay <- getParam "projectId"
case ProjectId <$> (readMay =<< fmap decodeUtf8 pidMay) of
Nothing -> snapError 400 "Value of parameter projectId could not be parsed to a valid value."
Just pid -> pure pid

[5.2162]

[5.2558]

requireProjectId :: MonadSnap m => m ProjectId
requireProjectId = do
maybePid <- parseParam "projectId" pidParser
maybe (snapError 400 "Value of parameter \"projectId\" cannot be parsed as a valid UUID")
pure
maybePid
where
pidParser = do
bs <- takeByteString
pure $ ProjectId <$> fromASCIIBytes bs
edit in server/Aftok/Snaplet/Projects.hs at line 7

[5.2486]

[5.2533]

import Control.Lens
edit in server/Aftok/Snaplet/Projects.hs at line 9

[5.2556]

[5.2415]

import Data.Attoparsec.ByteString (takeByteString)
import Data.Thyme.Clock as C
import qualified Network.Sendgrid.Api as Sendgrid
import System.IO (FilePath)
import Text.StringTemplate
edit in server/Aftok/Snaplet/Projects.hs at line 17

[5.2450]

[5.2450]

import Aftok.QConfig
replacement in server/Aftok/Snaplet/Projects.hs at line 35

[5.3320]→[5.3320:3357](∅→∅),[5.3357]→[5.12168:12240](∅→∅)

timestamp <- liftIO getCurrentTime
snapEval . createProject $ Project (cpn cp) timestamp uid (cpdepf cp)

[5.3320]

[5.3442]

t <- liftIO C.getCurrentTime
snapEval . createProject $ Project (cpn cp) t uid (cpdepf cp)
edit in server/Aftok/Snaplet/Projects.hs at line 49

[5.3685]

[5.3685]

projectInviteHandler :: QConfig -> Handler App App ()
projectInviteHandler cfg = do
uid <- requireUserId
pid <- requireProjectId
toEmail <- parseParam "email" (fmap (Email . decodeUtf8) takeByteString)
t <- liftIO C.getCurrentTime
(Just u, Just p, invCode) <- snapEval $
(,,) <$> findUser uid
<*> findProject pid uid
<*> createInvitation pid uid toEmail t
inviteEmail <- liftIO $
projectInviteEmail (templatePath cfg) (p ^. projectName) (u ^. userEmail) toEmail invCode
maybeSuccess <- liftIO $ Sendgrid.sendEmail (sendgridAuth cfg) inviteEmail
maybe
(snapError 500 "The invitation record was created successfully, but the introductory email could not be sent.")
(const $ pure ())
maybeSuccess

projectInviteEmail :: System.IO.FilePath
-> ProjectName
-> Email -> Email
-> InvitationCode
-> IO Sendgrid.EmailMessage
projectInviteEmail templatePath pn from' to' invCode = do
templates <- directoryGroup templatePath
template <- maybe (fail "Could not find template for invitation email") pure $
getStringTemplate "invitation_email" templates
let setAttrs = setAttribute "invCode" (renderInvCode invCode)
return $ Sendgrid.EmailMessage
{ from = unpack $ from' ^. _Email
, to = unpack $ to' ^. _Email
, subject = unpack $ "Welcome to the "<>pn<>" Aftok!"
, text = render $ setAttrs template
}
edit in server/Aftok/Snaplet/Projects.hs at line 85

[5.3686]
edit in server/Aftok/Snaplet/Users.hs at line 11

[5.165]

[5.2561]

import Data.Thyme.Clock as C
edit in server/Aftok/Snaplet/Users.hs at line 25

[5.345]

[5.345]

, _invitationCodes :: [InvitationCode]
replacement in server/Aftok/Snaplet/Users.hs at line 31

[5.435]→[5.435:572](∅→∅),[5.572]→[5.12488:12542](∅→∅)

let u = User <$> (UserName <$> v .: "username")
<*> (BtcAddr <$> v .: "btcAddr")
<*> v .: "email"
in CU <$> u <*> (fromString <$> v .: "password")

[5.435]

[5.634]

let parseUser = User <$> (UserName <$> v .: "username")
<*> (BtcAddr <$> v .: "btcAddr")
<*> (Email <$> v .: "email")

parseInvitationCodes c = either
(\e -> fail $ "Invitation code was rejected as invalid: " <> e)
pure
(traverse parseInvCode c)

in CU <$> parseUser
<*> (fromString <$> v .: "password")
<*> (parseInvitationCodes =<< v .: "invitation_codes")
replacement in server/Aftok/Snaplet/Users.hs at line 46

[5.4848]→[5.4848:4886](∅→∅)

registerHandler :: Handler App App ()

[5.4425]

[5.657]

registerHandler :: Handler App App UserId
edit in server/Aftok/Snaplet/Users.hs at line 49

[5.3592]

[5.751]

-- allow any number of 'invitationCode' query parameters
edit in server/Aftok/Snaplet/Users.hs at line 51

[5.843]

[5.3593]

t <- liftIO C.getCurrentTime
replacement in server/Aftok/Snaplet/Users.hs at line 53

[5.3691]→[5.12543:12605](∅→∅)

createQUser = snapEval (createUser $ userData ^. cuser)

[5.3691]

[5.3764]

createQUser = snapEval $ do
userId <- createUser $ userData ^. cuser
void $ traverse (\c -> acceptInvitation userId c t) (userData ^. invitationCodes)
return userId
replacement in server/Aftok/Snaplet/Users.hs at line 58

[5.3800]→[5.1025:1083](∅→∅),[5.1025]→[5.1025:1083](∅→∅)

void $ either throwDenied (\_ -> createQUser) authUser

[5.3800]

either throwDenied (\_ -> createQUser) authUser
edit in server/Aftok/Snaplet.hs at line 10

[5.1290]

[5.9489]

import Control.Monad.Trans.Either
edit in server/Aftok/Snaplet.hs at line 12

[5.9522]

[5.1324]

import Data.Attoparsec.ByteString(Parser, parseOnly)
edit in server/Aftok/Snaplet.hs at line 14

[5.1325]

[5.3017]

import Aftok
replacement in server/Aftok/Snaplet.hs at line 33

[5.1907]→[5.1907:2006](∅→∅)

getPostgresState = with db get
setLocalPostgresState s = local (set (db . snapletValue) s)

[5.1907]

[5.2006]

getPostgresState = with db get
setLocalPostgresState s = local (set (db . snapletValue) s)
replacement in server/Aftok/Snaplet.hs at line 36

[5.2007]→[5.13535:13642](∅→∅)

snapEval :: DBProg a -> Handler App App a
snapEval p = liftPG . runReaderT . runQDBM $ interpret dbEval p

[5.2007]

[5.4063]

snapEval :: (MonadSnap m, HasPostgres m) => DBProg a -> m a
snapEval p = do
let handleDBError (OpForbidden (UserId uid) reason) =
snapError 403 $ tshow reason <> " (User " <> tshow uid <> ")"
handleDBError (SubjectNotFound) =
snapError 404 "The subject of the requested operation could not be found."

e <- liftPG $ \conn -> runEitherT (runQDBM conn $ interpret dbEval p)
either handleDBError pure e
edit in server/Aftok/Snaplet.hs at line 56

[5.3199]

[5.9523]

parseParam :: MonadSnap m => ByteString -> Parser a -> m a
parseParam name parser = do
maybeBytes <- getParam name
case maybeBytes of
Nothing -> snapError 400 $ "Parameter "<> tshow name <>" is required"
Just bytes -> either
(const . snapError 400 $ "Value of parameter "<> tshow name <>" could not be parsed to a valid value.")
pure
(parseOnly parser bytes)
replacement in server/Main.hs at line 32

[5.8394]→[5.3303:3379](∅→∅)

appInit QConfig{..} = makeSnaplet "aftok" "Aftok Time Tracker" Nothing $ do

[5.8394]

[5.8526]

appInit cfg = makeSnaplet "aftok" "Aftok Time Tracker" Nothing $ do
replacement in server/Main.hs at line 34

[5.8568]→[5.3172:3244](∅→∅),[5.3244]→[2.6355:6407](∅→∅)

initCookieSessionManager authSiteKey "quookie" cookieTimeout
pgs <- nestSnaplet "db" db $ pgsInit' pgsConfig

[5.8568]

[5.8692]

initCookieSessionManager (authSiteKey cfg) "quookie" (cookieTimeout cfg)
pgs <- nestSnaplet "db" db $ pgsInit' (pgsConfig cfg)
edit in server/Main.hs at line 40

[5.2397]

[5.2397]

projectCreateRoute = void $ method POST projectCreateHandler
listProjectsRoute = serveJSON (fmap qdbProjectJSON) $ method GET projectListHandler
edit in server/Main.hs at line 43

[5.2398]

[5.2398]

projectRoute = serveJSON projectJSON $ method GET projectGetHandler
edit in server/Main.hs at line 47

[5.7876]

[5.7876]

payoutsRoute = serveJSON payoutsJSON $ method GET payoutsHandler
inviteRoute = void . method POST $ projectInviteHandler cfg
edit in server/Main.hs at line 52

[5.2570]→[5.2570:2887](∅→∅)

projectCreateRoute = void $ method POST projectCreateHandler
projectRoute = serveJSON projectJSON $ method GET projectGetHandler
listProjectsRoute = serveJSON (fmap qdbProjectJSON) $ method GET projectListHandler

payoutsRoute = serveJSON payoutsJSON $ method GET payoutsHandler
replacement in server/Main.hs at line 54

[5.2968]→[5.7961:8018](∅→∅)

, ("events/:eventId/amend", amendEventRoute)

[5.2968]

[5.2968]

, ("projects", projectCreateRoute)
, ("projects", listProjectsRoute)
, ("projects/:projectId", projectRoute)
replacement in server/Main.hs at line 61

[5.3779]→[5.3299:3346](∅→∅),[5.3299]→[5.3299:3346](∅→∅),[5.3346]→[5.3780:3938](∅→∅)

, ("projects", projectCreateRoute)
, ("projects", listProjectsRoute)
, ("projects/:projectId", projectRoute)
, ("projects/:projectId/payouts", payoutsRoute)

[5.3779]

[5.8999]

, ("projects/:projectId/payouts", payoutsRoute)
, ("projects/:projectId/invite", inviteRoute)
, ("events/:eventId/amend", amendEventRoute)
edit in sql/aftok-pg-002.sql at line 6

[4.762]

alter table project_companions
add joined_at timestamp with time zone not null
default (now() at time zone "UTC");
file addition: aftok-pg-003.sql (----------)

[54.1369]

create table invitations (
id uuid primary key default uuid_generate_v4(),
project_id uuid references projects(id) not null,
invitor_id uuid references users (id) not null,
invitee_email text not null,
invitation_key text not null,
invitation_time timestamp with time zone not null default (now() at time zone 'UTC'),
acceptance_time timestamp with time zone
);