Refactor QDB to use a free monad algebra instead.

[?]

Jun 13, 2015, 5:15 AM

QMRKFEPGFBCEWAIXPEIG5ILKAJ2JH5L3TOITHR4HNJXK5FN3KXBQC

Dependencies

[2] 4U7F3CPI THE GREAT RENAMING OF THINGS!
[3] 2OIPAQCB Merge branch 'master' of github.com:nuttycom/ananke
[4] Z7KS5XHH Very WIP. Wow.
[5] IZEVQF62 Work in progress replacing sqlite with postgres.
[6] O5FVTOM6 Undo JSON silliness, enable a couple more routes.
[7] P6NR2CGX Beginning of implementation of depreciation.
[8] W35DDBFY Factor common JSON conversions up into client lib module.
[9] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[10] EZQG2APB Update task list.
[11] GCVQD44V Create amends endpoint, switch to UUID primary keys
[12] V2VDN77H Enable postgres configuration via environment variable for Heroku.
[13] 64VI73NP Server now compiles using abstracted SQLite
[14] Y35QCWYW Minor improvement in WorkIndex type to eliminate duplicated information.
[15] 4QX5E5AC Initial compilation of payouts function succeeds.
[16] NVOCQVAS Initial failing tests.
[17] XTBSG4C7 Adding serveJSON combinator to eliminate some boilerplate from handlers.
[18] A2J7B4SC Initial impl of depreciation function.
[19] 75N3UJ4J More progression toward lenses.
[20] 5W5M56VJ Move library code to 'lib'
[21] LD4GLVSF More database stuff.
[22] SLL7262C Make depreciation functions more flexible.
[23] SCXG6TJW Make log reduction safer in presence of overlapping events.
[24] BROSTG5K Beginning of modularization of server.
[25] TZQJVHBA Add auction functions to ADB.
[26] WFZDMVUX Rename ADB -> QDB
[27] NTPC7KJE Trivial changes, feature scratchpad.
[28] LAROLAYU WIP
[29] VJPT6HDR Fix remaining type errors after addition of login handler.
[30] GKGVYBZG Added JSON serialization to TimeLog
[31] TLQ72DSJ Lenses, sqlite-simple
[32] JKMHA2QG SQLite support is now relatively sane.
[33] 2Y2QZFVF Switch to more modern cabal2nix-based workflow.
[34] TNR3TEHK Switch to Postgres + snaplet arch compiles.
[35] BXGLKYRX Added primitive user registration handler.
[36] 5XFJNUAZ Start of addition of project infrastructure.
[37] I2KHGVD4 Require project permissions for access to most data.
[38] 4IQVQL4T Added client for payouts endpoint.
[39] PBD7LZYQ Postgres & auth are beginning to function.
[40] 2G3GNDDU Event logging is now functioning in postgres.
[41] A6HKMINB Attempting to improve JSON handling.
[42] FD7SV5I6 Fix handling of event_t columns.
[43] N4NDAZYT Initial implementation of payouts.
[44] 7KZP4RHZ Switch from Data.Time to Data.Thyme
[45] 5DRIWGLU Improving TimeLog specs
[46] EMVTF2IW WIP moving back to snap.
[47] KNSI575V Cleanup of EventLog types.
[48] RPAJLHMT Change to use UUIDs instead of ints for primary keys.
[*] ADMKQQGC Initial empty Snap project.

Change contents

edit in aftok.cabal at line 30

[2.429]

[2.429]

Aftok.Util
edit in aftok.cabal at line 45

[3.2726]

[3.2726]

, free
edit in aftok.cabal at line 49

[3.2841]

[3.2841]

, kan-extensions
replacement in lib/Aftok/Database/PostgreSQL.hs at line 1

[3.532]→[3.532:565](∅→∅)

{-# LANGUAGE TemplateHaskell #-}

[3.456]

[3.565]

{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
replacement in lib/Aftok/Database/PostgreSQL.hs at line 3

[3.566]→[2.1048:1101](∅→∅)

module Aftok.Database.PostgreSQL (postgresQDB) where

[3.566]

[3.622]

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

[3.713]

[3.73]

import Data.Aeson(toJSON)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 28

[3.1124]→[3.1124:1158](∅→∅)

type QDBM = ReaderT Connection IO

[3.1124]

[3.1123]

newtype QDBM a = QDBM { runQDBM :: ReaderT Connection IO a }
deriving (Functor, Applicative, Monad)
edit in lib/Aftok/Database/PostgreSQL.hs at line 49

[3.765]→[3.223:224](∅→∅),[3.223]→[3.223:224](∅→∅),[3.224]→[3.165:240](∅→∅)

eidParser :: FieldParser EventId
eidParser f v = EventId <$> fromField f v
replacement in lib/Aftok/Database/PostgreSQL.hs at line 89

[3.2598]→[3.425:468](∅→∅)

qdbLogEntryParser :: RowParser QDBLogEntry

[3.2598]

[3.468]

qdbLogEntryParser :: RowParser KeyedLogEntry
replacement in lib/Aftok/Database/PostgreSQL.hs at line 91

[3.489]→[3.489:554](∅→∅)

(,,,) <$> fieldWith eidParser
<*> fieldWith pidParser

[3.489]

[3.554]

(,,) <$> fieldWith pidParser
replacement in lib/Aftok/Database/PostgreSQL.hs at line 113

[3.2935]→[3.1011:1046](∅→∅)

qdbUserParser :: RowParser QDBUser

[3.2935]

[3.1046]

qdbUserParser :: RowParser KeyedUser
edit in lib/Aftok/Database/PostgreSQL.hs at line 123

[3.1244]

[3.313]

<*> fieldWith fromJSONField
replacement in lib/Aftok/Database/PostgreSQL.hs at line 125

[3.314]→[3.1245:1286](∅→∅)

qdbProjectParser :: RowParser QDBProject

[3.314]

[3.1286]

qdbProjectParser :: RowParser KeyedProject
replacement in lib/Aftok/Database/PostgreSQL.hs at line 131

[3.1410]→[3.1410:1425](∅→∅)

pexec q d = do

[3.1410]

[3.1425]

pexec q d = QDBM $ do
replacement in lib/Aftok/Database/PostgreSQL.hs at line 136

[3.1527]→[3.1527:1546](∅→∅)

pinsert f q d = do

[3.1527]

[3.3172]

pinsert f q d = QDBM $ do
replacement in lib/Aftok/Database/PostgreSQL.hs at line 142

[3.1676]→[3.1676:1694](∅→∅)

pquery p q d = do

[3.1676]

[3.1320]

pquery p q d = QDBM $ do
replacement in lib/Aftok/Database/PostgreSQL.hs at line 146

[3.1362]→[3.295:359](∅→∅),[3.359]→[3.1726:1806](∅→∅),[3.1806]→[3.1510:1666](∅→∅),[3.1510]→[3.1510:1666](∅→∅),[3.1666]→[3.523:538](∅→∅),[3.3644]→[3.523:538](∅→∅),[3.523]→[3.523:538](∅→∅),[3.538]→[3.3645:3665](∅→∅),[3.3665]→[3.1025:1043](∅→∅),[3.1043]→[3.225:258](∅→∅),[3.258]→[3.1073:1081](∅→∅),[3.1073]→[3.1073:1081](∅→∅),[3.1081]→[3.3399:3405](∅→∅),[3.3687]→[3.3399:3405](∅→∅),[3.3399]→[3.3399:3405](∅→∅)

createEvent' :: ProjectId -> UserId -> LogEntry -> QDBM EventId
createEvent' (ProjectId pid) (UserId uid) (LogEntry a e m) =
pinsert EventId
"INSERT INTO work_events (project_id, user_id, btc_addr, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?) \
\RETURNING id"
( pid, uid
, a ^. _BtcAddr
, eventName e
, fromThyme $ e ^. eventTime
, m
)

[3.1362]

[3.1807]

instance DBEval QDBM where
dbEval (CreateEvent (ProjectId pid) (UserId uid) (LogEntry a e m)) =
pinsert EventId
"INSERT INTO work_events (project_id, user_id, btc_addr, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?) \
\RETURNING id"
( pid, uid
, a ^. _BtcAddr
, eventName e
, fromThyme $ e ^. eventTime
, m
)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 159

[3.1808]→[3.1808:2097](∅→∅)

findEvent' :: EventId -> QDBM (Maybe QDBLogEntry)
findEvent' (EventId eid) = do
logEntries <- pquery qdbLogEntryParser
"SELECT id, project_id, user_id, btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE id = ?"
(Only eid)
pure $ headMay logEntries

[3.1808]

[3.3405]

dbEval (FindEvent (EventId eid)) = do
logEntries <- pquery qdbLogEntryParser
"SELECT project_id, user_id, btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE id = ?"
(Only eid)
pure $ headMay logEntries
replacement in lib/Aftok/Database/PostgreSQL.hs at line 166

[3.3406]→[3.259:374](∅→∅),[3.374]→[3.2098:2130](∅→∅),[3.2130]→[3.402:585](∅→∅),[3.402]→[3.402:585](∅→∅),[3.585]→[3.2131:2165](∅→∅),[3.2165]→[3.615:841](∅→∅),[3.615]→[3.615:841](∅→∅),[3.841]→[3.2166:2197](∅→∅),[3.2197]→[3.868:1051](∅→∅),[3.868]→[3.868:1051](∅→∅),[3.1051]→[3.2198:2226](∅→∅)

findEvents' :: ProjectId -> UserId -> Interval' -> QDBM [LogEntry]
findEvents' (ProjectId pid) (UserId uid) ival =
let q p (Before e) = pquery p
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE project_id = ? AND user_id = ? AND event_time <= ?"
(pid, uid, PUTCTime e)
q p (During s e) = pquery p
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE project_id = ? AND user_id = ? \
\AND event_time >= ? AND event_time <= ?"
(pid, uid, PUTCTime s, PUTCTime e)
q p (After s) = pquery p
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE project_id = ? AND user_id = ? AND event_time >= ?"
(pid, uid, PUTCTime s)
in q logEntryParser ival

[3.3406]

[3.1083]

dbEval (FindEvents (ProjectId pid) (UserId uid) ival) =
let q p (Before e) = pquery p
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE project_id = ? AND user_id = ? AND event_time <= ?"
(pid, uid, PUTCTime e)
q p (During s e) = pquery p
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE project_id = ? AND user_id = ? \
\AND event_time >= ? AND event_time <= ?"
(pid, uid, PUTCTime s, PUTCTime e)
q p (After s) = pquery p
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events \
\WHERE project_id = ? AND user_id = ? AND event_time >= ?"
(pid, uid, PUTCTime s)
in q logEntryParser ival
replacement in lib/Aftok/Database/PostgreSQL.hs at line 182

[3.1084]→[3.2227:2288](∅→∅),[3.2288]→[3.1768:1815](∅→∅),[3.1768]→[3.1768:1815](∅→∅),[3.1815]→[3.2289:2414](∅→∅),[3.2414]→[3.264:317](∅→∅),[3.1920]→[3.264:317](∅→∅)

amendEvent' :: EventId -> EventAmendment -> QDBM AmendmentId
amendEvent' (EventId eid) (TimeChange mt t) =
pinsert AmendmentId
"INSERT INTO event_time_amendments (event_id, mod_time, event_time) VALUES (?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, fromThyme t )

[3.1084]

[3.1951]

dbEval (AmendEvent (EventId eid) (TimeChange mt t)) =
pinsert AmendmentId
"INSERT INTO event_time_amendments (event_id, mod_time, event_time) VALUES (?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, fromThyme t )
replacement in lib/Aftok/Database/PostgreSQL.hs at line 187

[3.1952]→[3.1952:2005](∅→∅),[3.2005]→[3.2415:2538](∅→∅),[3.2538]→[3.318:376](∅→∅),[3.2108]→[3.318:376](∅→∅)

amendEvent' (EventId eid) (AddressChange mt addr) =
pinsert AmendmentId
"INSERT INTO event_addr_amendments (event_id, mod_time, btc_addr) VALUES (?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, addr ^. _BtcAddr )

[3.1952]

[3.2154]

dbEval (AmendEvent (EventId eid) (AddressChange mt addr)) =
pinsert AmendmentId
"INSERT INTO event_addr_amendments (event_id, mod_time, btc_addr) VALUES (?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, addr ^. _BtcAddr )
replacement in lib/Aftok/Database/PostgreSQL.hs at line 192

[3.2157]→[3.2157:2208](∅→∅),[3.2208]→[3.2539:2708](∅→∅),[3.420]→[3.2346:2393](∅→∅),[3.2708]→[3.2346:2393](∅→∅),[3.2346]→[3.2346:2393](∅→∅),[3.2393]→[3.602:626](∅→∅),[3.602]→[3.602:626](∅→∅),[3.626]→[3.2709:2747](∅→∅),[3.2747]→[3.1085:1186](∅→∅),[3.2411]→[3.1085:1186](∅→∅),[3.405]→[3.740:762](∅→∅),[3.1186]→[3.740:762](∅→∅),[3.740]→[3.740:762](∅→∅),[3.762]→[3.2748:2778](∅→∅),[3.2778]→[3.3624:3625](∅→∅),[3.3624]→[3.3624:3625](∅→∅),[3.3625]→[3.425:482](∅→∅),[3.482]→[3.2779:2926](∅→∅),[3.2926]→[3.954:1029](∅→∅),[3.954]→[3.954:1029](∅→∅),[3.3928]→[3.3928:3929](∅→∅),[3.3929]→[3.511:585](∅→∅),[3.585]→[3.2927:3026](∅→∅),[3.3026]→[3.4129:4162](∅→∅),[3.4129]→[3.4129:4162](∅→∅),[3.4162]→[3.3027:3053](∅→∅),[3.3053]→[3.4200:4201](∅→∅),[3.4200]→[3.4200:4201](∅→∅),[3.4201]→[3.3054:3099](∅→∅),[3.3099]→[3.628:666](∅→∅),[3.628]→[3.628:666](∅→∅),[3.666]→[3.3100:3241](∅→∅),[3.159]→[3.4444:4597](∅→∅),[3.3241]→[3.4444:4597](∅→∅),[3.4444]→[3.4444:4597](∅→∅)

amendEvent' (EventId eid) (MetadataChange mt v) =
pinsert AmendmentId
"INSERT INTO event_metadata_amendments (event_id, mod_time, btc_addr) VALUES (?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, v)

readWorkIndex' :: ProjectId -> QDBM WorkIndex
readWorkIndex' pid = do
logEntries <- pquery logEntryParser
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events WHERE project_id = ?"
(Only $ PPid pid)
pure $ workIndex logEntries

createAuction' :: ProjectId -> Auction -> QDBM AuctionId
createAuction' pid auc =
pinsert AuctionId
"INSERT INTO auctions (project_id, raise_amount, end_time) \
\VALUES (?, ?, ?) RETURNING id"
(pid ^. (_ProjectId), auc ^. (raiseAmount.to PBTC), auc ^. auctionEnd)

findAuction' :: AuctionId -> QDBM (Maybe Auction)
findAuction' aucId = do
auctions <- pquery auctionParser
"SELECT raise_amount, end_time FROM auctions WHERE id = ?"
(Only (aucId ^. _AuctionId))
pure $ headMay auctions

createBid' :: AuctionId -> Bid -> QDBM BidId
createBid' (AuctionId aucId) bid = do
pinsert BidId
"INSERT INTO bids (auction_id, bidder_id, bid_seconds, bid_amount, bid_time) \
\VALUES (?, ?, ?, ?, ?) RETURNING id"
( aucId
, bid ^. (bidUser._UserId)
, case bid ^. bidSeconds of (Seconds i) -> i
, bid ^. (bidAmount.to PBTC)
, bid ^. bidTime
)

[3.2157]

[3.4597]

dbEval (AmendEvent (EventId eid) (MetadataChange mt v)) =
pinsert AmendmentId
"INSERT INTO event_metadata_amendments (event_id, mod_time, btc_addr) VALUES (?, ?, ?) RETURNING id"
( eid, fromThyme $ mt ^. _ModTime, v)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 197

[3.4598]→[3.2615:2652](∅→∅),[3.2652]→[3.3242:3280](∅→∅),[3.2670]→[3.4715:4837](∅→∅),[3.3280]→[3.4715:4837](∅→∅),[3.4715]→[3.4715:4837](∅→∅)

readBids' :: AuctionId -> QDBM [Bid]
readBids' aucId =
pquery bidParser
"SELECT user_id, bid_seconds, bid_amount, bid_time FROM bids WHERE auction_id = ?"
(Only $ (aucId ^. _AuctionId))

[3.4598]

[3.4861]

dbEval (ReadWorkIndex pid) = do
logEntries <- pquery logEntryParser
"SELECT btc_addr, event_type, event_time, event_metadata FROM work_events WHERE project_id = ?"
(Only $ PPid pid)
pure $ workIndex logEntries
replacement in lib/Aftok/Database/PostgreSQL.hs at line 203

[3.4862]→[3.2671:2706](∅→∅),[3.2706]→[3.3281:3319](∅→∅),[3.2724]→[3.160:240](∅→∅),[3.3319]→[3.160:240](∅→∅),[3.4978]→[3.160:240](∅→∅),[3.240]→[3.3688:3777](∅→∅)

createUser' :: User -> QDBM UserId
createUser' user' =
pinsert UserId
"INSERT INTO users (handle, btc_addr, email) VALUES (?, ?, ?) RETURNING id"
(user' ^. (username._UserName), user' ^. (userAddress._BtcAddr), user' ^. userEmail)

[3.4862]

[3.5182]

dbEval (CreateAuction pid auc) =
pinsert AuctionId
"INSERT INTO auctions (project_id, raise_amount, end_time) \
\VALUES (?, ?, ?) RETURNING id"
(pid ^. (_ProjectId), auc ^. (raiseAmount.to PBTC), auc ^. auctionEnd)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 209

[3.5183]→[3.2725:2766](∅→∅),[3.2766]→[3.5241:5269](∅→∅),[3.5241]→[3.5241:5269](∅→∅),[3.5269]→[3.3320:3349](∅→∅),[3.2785]→[3.5312:5388](∅→∅),[3.3349]→[3.5312:5388](∅→∅),[3.5312]→[3.5312:5388](∅→∅),[3.5388]→[3.3350:3373](∅→∅)

findUser' :: UserId -> QDBM (Maybe User)
findUser' (UserId uid) = do
users <- pquery userParser
"SELECT handle, btc_addr, email FROM users WHERE id = ?"
(Only uid)
pure $ headMay users

[3.5183]

[3.5424]

dbEval (FindAuction aucId) = do
auctions <- pquery auctionParser
"SELECT raise_amount, end_time FROM auctions WHERE id = ?"
(Only (aucId ^. _AuctionId))
pure $ headMay auctions
replacement in lib/Aftok/Database/PostgreSQL.hs at line 215

[3.5425]→[3.2786:2842](∅→∅),[3.2842]→[3.501:539](∅→∅),[3.501]→[3.501:539](∅→∅),[3.539]→[3.3374:3406](∅→∅),[3.2861]→[3.582:664](∅→∅),[3.3406]→[3.582:664](∅→∅),[3.582]→[3.582:664](∅→∅),[3.664]→[3.3407:3430](∅→∅)

findUserByUserName' :: UserName -> QDBM (Maybe QDBUser)
findUserByUserName' (UserName h) = do
users <- pquery qdbUserParser
"SELECT id, handle, btc_addr, email FROM users WHERE handle = ?"
(Only h)
pure $ headMay users

[3.5425]

[3.5524]

dbEval (CreateBid (AuctionId aucId) bid) =
pinsert BidId
"INSERT INTO bids (auction_id, bidder_id, bid_seconds, bid_amount, bid_time) \
\VALUES (?, ?, ?, ?, ?) RETURNING id"
( aucId
, bid ^. (bidUser._UserId)
, case bid ^. bidSeconds of (Seconds i) -> i
, bid ^. (bidAmount.to PBTC)
, bid ^. bidTime
)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 226

[3.5525]→[3.2862:2906](∅→∅),[3.2906]→[3.683:705](∅→∅),[3.683]→[3.683:705](∅→∅),[3.705]→[3.4:41](∅→∅),[3.41]→[3.3431:3458](∅→∅),[3.2924]→[3.747:849](∅→∅),[3.3458]→[3.747:849](∅→∅),[3.747]→[3.747:849](∅→∅),[3.849]→[3.42:90](∅→∅),[3.90]→[3.3459:3588](∅→∅)

createProject' :: Project -> QDBM ProjectId
createProject' p = do
let uid = p ^. (initiator._UserId)
pid <- pinsert ProjectId
"INSERT INTO projects (project_name, inception_date, initiator_id) VALUES (?, ?, ?) RETURNING id"
(p ^. projectName, p ^. inceptionDate, uid)
void $ pexec
"INSERT INTO project_companions (project_id, user_id) VALUES (?, ?)"
(pid ^. _ProjectId, uid)
pure pid

[3.5525]

[3.667]

dbEval (ReadBids aucId) =
pquery bidParser
"SELECT user_id, bid_seconds, bid_amount, bid_time FROM bids WHERE auction_id = ?"
(Only $ (aucId ^. _AuctionId))
replacement in lib/Aftok/Database/PostgreSQL.hs at line 231

[3.668]→[3.668:752](∅→∅),[3.752]→[3.3589:3624](∅→∅),[3.3624]→[3.773:871](∅→∅),[3.773]→[3.773:871](∅→∅),[3.871]→[3.3625:3651](∅→∅)

findProject' :: ProjectId -> QDBM (Maybe Project)
findProject' (ProjectId pid) = do
projects <- pquery projectParser
"SELECT project_name, inception_date, initiator_id FROM projects WHERE id = ?"
(Only pid)
pure $ headMay projects

[3.668]

[3.704]

dbEval (CreateUser user') =
pinsert UserId
"INSERT INTO users (handle, btc_addr, email) VALUES (?, ?, ?) RETURNING id"
(user' ^. (username._UserName), user' ^. (userAddress._BtcAddr), user' ^. userEmail)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 236

[3.705]→[3.2941:2990](∅→∅),[3.2990]→[3.3652:3712](∅→∅),[3.3011]→[3.1111:1180](∅→∅),[3.3712]→[3.1111:1180](∅→∅),[3.1111]→[3.1111:1180](∅→∅),[3.1180]→[3.274:348](∅→∅),[3.348]→[3.3713:3740](∅→∅),[3.3740]→[3.380:395](∅→∅),[3.380]→[3.380:395](∅→∅)

findUserProjects' :: UserId -> QDBM [QDBProject]
findUserProjects' (UserId uid) =
pquery qdbProjectParser
"SELECT p.id, p.project_name, p.inception_date, p.initiator_id \
\FROM projects p JOIN project_companions pc ON pc.project_id = p.id \
\WHERE pc.user_id = ?"
(Only uid)

[3.705]

[3.1368]

dbEval (FindUser (UserId uid)) = do
users <- pquery userParser
"SELECT handle, btc_addr, email FROM users WHERE id = ?"
(Only uid)
pure $ headMay users
edit in lib/Aftok/Database/PostgreSQL.hs at line 242

[3.1369]

[3.3741]

dbEval (FindUserByName (UserName h)) = do
users <- pquery qdbUserParser
"SELECT id, handle, btc_addr, email FROM users WHERE handle = ?"
(Only h)
pure $ headMay users
replacement in lib/Aftok/Database/PostgreSQL.hs at line 248

[3.3742]→[3.3012:3036](∅→∅),[3.1369]→[3.3012:3036](∅→∅),[3.3036]→[3.5568:5587](∅→∅),[3.5568]→[3.5568:5587](∅→∅),[3.5587]→[3.914:945](∅→∅),[3.945]→[3.3037:3066](∅→∅),[3.5618]→[3.3037:3066](∅→∅),[3.3066]→[3.3743:3770](∅→∅),[3.3770]→[3.1187:1216](∅→∅),[3.3066]→[3.1187:1216](∅→∅),[3.1216]→[3.5618:5654](∅→∅),[3.3066]→[3.5618:5654](∅→∅),[3.5618]→[3.5618:5654](∅→∅)

postgresQDB :: QDB QDBM
postgresQDB = QDB
{ createEvent = createEvent'
, amendEvent = amendEvent'
, findEvent = findEvent'
, findEvents = findEvents'
, readWorkIndex = readWorkIndex'

[3.3742]

[3.946]

dbEval (CreateProject p) =
pinsert ProjectId
"INSERT INTO projects (project_name, inception_date, initiator_id, depreciation_fn) \
\VALUES (?, ?, ?, ?) RETURNING id"
(p ^. projectName, p ^. inceptionDate, p ^. (initiator._UserId), toJSON $ p ^. depf)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 254

[3.947]→[3.947:1013](∅→∅)

, createAuction = createAuction'
, findAuction = findAuction'

[3.947]

[3.1013]

dbEval (FindProject (ProjectId pid)) = do
projects <- pquery projectParser
"SELECT project_name, inception_date, initiator_id FROM projects WHERE id = ?"
(Only pid)
pure $ headMay projects
replacement in lib/Aftok/Database/PostgreSQL.hs at line 260

[3.1014]→[3.1014:1041](∅→∅),[3.1041]→[3.5741:5766](∅→∅),[3.5741]→[3.5741:5766](∅→∅)

, createBid = createBid'
, readBids = readBids'

[3.1014]

[3.1042]

dbEval (FindUserProjects (UserId uid)) =
pquery qdbProjectParser
"SELECT p.id, p.project_name, p.inception_date, p.initiator_id \
\FROM projects p JOIN project_companions pc ON pc.project_id = p.id \
\WHERE pc.user_id = ? \
\UNION \
\SELECT p.id, p.project_name, p.inception_date, p.initiator_id \
\FROM projects p \
\WHERE p.initiator_id = ?"
(uid, uid)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 271

[3.1043]→[3.5766:5820](∅→∅),[3.5766]→[3.5766:5820](∅→∅),[3.5820]→[3.706:751](∅→∅)

, createUser = createUser'
, findUser = findUser'
, findUserByUserName = findUserByUserName'

[3.1043]

[3.1044]

dbEval (AddUserToProject pid current new) = do
void $ pexec
"INSERT INTO project_companions (project_id, user_id, invited_by) VALUES (?, ?, ?)"
(pid ^. _ProjectId, new ^. _UserId, current ^. _UserId)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 276

[3.1045]→[3.1371:1406](∅→∅),[3.751]→[3.1371:1406](∅→∅),[3.1406]→[3.1046:1077](∅→∅),[3.1077]→[3.1406:1447](∅→∅),[3.1406]→[3.1406:1447](∅→∅),[3.751]→[3.5861:5865](∅→∅),[3.1447]→[3.5861:5865](∅→∅),[3.5861]→[3.5861:5865](∅→∅)

, createProject = createProject'
, findProject = findProject'
, findUserProjects = findUserProjects'
}

[3.1045]

-- FIXME, these are just placeholders
dbEval (OpForbidden _ reason _) = fail $ show reason
dbEval (SubjectNotFound _) = fail "Subject of operation was not found."
replacement in lib/Aftok/Database.hs at line 1

[3.4936]→[3.5:38](∅→∅)

{-# LANGUAGE TemplateHaskell #-}

[3.4936]

[3.426]

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

[3.838]

[3.6576]

import Control.Lens
edit in lib/Aftok/Database.hs at line 12

[2.1548]

[3.5044]

import Aftok.Util

type KeyedUser = (UserId, User)
type KeyedLogEntry = (ProjectId, UserId, LogEntry)
type KeyedProject = (ProjectId, Project)
type InvitingUID = UserId
type InvitedUID = UserId

type DBProg a = Program DBOp a

data DBOp a where
CreateUser :: User -> DBOp UserId
FindUser :: UserId -> DBOp (Maybe User)
FindUserByName :: UserName -> DBOp (Maybe KeyedUser)

CreateProject :: Project -> DBOp ProjectId
FindProject :: ProjectId -> DBOp (Maybe Project)
FindUserProjects :: UserId -> DBOp [KeyedProject]
AddUserToProject :: ProjectId -> InvitingUID -> InvitedUID -> DBOp ()

CreateEvent :: ProjectId -> UserId -> LogEntry -> DBOp EventId
AmendEvent :: EventId -> EventAmendment -> DBOp AmendmentId
FindEvent :: EventId -> DBOp (Maybe KeyedLogEntry)
FindEvents :: ProjectId -> UserId -> Interval' -> DBOp [LogEntry]
ReadWorkIndex :: ProjectId -> DBOp WorkIndex

CreateAuction :: ProjectId -> Auction -> DBOp AuctionId
FindAuction :: AuctionId -> DBOp (Maybe Auction)
CreateBid :: AuctionId -> Bid -> DBOp BidId
ReadBids :: AuctionId -> DBOp [Bid]

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

data OpForbiddenReason = UserNotProjectMember
| UserNotEventLogger
deriving (Eq, Show)

class DBEval m where
dbEval :: DBOp a -> m a

-- User ops

createUser :: User -> DBProg UserId
createUser = fc . CreateUser

findUser :: UserId -> DBProg (Maybe User)
findUser = fc . FindUser
replacement in lib/Aftok/Database.hs at line 61

[3.5045]→[3.3772:3904](∅→∅)

type QDBUser = (UserId, User)
type QDBLogEntry = (EventId, ProjectId, UserId, LogEntry)
type QDBProject = (ProjectId, Project)

[3.5045]

[3.1389]

findUserByName :: UserName -> DBProg (Maybe KeyedUser)
findUserByName = fc . FindUserByName

-- Project ops

createProject :: Project -> DBProg ProjectId
createProject p = do
pid <- fc $ CreateProject p
addUserToProject pid (p ^. initiator) (p ^. initiator)
return pid

findProject :: ProjectId -> UserId -> DBProg (Maybe Project)
findProject pid uid = do
kps <- findUserProjects uid
pure $ fmap snd (find (\(pid', _) -> pid' == pid) kps)

findUserProjects :: UserId -> DBProg [KeyedProject]
findUserProjects = fc . FindUserProjects

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

withProjectAuth :: ProjectId -> UserId -> DBOp a -> DBProg a
withProjectAuth pid uid act = do
px <- findUserProjects uid
fc $ if any (\(pid', _) -> pid' == pid) px
then act
else OpForbidden uid UserNotProjectMember act
replacement in lib/Aftok/Database.hs at line 91

[3.6669]→[3.6669:6687](∅→∅),[3.6687]→[3.1079:1145](∅→∅),[3.1145]→[3.3905:4023](∅→∅),[3.4023]→[3.1244:1314](∅→∅),[3.3190]→[3.1244:1314](∅→∅),[3.1314]→[3.296:342](∅→∅),[3.3190]→[3.296:342](∅→∅),[3.296]→[3.296:342](∅→∅)

data QDB m = QDB
{ createEvent :: ProjectId -> UserId -> LogEntry -> m EventId
, amendEvent :: EventId -> EventAmendment -> m AmendmentId
, findEvent :: EventId -> m (Maybe QDBLogEntry)
, findEvents :: ProjectId -> UserId -> Interval' -> m [LogEntry]
, readWorkIndex :: ProjectId -> m WorkIndex

[3.1390]

[3.1146]

-- Log ops

-- TODO: ignore "duplicate" events within some small time limit?
createEvent :: ProjectId -> UserId -> LogEntry -> DBProg EventId
createEvent p u l = withProjectAuth p u $ CreateEvent p u l

amendEvent :: UserId -> EventId -> EventAmendment -> DBProg AmendmentId
amendEvent uid eid a = do
ev <- findEvent eid
let act = AmendEvent eid a
forbidden = OpForbidden uid UserNotEventLogger act
missing = SubjectNotFound act
fc $ maybe missing (\(_, uid', _) -> if uid' == uid then act else forbidden) ev
replacement in lib/Aftok/Database.hs at line 105

[3.1147]→[3.1147:1256](∅→∅)

, createAuction :: ProjectId -> Auction -> m AuctionId
, findAuction :: AuctionId -> m (Maybe Auction)

[3.1147]

[3.4024]

findEvent :: EventId -> DBProg (Maybe KeyedLogEntry)
findEvent = fc . FindEvent
replacement in lib/Aftok/Database.hs at line 108

[3.4025]→[3.4025:4074](∅→∅),[3.1302]→[3.1598:1640](∅→∅),[3.4074]→[3.1598:1640](∅→∅),[3.1598]→[3.1598:1640](∅→∅)

, createBid :: AuctionId -> Bid -> m BidId
, readBids :: AuctionId -> m [Bid]

[3.4025]

[3.1303]

findEvents :: ProjectId -> UserId -> Interval' -> DBProg [LogEntry]
findEvents p u i = fc $ FindEvents p u i
replacement in lib/Aftok/Database.hs at line 111

[3.1304]→[3.578:662](∅→∅),[3.1640]→[3.578:662](∅→∅),[3.578]→[3.578:662](∅→∅),[3.662]→[3.799:855](∅→∅),[3.7012]→[3.799:855](∅→∅)

, createUser :: User -> m UserId
, findUser :: UserId -> m (Maybe User)
, findUserByUserName :: UserName -> m (Maybe QDBUser)

[3.1304]

[3.1305]

readWorkIndex :: ProjectId -> UserId -> DBProg WorkIndex
readWorkIndex pid uid = withProjectAuth pid uid $ ReadWorkIndex pid
edit in lib/Aftok/Database.hs at line 114

[3.1306]→[3.1449:1493](∅→∅),[3.855]→[3.1449:1493](∅→∅),[3.1493]→[3.1307:1359](∅→∅),[3.1359]→[3.1641:1690](∅→∅),[3.1493]→[3.1641:1690](∅→∅),[3.855]→[3.1641:1690](∅→∅),[3.855]→[3.5159:5163](∅→∅),[3.1688]→[3.5159:5163](∅→∅),[3.1690]→[3.5159:5163](∅→∅),[3.1725]→[3.5159:5163](∅→∅),[3.5930]→[3.5159:5163](∅→∅),[3.7064]→[3.5159:5163](∅→∅),[3.5159]→[3.5159:5163](∅→∅)

, createProject :: Project -> m ProjectId
, findProject :: ProjectId -> m (Maybe Project)
, findUserProjects :: UserId -> m [QDBProject]
}
replacement in lib/Aftok/Json.hs at line 82

[3.486]→[3.1514:1552](∅→∅)

qdbProjectJSON :: QDBProject -> Value

[3.486]

[3.5170]

qdbProjectJSON :: KeyedProject -> Value
replacement in lib/Aftok/TimeLog.hs at line 10

[3.2184]→[3.3:12](∅→∅),[3.5508]→[3.3:12](∅→∅),[3.3635]→[3.3:12](∅→∅)

, DepF

[3.2184]

[3.2185]

, DepF, toDepF
edit in lib/Aftok/TimeLog.hs at line 15

[3.12]→[3.5326:5345](∅→∅),[3.5608]→[3.5326:5345](∅→∅),[3.6623]→[3.5326:5345](∅→∅),[3.24]→[3.5326:5345](∅→∅)

, Months(Months)
edit in lib/Aftok/TimeLog.hs at line 98

[3.2354]

[3.344]

toDepF :: DepreciationFunction -> DepF
toDepF (LinearDepreciation undepLength depLength) = linearDepreciation undepLength depLength
replacement in lib/Aftok/TimeLog.hs at line 106

[3.1502]→[3.1502:1576](∅→∅)

workCredit depf ptime ivals = getSum $ F.foldMap (Sum . depf ptime) ivals

[3.1502]

[3.1576]

workCredit df ptime ivals = getSum $ F.foldMap (Sum . df ptime) ivals
edit in lib/Aftok/TimeLog.hs at line 164

[3.23]→[3.23:57](∅→∅)

newtype Months = Months Integer
replacement in lib/Aftok/TimeLog.hs at line 167

[3.2121]→[3.2121:2404](∅→∅)

linearDepreciation :: Months -> -- ^ The number of initial months during which no depreciation occurs
Months -> -- ^ The number of months over which each logged interval will be depreciated
DepF
linearDepreciation undepPeriod depPeriod =

[3.2121]

[3.2404]

linearDepreciation :: Months -- ^ The number of initial months during which no depreciation occurs
-> Months -- ^ The number of months over which each logged interval will be depreciated
-> DepF -- ^ The resulting configured depreciation function.
linearDepreciation undepLength depLength =
replacement in lib/Aftok/TimeLog.hs at line 175

[3.2537]→[3.2537:2613](∅→∅)

maxDepreciable = monthsLength undepPeriod ^+^ monthsLength depPeriod

[3.2537]

[3.970]

maxDepreciable = monthsLength undepLength ^+^ monthsLength depLength
replacement in lib/Aftok/TimeLog.hs at line 179

[3.508]→[3.508:556](∅→∅)

if dt < monthsLength undepPeriod then 1

[3.508]

[3.2647]

if dt < monthsLength undepLength then 1
file addition: Util.hs (----------)

[2.679]

{-# LANGUAGE RankNTypes #-}

module Aftok.Util where

import ClassyPrelude
import Control.Monad.Free.Church
import Data.Functor.Coyoneda

type Program f a = F (Coyoneda f) a

-- Shouldn't this exist already in a library somewhere?
interpret :: Monad m => (forall x. f x -> m x) -> Program f a -> m a
interpret nt p =
let eval (Coyoneda cf cm) = nt cm >>= cf
in iterM eval p

fc :: f a -> Program f a
fc = liftF . liftCoyoneda
replacement in lib/Aftok.hs at line 1

[3.2457]→[3.1742:1794](∅→∅)

{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-}

[3.2457]

[3.1126]

{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, DeriveDataTypeable #-}
replacement in lib/Aftok.hs at line 7

[3.2690]→[3.1818:1838](∅→∅),[3.1149]→[3.1818:1838](∅→∅)

import Control.Lens

[3.2690]

[3.2203]

import Control.Lens(makePrisms, makeLenses)
import Data.Aeson
import Data.Aeson.Types
import Data.Data
edit in lib/Aftok.hs at line 19

[3.4286]

[3.2763]

newtype Months = Months Integer
deriving (Eq, Show, Data, Typeable)
edit in lib/Aftok.hs at line 23

[3.2764]

[3.2221]

data DepreciationFunction = LinearDepreciation Months Months
deriving (Eq, Show, Data, Typeable)
edit in lib/Aftok.hs at line 46

[3.3168]

[3.3168]

, _depf :: DepreciationFunction
edit in lib/Aftok.hs at line 68

[3.3595]

-- | others tbd

instance ToJSON DepreciationFunction where
toJSON (LinearDepreciation (Months up) (Months dp)) =
object [ "type" .= ("LinearDepreciation" :: Text)
, "arguments" .= (
object [ "undep" .= up
, "dep" .= dp
]
)]

instance FromJSON DepreciationFunction where
parseJSON (Object v) = do
t <- v .: "text" :: Parser Text
args <- v .: "arguments"
case unpack t of
"LinearDepreciation" ->
let undep = Months <$> (args .: "undep")
dep = Months <$> (args .: "dep")
in LinearDepreciation <$> undep <*> dep
x -> fail $ "No depreciation function recognized for type " <> x

parseJSON _ = mzero
replacement in server/Aftok/Snaplet/Auth.hs at line 6

[3.283]→[3.283:310](∅→∅)

import Control.Monad.State

[3.283]

[3.1947]

-- import Control.Monad.State
replacement in server/Aftok/Snaplet/Auth.hs at line 16

[3.527]→[3.527:564](∅→∅)

import Snap.Snaplet.PostgresqlSimple

[3.527]

[3.564]

-- import Snap.Snaplet.PostgresqlSimple
edit in server/Aftok/Snaplet/Auth.hs at line 34

[3.1742]→[3.1742:1780](∅→∅)

QDB{..} <- view qdb <$> with qm get
replacement in server/Aftok/Snaplet/Auth.hs at line 35

[3.1458]→[3.1458:1524](∅→∅)

qdbUser <- liftPG . runReaderT $ findUserByUserName currentUser

[3.1458]

[3.2024]

qdbUser <- snapEval $ findUserByName currentUser
replacement in server/Aftok/Snaplet/Auth.hs at line 40

[3.2162]→[3.4020:4106](∅→∅),[3.4106]→[3.2062:2100](∅→∅),[3.2252]→[3.2062:2100](∅→∅)

requireProjectAccess :: Handler App App (UserId, ProjectId)
requireProjectAccess = do
QDB{..} <- view qdb <$> with qm get

[3.2162]

[3.2252]

requireProjectId :: Handler App App ProjectId
requireProjectId = do
replacement in server/Aftok/Snaplet/Auth.hs at line 44

[3.2346]→[3.2346:2445](∅→∅),[3.2445]→[3.2101:2120](∅→∅),[3.2120]→[3.4107:4134](∅→∅),[3.4134]→[3.2120:2181](∅→∅),[3.2120]→[3.2120:2181](∅→∅),[3.2181]→[3.8101:8146](∅→∅),[3.8146]→[3.4135:4164](∅→∅),[3.2233]→[3.4135:4164](∅→∅),[3.4164]→[3.2255:2361](∅→∅),[3.2255]→[3.2255:2361](∅→∅)

Nothing -> snapError 403 "Value of parameter projectId could not be parsed to a valid value."
Just pid -> do
uid <- requireUserId
projects <- liftPG . runReaderT $ findUserProjects uid
if any (\p -> p ^. _1 == pid) projects
then pure (uid, pid)
else snapError 403 $ "User " ++ (tshow uid) ++ " does not have access to project " ++ (tshow pid)

[3.2346]

[3.2558]

Nothing -> snapError 400 "Value of parameter projectId could not be parsed to a valid value."
Just pid -> pure pid
edit in server/Aftok/Snaplet/Projects.hs at line 7

[3.2486]→[3.2486:2533](∅→∅)

import Control.Lens
import Control.Monad.State
edit in server/Aftok/Snaplet/Projects.hs at line 15

[3.2688]→[3.2688:2725](∅→∅)

import Snap.Snaplet.PostgresqlSimple
replacement in server/Aftok/Snaplet/Projects.hs at line 16

[3.2726]→[3.2726:2791](∅→∅)

data CreateProject = CreateProject { createProjectName :: Text }

[3.2726]

[3.2791]

data CProject = CP { cpn :: Text, cpdepf :: DepreciationFunction }
replacement in server/Aftok/Snaplet/Projects.hs at line 18

[3.2792]→[3.2792:2892](∅→∅)

instance FromJSON CreateProject where
parseJSON (Object v) = CreateProject <$> v .: "projectName"

[3.2792]

[3.2892]

instance FromJSON CProject where
parseJSON (Object v) = CP <$> v .: "projectName" <*> v .: "depf"
edit in server/Aftok/Snaplet/Projects.hs at line 24

[3.3132]→[3.3132:3170](∅→∅)

QDB{..} <- view qdb <$> with qm get
replacement in server/Aftok/Snaplet/Projects.hs at line 28

[3.3357]→[3.3357:3442](∅→∅)

liftPG . runReaderT . createProject $ Project (createProjectName cp) timestamp uid

[3.3357]

[3.3442]

snapEval . createProject $ Project (cpn cp) timestamp uid (cpdepf cp)
replacement in server/Aftok/Snaplet/Projects.hs at line 30

[3.3443]→[3.1382:1433](∅→∅)

projectListHandler :: Handler App App [QDBProject]

[3.3443]

[3.1433]

projectListHandler :: Handler App App [KeyedProject]
edit in server/Aftok/Snaplet/Projects.hs at line 32

[3.1457]→[3.1457:1495](∅→∅)

QDB{..} <- view qdb <$> with qm get
replacement in server/Aftok/Snaplet/Projects.hs at line 33

[3.1518]→[3.1518:1563](∅→∅)

liftPG . runReaderT $ findUserProjects uid

[3.1518]

[3.1563]

snapEval $ findUserProjects uid
replacement in server/Aftok/Snaplet/Projects.hs at line 37

[3.3469]→[3.3469:3507](∅→∅),[3.3507]→[3.4166:4205](∅→∅),[3.4205]→[3.3564:3610](∅→∅),[3.3564]→[3.3564:3610](∅→∅)

QDB{..} <- view qdb <$> with qm get
pid <- fmap snd requireProjectAccess
mp <- liftPG . runReaderT $ findProject pid

[3.3469]

[3.3610]

uid <- requireUserId
pid <- requireProjectId
mp <- snapEval $ findProject pid uid
edit in server/Aftok/Snaplet/Users.hs at line 10

[3.115]→[3.115:142](∅→∅)

import Control.Monad.State
edit in server/Aftok/Snaplet/Users.hs at line 19

[3.3729]→[3.230:267](∅→∅)

import Snap.Snaplet.PostgresqlSimple
replacement in server/Aftok/Snaplet/Users.hs at line 20

[3.269]→[3.269:298](∅→∅)

data CreateUser = CreateUser

[3.269]

[3.298]

data CUser = CU
replacement in server/Aftok/Snaplet/Users.hs at line 24

[3.349]→[3.349:373](∅→∅)

makeLenses ''CreateUser

[3.349]

[3.4305]

makeLenses ''CUser
replacement in server/Aftok/Snaplet/Users.hs at line 26

[3.4306]→[3.374:409](∅→∅)

instance FromJSON CreateUser where

[3.4306]

[3.409]

instance FromJSON CUser where
replacement in server/Aftok/Snaplet/Users.hs at line 31

[3.572]→[3.572:634](∅→∅)

in CreateUser <$> u <*> (fromString <$> v .: "password")

[3.572]

[3.634]

in CU <$> u <*> (fromString <$> v .: "password")
edit in server/Aftok/Snaplet/Users.hs at line 36

[3.678]→[3.678:716](∅→∅)

QDB{..} <- view qdb <$> with qm get
replacement in server/Aftok/Snaplet/Users.hs at line 39

[3.3691]→[3.3691:3764](∅→∅)

createQUser = liftPG $ runReaderT (createUser $ userData ^. cuser)

[3.3691]

[3.3764]

createQUser = snapEval (createUser $ userData ^. cuser)
edit in server/Aftok/Snaplet/WorkLog.hs at line 6

[3.5565]→[3.5565:5592](∅→∅)

import Control.Monad.State
edit in server/Aftok/Snaplet/WorkLog.hs at line 23

[3.5793]→[3.5793:5830](∅→∅)

import Snap.Snaplet.PostgresqlSimple
edit in server/Aftok/Snaplet/WorkLog.hs at line 24

[3.5831]→[3.8217:8282](∅→∅)

-- TODO: ignore "duplicate" events within some small time limit?
replacement in server/Aftok/Snaplet/WorkLog.hs at line 26

[3.3246]→[3.5933:5971](∅→∅),[3.3369]→[3.5933:5971](∅→∅),[3.5933]→[3.5933:5971](∅→∅),[3.5971]→[3.4709:4746](∅→∅)

QDB{..} <- view qdb <$> with qm get
(uid, pid) <- requireProjectAccess

[3.3246]

[3.5971]

uid <- requireUserId
pid <- requireProjectId
replacement in server/Aftok/Snaplet/WorkLog.hs at line 32

[3.6216]→[3.6216:6308](∅→∅)

Nothing -> snapError 400 $ "Unable to parse bitcoin address from " <> (tshow addrBytes)

[3.6216]

[3.8283]

Nothing ->
snapError 400 $ "Unable to parse bitcoin address from " <> (tshow addrBytes)
replacement in server/Aftok/Snaplet/WorkLog.hs at line 35

[3.8301]→[3.8301:8477](∅→∅)

let logEntry a = LogEntry a (evCtr timestamp) (A.decode requestBody)
storeEv a = runReaderT . createEvent pid uid $ logEntry a
in liftPG $ storeEv addr

[3.8301]

[3.6347]

snapEval $ createEvent pid uid (LogEntry addr (evCtr timestamp) (A.decode requestBody))
replacement in server/Aftok/Snaplet/WorkLog.hs at line 39

[3.3456]→[3.6436:6474](∅→∅),[3.6436]→[3.6436:6474](∅→∅),[3.6474]→[3.4819:4858](∅→∅),[3.4858]→[3.1619:1661](∅→∅),[3.3515]→[3.1619:1661](∅→∅)

QDB{..} <- view qdb <$> with qm get
pid <- fmap snd requireProjectAccess
liftPG . runReaderT $ readWorkIndex pid

[3.3456]

[3.6631]

uid <- requireUserId
pid <- requireProjectId
snapEval $ readWorkIndex pid uid
replacement in server/Aftok/Snaplet/WorkLog.hs at line 45

[3.4930]→[3.4930:5005](∅→∅)

QDB{..} <- view qdb <$> with qm get
(uid, pid) <- requireProjectAccess

[3.4930]

[3.5005]

uid <- requireUserId
pid <- requireProjectId
replacement in server/Aftok/Snaplet/WorkLog.hs at line 53

[3.8589]→[3.5337:5385](∅→∅),[3.5337]→[3.5337:5385](∅→∅)

liftPG . runReaderT $ findEvents pid uid ival

[3.8589]

[3.5385]

snapEval $ findEvents pid uid ival
replacement in server/Aftok/Snaplet/WorkLog.hs at line 57

[3.3671]→[3.6705:6744](∅→∅),[3.6705]→[3.6705:6744](∅→∅),[3.6744]→[3.8590:8682](∅→∅)

(QModules QDB{..} df) <- with qm get
pid <- fmap snd requireProjectAccess
widx <- liftPG . runReaderT $ readWorkIndex pid

[3.3671]

[3.3065]

uid <- requireUserId
pid <- requireProjectId
projectMay <- snapEval $ findProject pid uid
project <- maybe (snapError 400 $ "Project not found for id " <> tshow pid) pure projectMay
widx <- snapEval $ readWorkIndex pid uid
replacement in server/Aftok/Snaplet/WorkLog.hs at line 63

[3.3102]→[3.1705:1736](∅→∅),[3.6779]→[3.1705:1736](∅→∅)

pure $ payouts df ptime widx

[3.3102]

[3.3781]

pure $ payouts (toDepF $ project ^. depf) ptime widx
replacement in server/Aftok/Snaplet/WorkLog.hs at line 67

[3.8755]→[3.8755:8828](∅→∅)

QDB{..} <- view qdb <$> with qm get
(uid, _) <- requireProjectAccess

[3.8755]

[3.8828]

uid <- requireUserId
edit in server/Aftok/Snaplet/WorkLog.hs at line 73

[3.9000]→[3.5479:5480](∅→∅),[3.5479]→[3.5479:5480](∅→∅),[3.5480]→[3.9001:9146](∅→∅)

ev <- liftPG . runReaderT $ findEvent eventId
(_, _, uid', _) <- maybe (snapError 404 ("Event not found for id " <> tshow eventId)) pure ev
replacement in server/Aftok/Snaplet/WorkLog.hs at line 75

[3.9233]→[3.9233:9487](∅→∅)

if uid' == uid
then either
(snapError 400 . pack)
(liftPG . runReaderT . amendEvent eventId)
(parseEither (parseEventAmendment modTime) requestJSON)
else
(snapError 403 "You do not have permission to view this event.")

[3.9233]

either
(snapError 400 . pack)
(snapEval . amendEvent uid eventId)
(parseEither (parseEventAmendment modTime) requestJSON)
edit in server/Aftok/Snaplet.hs at line 11

[3.9522]→[3.1290:1324](∅→∅),[3.1290]→[3.1290:1324](∅→∅)

import Database.PostgreSQL.Simple
replacement in server/Aftok/Snaplet.hs at line 14

[2.3072]→[2.3072:3093](∅→∅)

import Aftok.TimeLog

[2.3072]

[3.1432]

import Aftok.Util
edit in server/Aftok/Snaplet.hs at line 21

[3.1576]→[3.1576:1688](∅→∅)

data QModules = QModules
{ _qdb :: QDB (ReaderT Connection IO)
, _depf :: DepF
}
makeLenses ''QModules
replacement in server/Aftok/Snaplet.hs at line 23

[3.1705]→[3.1705:1770](∅→∅)

{ _qm :: Snaplet QModules
, _sess :: Snaplet SessionManager

[3.1705]

[3.1770]

{ _sess :: Snaplet SessionManager
replacement in server/Aftok/Snaplet.hs at line 33

[3.2007]→[3.2007:2227](∅→∅)

-- | FIXME, make configurable
qdbpgSnapletInit :: SnapletInit a QModules
qdbpgSnapletInit = makeSnaplet "qdbpg" "QDB on Postgresql" Nothing $ do
pure $ QModules postgresQDB $ linearDepreciation (Months 6) (Months 60)

[3.2007]

[3.4063]

snapEval :: DBProg a -> Handler App App a
snapEval p = liftPG . runReaderT . runQDBM $ interpret dbEval p
edit in server/Main.hs at line 33

[2.3379]→[3.2219:2273](∅→∅),[3.8476]→[3.2219:2273](∅→∅)

qms <- nestSnaplet "qmodules" qm qdbpgSnapletInit
replacement in server/Main.hs at line 64

[3.9014]→[3.217:252](∅→∅)

return $ App qms sesss pgs auths

[3.9014]

[3.1077]

return $ App sesss pgs auths