nuttycom/aftok - Change QMRKFEPGFBCEWAIXPEIG5ILKAJ2JH5L3TOITHR4HNJXK5FN3KXBQC

Refactor QDB to use a free monad algebra instead.

Created by Kris Nuttycombe on June 13, 2015

QMRKFEPGFBCEWAIXPEIG5ILKAJ2JH5L3TOITHR4HNJXK5FN3KXBQC

Dependencies

In channels

main

Change contents

Insertion in aftok.cabal at line 30 [3.1]
[2.429]
[2.429]
```
                      Aftok.Util
```
Insertion in aftok.cabal at line 45 [3.1]
[4.2726]
[4.2726]
```
    , free
```
Insertion in aftok.cabal at line 49 [3.1]
[4.2841]
[4.2841]
```
    , kan-extensions
```
Replacement in lib/Aftok/Database/PostgreSQL.hs at line 1 [5.456]
B:BD[5.532] → [5.532:565]
```
{-# LANGUAGE TemplateHaskell #-}
```
[5.456]
[5.565]
```
{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
```
Replacement in lib/Aftok/Database/PostgreSQL.hs at line 3 [5.456]
B:BD[5.566] → [2.1048:1101]
```
module Aftok.Database.PostgreSQL (postgresQDB) where
```
[5.566]
[5.622]
```
module Aftok.Database.PostgreSQL (QDBM(..)) where
```
Insertion in lib/Aftok/Database/PostgreSQL.hs at line 8 [5.456]
[5.713]
[6.73]
```
import Data.Aeson(toJSON)
```

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 28 [5.456]

B:BD[7.1124] → [7.1124:1158]

type QDBM = ReaderT Connection IO

[7.1124]

[5.1123]

newtype QDBM a = QDBM { runQDBM :: ReaderT Connection IO a }
  deriving (Functor, Applicative, Monad)

Deletion in lib/Aftok/Database/PostgreSQL.hs at line 49 [5.456]
∅:D[8.765] → [9.223:224]
B:BD[9.223] → [9.223:224]
B:BD[9.224] → [6.165:240]
```
eidParser :: FieldParser EventId
eidParser f v = EventId <$> fromField f v
```
Replacement in lib/Aftok/Database/PostgreSQL.hs at line 89 [5.456]
B:BD[5.2598] → [6.425:468]
```
qdbLogEntryParser :: RowParser QDBLogEntry
```
[5.2598]
[6.468]
```
qdbLogEntryParser :: RowParser KeyedLogEntry
```

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 91 [5.456]

B:BD[6.489] → [6.489:554]

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

[6.489]

[6.554]

  (,,) <$> fieldWith pidParser

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 113 [5.456]
B:BD[5.2935] → [6.1011:1046]
```
qdbUserParser :: RowParser QDBUser
```
[5.2935]
[6.1046]
```
qdbUserParser :: RowParser KeyedUser
```
Insertion in lib/Aftok/Database/PostgreSQL.hs at line 123 [5.456]
[6.1244]
[10.313]
```
          <*> fieldWith fromJSONField
```
Replacement in lib/Aftok/Database/PostgreSQL.hs at line 125 [5.456]
B:BD[10.314] → [6.1245:1286]
```
qdbProjectParser :: RowParser QDBProject
```
[10.314]
[6.1286]
```
qdbProjectParser :: RowParser KeyedProject
```
Replacement in lib/Aftok/Database/PostgreSQL.hs at line 131 [5.456]
B:BD[6.1410] → [6.1410:1425]
```
pexec q d = do
```
[6.1410]
[6.1425]
```
pexec q d = QDBM $ do
```
Replacement in lib/Aftok/Database/PostgreSQL.hs at line 136 [5.456]
B:BD[6.1527] → [6.1527:1546]
```
pinsert f q d = do
```
[6.1527]
[5.3172]
```
pinsert f q d = QDBM $ do
```
Replacement in lib/Aftok/Database/PostgreSQL.hs at line 142 [5.456]
B:BD[6.1676] → [6.1676:1694]
```
pquery p q d = do
```
[6.1676]
[7.1320]
```
pquery p q d = QDBM $ do
```

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 146 [5.456]

B:BD[7.1362] → [11.295:359]

B:BD[11.359] → [6.1726:1806]

∅:D[6.1806] → [7.1510:1666]

B:BD[7.1510] → [7.1510:1666]

∅:D[7.1666] → [12.523:538]

∅:D[13.3644] → [12.523:538]

B:BD[12.523] → [12.523:538]

B:BD[12.538] → [13.3645:3665]

B:BD[13.3665] → [8.1025:1043]

B:BD[8.1043] → [4.225:258]

∅:D[4.258] → [8.1073:1081]

B:BD[8.1073] → [8.1073:1081]

∅:D[8.1081] → [5.3399:3405]

∅:D[13.3687] → [5.3399:3405]

B:BD[5.3399] → [5.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
    )

[7.1362]

[6.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 [5.456]

B:BD[6.1808] → [6.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

[6.1808]

[5.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 [5.456]

B:BD[5.3406] → [4.259:374]

B:BD[4.374] → [6.2098:2130]

∅:D[6.2130] → [4.402:585]

B:BD[4.402] → [4.402:585]

B:BD[4.585] → [6.2131:2165]

∅:D[6.2165] → [4.615:841]

B:BD[4.615] → [4.615:841]

B:BD[4.841] → [6.2166:2197]

∅:D[6.2197] → [4.868:1051]

B:BD[4.868] → [4.868:1051]

B:BD[4.1051] → [6.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

[5.3406]

[4.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 [5.456]

B:BD[4.1084] → [6.2227:2288]

∅:D[6.2288] → [7.1768:1815]

B:BD[7.1768] → [7.1768:1815]

B:BD[7.1815] → [6.2289:2414]

∅:D[6.2414] → [14.264:317]

B:BD[7.1920] → [14.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 )

[4.1084]

[7.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 [5.456]

B:BD[7.1952] → [7.1952:2005]

B:BD[7.2005] → [6.2415:2538]

∅:D[6.2538] → [14.318:376]

B:BD[7.2108] → [14.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 )

[7.1952]

[7.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 [5.456]

B:BD[7.2157] → [7.2157:2208]

B:BD[7.2208] → [6.2539:2708]

∅:D[14.420] → [7.2346:2393]

∅:D[6.2708] → [7.2346:2393]

B:BD[7.2346] → [7.2346:2393]

∅:D[7.2393] → [12.602:626]

B:BD[12.602] → [12.602:626]

B:BD[12.626] → [6.2709:2747]

∅:D[6.2747] → [4.1085:1186]

B:BD[7.2411] → [4.1085:1186]

∅:D[9.405] → [12.740:762]

∅:D[4.1186] → [12.740:762]

B:BD[12.740] → [12.740:762]

B:BD[12.762] → [6.2748:2778]

∅:D[6.2778] → [5.3624:3625]

B:BD[5.3624] → [5.3624:3625]

B:BD[5.3625] → [11.425:482]

B:BD[11.482] → [6.2779:2926]

∅:D[6.2926] → [12.954:1029]

B:BD[12.954] → [12.954:1029]

B:BD[5.3928] → [5.3928:3929]

B:BD[5.3929] → [11.511:585]

B:BD[11.585] → [6.2927:3026]

∅:D[6.3026] → [5.4129:4162]

B:BD[5.4129] → [5.4129:4162]

B:BD[5.4162] → [6.3027:3053]

∅:D[6.3053] → [5.4200:4201]

B:BD[5.4200] → [5.4200:4201]

B:BD[5.4201] → [6.3054:3099]

∅:D[6.3099] → [11.628:666]

B:BD[11.628] → [11.628:666]

B:BD[11.666] → [6.3100:3241]

∅:D[15.159] → [5.4444:4597]

∅:D[6.3241] → [5.4444:4597]

B:BD[5.4444] → [5.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
    )

[7.2157]

[5.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 [5.456]

B:BD[5.4598] → [7.2615:2652]

B:BD[7.2652] → [6.3242:3280]

∅:D[7.2670] → [5.4715:4837]

∅:D[6.3280] → [5.4715:4837]

B:BD[5.4715] → [5.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))

[5.4598]

[5.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 [5.456]

B:BD[5.4862] → [7.2671:2706]

B:BD[7.2706] → [6.3281:3319]

∅:D[7.2724] → [15.160:240]

∅:D[6.3319] → [15.160:240]

B:BD[5.4978] → [15.160:240]

B:BD[15.240] → [13.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)

[5.4862]

[5.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 [5.456]

B:BD[5.5183] → [7.2725:2766]

∅:D[7.2766] → [5.5241:5269]

B:BD[5.5241] → [5.5241:5269]

B:BD[5.5269] → [6.3320:3349]

∅:D[7.2785] → [5.5312:5388]

∅:D[6.3349] → [5.5312:5388]

B:BD[5.5312] → [5.5312:5388]

B:BD[5.5388] → [6.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

[5.5183]

[5.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 [5.456]

B:BD[5.5425] → [7.2786:2842]

∅:D[7.2842] → [10.501:539]

B:BD[10.501] → [10.501:539]

B:BD[10.539] → [6.3374:3406]

∅:D[7.2861] → [10.582:664]

∅:D[6.3406] → [10.582:664]

B:BD[10.582] → [10.582:664]

B:BD[10.664] → [6.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

[5.5425]

[5.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 [5.456]

B:BD[5.5525] → [7.2862:2906]

∅:D[7.2906] → [16.683:705]

B:BD[16.683] → [16.683:705]

B:BD[16.705] → [17.4:41]

B:BD[17.41] → [6.3431:3458]

∅:D[7.2924] → [16.747:849]

∅:D[6.3458] → [16.747:849]

B:BD[16.747] → [16.747:849]

B:BD[16.849] → [17.42:90]

B:BD[17.90] → [6.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

[5.5525]

[11.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 [5.456]

B:BD[11.668] → [11.668:752]

B:BD[11.752] → [6.3589:3624]

∅:D[6.3624] → [11.773:871]

B:BD[11.773] → [11.773:871]

B:BD[11.871] → [6.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

[11.668]

[10.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 [5.456]

B:BD[10.705] → [7.2941:2990]

B:BD[7.2990] → [6.3652:3712]

∅:D[7.3011] → [16.1111:1180]

∅:D[6.3712] → [16.1111:1180]

B:BD[16.1111] → [16.1111:1180]

B:BD[16.1180] → [17.274:348]

B:BD[17.348] → [6.3713:3740]

∅:D[6.3740] → [17.380:395]

B:BD[17.380] → [17.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)

[10.705]

[16.1368]

  dbEval (FindUser (UserId uid)) = do
    users <- pquery userParser
      "SELECT handle, btc_addr, email FROM users WHERE id = ?"
      (Only uid)
    pure $ headMay users

Insertion in lib/Aftok/Database/PostgreSQL.hs at line 242 [5.456]

[16.1369]

[6.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 [5.456]

∅:D[6.3742] → [7.3012:3036]

B:BD[16.1369] → [7.3012:3036]

∅:D[7.3036] → [5.5568:5587]

B:BD[5.5568] → [5.5568:5587]

B:BD[5.5587] → [11.914:945]

∅:D[11.945] → [7.3037:3066]

B:BD[5.5618] → [7.3037:3066]

B:BD[7.3066] → [6.3743:3770]

∅:D[6.3770] → [4.1187:1216]

B:BD[7.3066] → [4.1187:1216]

∅:D[4.1216] → [5.5618:5654]

∅:D[7.3066] → [5.5618:5654]

B:BD[5.5618] → [5.5618:5654]

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

[6.3742]

[11.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 [5.456]

B:BD[11.947] → [11.947:1013]

  , createAuction = createAuction'
  , findAuction = findAuction'

[11.947]

[11.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 [5.456]

B:BD[11.1014] → [11.1014:1041]

∅:D[11.1041] → [5.5741:5766]

B:BD[5.5741] → [5.5741:5766]

  , createBid = createBid'
  , readBids = readBids'

[11.1014]

[11.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 [5.456]

∅:D[11.1043] → [5.5766:5820]

B:BD[5.5766] → [5.5766:5820]

B:BD[5.5820] → [10.706:751]

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

[11.1043]

[11.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 [5.456]
∅:D[11.1045] → [16.1371:1406]
B:BD[10.751] → [16.1371:1406]
B:BD[16.1406] → [11.1046:1077]
∅:D[11.1077] → [16.1406:1447]
B:BD[16.1406] → [16.1406:1447]
∅:D[10.751] → [5.5861:5865]
∅:D[16.1447] → [5.5861:5865]
B:BD[5.5861] → [5.5861:5865]
```
  , createProject = createProject'
  , findProject = findProject'
  , findUserProjects = findUserProjects'
  }
```
[11.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]
B:BD[3.4936] → [18.5:38]
```
{-# LANGUAGE TemplateHaskell #-}
```
[3.4936]
[19.426]
```
{-# LANGUAGE GADTs #-}
```
Insertion in lib/Aftok/Database.hs at line 6 [3.4936]
[20.838]
[5.6576]
```
import Control.Lens
```

Insertion in lib/Aftok/Database.hs at line 12 [3.4936]

[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.4936]

B:BD[3.5045] → [6.3772:3904]

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

[3.5045]

[12.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.4936]

B:BD[5.6669] → [5.6669:6687]

B:BD[5.6687] → [11.1079:1145]

B:BD[11.1145] → [6.3905:4023]

∅:D[6.4023] → [4.1244:1314]

B:BD[7.3190] → [4.1244:1314]

∅:D[4.1314] → [21.296:342]

∅:D[7.3190] → [21.296:342]

B:BD[21.296] → [21.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

[12.1390]

[11.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.4936]

B:BD[11.1147] → [11.1147:1256]

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

[11.1147]

[6.4024]

findEvent :: EventId -> DBProg (Maybe KeyedLogEntry)
findEvent = fc . FindEvent

Replacement in lib/Aftok/Database.hs at line 108 [3.4936]

B:BD[6.4025] → [6.4025:4074]

∅:D[11.1302] → [12.1598:1640]

∅:D[6.4074] → [12.1598:1640]

B:BD[12.1598] → [12.1598:1640]

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

[6.4025]

[11.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.4936]

∅:D[11.1304] → [21.578:662]

∅:D[12.1640] → [21.578:662]

B:BD[21.578] → [21.578:662]

∅:D[21.662] → [10.799:855]

B:BD[5.7012] → [10.799:855]

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

[11.1304]

[11.1305]

readWorkIndex :: ProjectId -> UserId -> DBProg WorkIndex
readWorkIndex pid uid = withProjectAuth pid uid $ ReadWorkIndex pid

Deletion in lib/Aftok/Database.hs at line 114 [3.4936]
∅:D[11.1306] → [16.1449:1493]
B:BD[10.855] → [16.1449:1493]
B:BD[16.1493] → [11.1307:1359]
∅:D[11.1359] → [12.1641:1690]
∅:D[16.1493] → [12.1641:1690]
B:BD[10.855] → [12.1641:1690]
∅:D[10.855] → [3.5159:5163]
∅:D[22.1688] → [3.5159:5163]
∅:D[12.1690] → [3.5159:5163]
∅:D[23.1725] → [3.5159:5163]
∅:D[24.5930] → [3.5159:5163]
∅:D[5.7064] → [3.5159:5163]
B:BD[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 [25.19]
B:BD[25.486] → [11.1514:1552]
```
qdbProjectJSON :: QDBProject -> Value
```
[25.486]
[6.5170]
```
qdbProjectJSON :: KeyedProject -> Value
```
Replacement in lib/Aftok/TimeLog.hs at line 10 [27.846]
∅:D[11.2184] → [26.3:12]
∅:D[7.5508] → [26.3:12]
B:BD[28.3635] → [26.3:12]
```
  , DepF
```
[11.2184]
[11.2185]
```
  , DepF, toDepF
```
Deletion in lib/Aftok/TimeLog.hs at line 15 [27.846]
∅:D[26.12] → [3.5326:5345]
∅:D[7.5608] → [3.5326:5345]
∅:D[6.6623] → [3.5326:5345]
B:BD[29.24] → [3.5326:5345]
```
  , Months(Months)
```

Insertion in lib/Aftok/TimeLog.hs at line 98 [27.846]

[27.2354]

[30.344]

toDepF :: DepreciationFunction -> DepF
toDepF (LinearDepreciation undepLength depLength)  = linearDepreciation undepLength depLength

Replacement in lib/Aftok/TimeLog.hs at line 106 [27.846]

B:BD[14.1502] → [14.1502:1576]

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

[14.1502]

[14.1576]

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

Deletion in lib/Aftok/TimeLog.hs at line 164 [27.846]
B:BD[31.23] → [31.23:57]
```
newtype Months = Months Integer 
```

Replacement in lib/Aftok/TimeLog.hs at line 167 [27.846]

B:BD[14.2121] → [14.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 =

[14.2121]

[14.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 [27.846]

B:BD[14.2537] → [14.2537:2613]

      maxDepreciable = monthsLength undepPeriod ^+^ monthsLength depPeriod

[14.2537]

[33.970]

      maxDepreciable = monthsLength undepLength ^+^ monthsLength depLength

Replacement in lib/Aftok/TimeLog.hs at line 179 [27.846]

B:BD[26.508] → [26.508:556]

        if dt < monthsLength undepPeriod then 1

[26.508]

[14.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 [27.2457]

B:BD[27.2457] → [34.1742:1794]

{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-}

[27.2457]

[19.1126]

{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, DeriveDataTypeable #-}

Replacement in lib/Aftok.hs at line 7 [27.2457]
∅:D[12.2690] → [34.1818:1838]
B:BD[19.1149] → [34.1818:1838]
```
import Control.Lens
```
[12.2690]
[4.2203]
```
import Control.Lens(makePrisms, makeLenses)
import Data.Aeson
import Data.Aeson.Types
import Data.Data
```

Insertion in lib/Aftok.hs at line 19 [27.2457]

[13.4286]

[27.2763]


newtype Months = Months Integer 
  deriving (Eq, Show, Data, Typeable)

Insertion in lib/Aftok.hs at line 23 [27.2457]

[27.2764]

[4.2221]

data DepreciationFunction = LinearDepreciation Months Months
  deriving (Eq, Show, Data, Typeable)

Insertion in lib/Aftok.hs at line 46 [27.2457]
[12.3168]
[12.3168]
```
  , _depf :: DepreciationFunction
```

Insertion in lib/Aftok.hs at line 68 [27.2457]

[12.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 [35.203]
B:BD[35.283] → [35.283:310]
```
import Control.Monad.State
```
[35.283]
[15.1947]
```
-- import Control.Monad.State
```
Replacement in server/Aftok/Snaplet/Auth.hs at line 16 [35.203]
B:BD[35.527] → [35.527:564]
```
import Snap.Snaplet.PostgresqlSimple
```
[35.527]
[35.564]
```
-- import Snap.Snaplet.PostgresqlSimple
```
Deletion in server/Aftok/Snaplet/Auth.hs at line 34 [35.203]
B:BD[35.1742] → [35.1742:1780]
```
  QDB{..} <- view qdb <$> with qm get
```

Replacement in server/Aftok/Snaplet/Auth.hs at line 35 [35.203]

B:BD[17.1458] → [17.1458:1524]

  qdbUser <- liftPG . runReaderT $ findUserByUserName currentUser

[17.1458]

[35.2024]

  qdbUser <- snapEval $ findUserByName currentUser

Replacement in server/Aftok/Snaplet/Auth.hs at line 40 [35.203]

B:BD[35.2162] → [4.4020:4106]

∅:D[4.4106] → [15.2062:2100]

B:BD[35.2252] → [15.2062:2100]

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

[35.2162]

[35.2252]

requireProjectId :: Handler App App ProjectId
requireProjectId = do

Replacement in server/Aftok/Snaplet/Auth.hs at line 44 [35.203]

B:BD[35.2346] → [35.2346:2445]

B:BD[35.2445] → [15.2101:2120]

B:BD[15.2120] → [4.4107:4134]

∅:D[4.4134] → [15.2120:2181]

B:BD[15.2120] → [15.2120:2181]

B:BD[15.2181] → [6.8101:8146]

∅:D[6.8146] → [4.4135:4164]

B:BD[15.2233] → [4.4135:4164]

∅:D[4.4164] → [15.2255:2361]

B:BD[15.2255] → [15.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)

[35.2346]

[35.2558]

    Nothing  -> snapError 400 "Value of parameter projectId could not be parsed to a valid value."
    Just pid -> pure pid

Deletion in server/Aftok/Snaplet/Projects.hs at line 7 [15.2363]
B:BD[15.2486] → [15.2486:2533]
```
import Control.Lens
import Control.Monad.State
```
Deletion in server/Aftok/Snaplet/Projects.hs at line 15 [15.2363]
B:BD[15.2688] → [15.2688:2725]
```
import Snap.Snaplet.PostgresqlSimple
```

Replacement in server/Aftok/Snaplet/Projects.hs at line 16 [15.2363]

B:BD[15.2726] → [15.2726:2791]

data CreateProject = CreateProject { createProjectName :: Text }

[15.2726]

[15.2791]

data CProject = CP { cpn :: Text, cpdepf :: DepreciationFunction }

Replacement in server/Aftok/Snaplet/Projects.hs at line 18 [15.2363]

B:BD[15.2792] → [15.2792:2892]

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

[15.2792]

[15.2892]

instance FromJSON CProject where
  parseJSON (Object v) = CP <$> v .: "projectName" <*> v .: "depf"

Deletion in server/Aftok/Snaplet/Projects.hs at line 24 [15.2363]
B:BD[15.3132] → [15.3132:3170]
```
  QDB{..} <- view qdb <$> with qm get
```

Replacement in server/Aftok/Snaplet/Projects.hs at line 28 [15.2363]

B:BD[15.3357] → [15.3357:3442]

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

[15.3357]

[15.3442]

  snapEval . createProject $ Project (cpn cp) timestamp uid (cpdepf cp)

Replacement in server/Aftok/Snaplet/Projects.hs at line 30 [15.2363]
B:BD[15.3443] → [36.1382:1433]
```
projectListHandler :: Handler App App [QDBProject]
```
[15.3443]
[36.1433]
```
projectListHandler :: Handler App App [KeyedProject]
```
Deletion in server/Aftok/Snaplet/Projects.hs at line 32 [15.2363]
B:BD[36.1457] → [36.1457:1495]
```
  QDB{..} <- view qdb <$> with qm get
```
Replacement in server/Aftok/Snaplet/Projects.hs at line 33 [15.2363]
B:BD[36.1518] → [36.1518:1563]
```
  liftPG . runReaderT $ findUserProjects uid
```
[36.1518]
[36.1563]
```
  snapEval $ findUserProjects uid
```

Replacement in server/Aftok/Snaplet/Projects.hs at line 37 [15.2363]

B:BD[11.3469] → [11.3469:3507]

B:BD[11.3507] → [4.4166:4205]

∅:D[4.4205] → [11.3564:3610]

B:BD[11.3564] → [11.3564:3610]

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

[11.3469]

[11.3610]

  uid <- requireUserId
  pid <- requireProjectId
  mp <- snapEval $ findProject pid uid

Deletion in server/Aftok/Snaplet/Users.hs at line 10 [37.3234]
B:BD[18.115] → [18.115:142]
```
import Control.Monad.State
```
Deletion in server/Aftok/Snaplet/Users.hs at line 19 [37.3234]
B:BD[37.3729] → [18.230:267]
```
import Snap.Snaplet.PostgresqlSimple
```
Replacement in server/Aftok/Snaplet/Users.hs at line 20 [37.3234]
B:BD[18.269] → [18.269:298]
```
data CreateUser = CreateUser
```
[18.269]
[18.298]
```
data CUser = CU
```
Replacement in server/Aftok/Snaplet/Users.hs at line 24 [37.3234]
B:BD[18.349] → [18.349:373]
```
makeLenses ''CreateUser
```
[18.349]
[37.4305]
```
makeLenses ''CUser
```
Replacement in server/Aftok/Snaplet/Users.hs at line 26 [37.3234]
B:BD[37.4306] → [18.374:409]
```
instance FromJSON CreateUser where
```
[37.4306]
[18.409]
```
instance FromJSON CUser where
```

Replacement in server/Aftok/Snaplet/Users.hs at line 31 [37.3234]

B:BD[18.572] → [18.572:634]

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

[18.572]

[18.634]

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

Deletion in server/Aftok/Snaplet/Users.hs at line 36 [37.3234]
B:BD[18.678] → [18.678:716]
```
  QDB{..} <- view qdb <$> with qm get
```

Replacement in server/Aftok/Snaplet/Users.hs at line 39 [37.3234]

B:BD[15.3691] → [15.3691:3764]

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

[15.3691]

[15.3764]

      createQUser = snapEval (createUser $ userData ^. cuser)

Deletion in server/Aftok/Snaplet/WorkLog.hs at line 6 [37.5424]
B:BD[37.5565] → [37.5565:5592]
```
import Control.Monad.State
```
Deletion in server/Aftok/Snaplet/WorkLog.hs at line 23 [37.5424]
B:BD[37.5793] → [37.5793:5830]
```
import Snap.Snaplet.PostgresqlSimple
```
Deletion in server/Aftok/Snaplet/WorkLog.hs at line 24 [37.5424]
B:BD[37.5831] → [6.8217:8282]
```
-- TODO: ignore "duplicate" events within some small time limit?
```
Replacement in server/Aftok/Snaplet/WorkLog.hs at line 26 [37.5424]
∅:D[8.3246] → [37.5933:5971]
∅:D[35.3369] → [37.5933:5971]
B:BD[37.5933] → [37.5933:5971]
B:BD[37.5971] → [4.4709:4746]
```
  QDB{..} <- view qdb <$> with qm get
  (uid, pid) <- requireProjectAccess
```
[8.3246]
[37.5971]
```
  uid <- requireUserId
  pid <- requireProjectId
```

Replacement in server/Aftok/Snaplet/WorkLog.hs at line 32 [37.5424]

B:BD[37.6216] → [37.6216:6308]

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

[37.6216]

[6.8283]

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

Replacement in server/Aftok/Snaplet/WorkLog.hs at line 35 [37.5424]

B:BD[6.8301] → [6.8301:8477]

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

[6.8301]

[37.6347]

      snapEval $ createEvent pid uid (LogEntry addr (evCtr timestamp) (A.decode requestBody))

Replacement in server/Aftok/Snaplet/WorkLog.hs at line 39 [37.5424]
∅:D[35.3456] → [37.6436:6474]
B:BD[37.6436] → [37.6436:6474]
B:BD[37.6474] → [4.4819:4858]
∅:D[4.4858] → [36.1619:1661]
B:BD[35.3515] → [36.1619:1661]
```
  QDB{..} <- view qdb <$> with qm get
  pid <- fmap snd requireProjectAccess
  liftPG . runReaderT $ readWorkIndex pid
```
[35.3456]
[37.6631]
```
  uid <- requireUserId
  pid <- requireProjectId
  snapEval $ readWorkIndex pid uid
```

Replacement in server/Aftok/Snaplet/WorkLog.hs at line 45 [37.5424]

B:BD[4.4930] → [4.4930:5005]

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

[4.4930]

[4.5005]

  uid <- requireUserId
  pid <- requireProjectId

Replacement in server/Aftok/Snaplet/WorkLog.hs at line 53 [37.5424]
∅:D[6.8589] → [4.5337:5385]
B:BD[4.5337] → [4.5337:5385]
```
  liftPG . runReaderT $ findEvents pid uid ival
```
[6.8589]
[4.5385]
```
  snapEval $ findEvents pid uid ival
```

Replacement in server/Aftok/Snaplet/WorkLog.hs at line 57 [37.5424]

∅:D[35.3671] → [37.6705:6744]

B:BD[37.6705] → [37.6705:6744]

B:BD[37.6744] → [6.8590:8682]

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

[35.3671]

[14.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 [37.5424]
∅:D[14.3102] → [36.1705:1736]
B:BD[37.6779] → [36.1705:1736]
```
  pure $ payouts df ptime widx
```
[14.3102]
[35.3781]
```
  pure $ payouts (toDepF $ project ^. depf) ptime widx
```
Replacement in server/Aftok/Snaplet/WorkLog.hs at line 67 [37.5424]
B:BD[6.8755] → [6.8755:8828]
```
  QDB{..} <- view qdb <$> with qm get
  (uid, _) <- requireProjectAccess
```
[6.8755]
[6.8828]
```
  uid <- requireUserId
```
Deletion in server/Aftok/Snaplet/WorkLog.hs at line 73 [37.5424]
∅:D[6.9000] → [4.5479:5480]
B:BD[4.5479] → [4.5479:5480]
B:BD[4.5480] → [6.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 [37.5424]

B:BD[6.9233] → [6.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.")

[6.9233]

  either 
    (snapError 400 . pack)
    (snapEval . amendEvent uid eventId)
    (parseEither (parseEventAmendment modTime) requestJSON)

Deletion in server/Aftok/Snaplet.hs at line 11 [37.1088]
∅:D[6.9522] → [37.1290:1324]
B:BD[37.1290] → [37.1290:1324]
```
import Database.PostgreSQL.Simple
```
Replacement in server/Aftok/Snaplet.hs at line 14 [37.1088]
B:BD[2.3072] → [2.3072:3093]
```
import Aftok.TimeLog
```
[2.3072]
[37.1432]
```
import Aftok.Util
```

Deletion in server/Aftok/Snaplet.hs at line 21 [37.1088]

B:BD[37.1576] → [37.1576:1688]


data QModules = QModules 
  { _qdb :: QDB (ReaderT Connection IO) 
  , _depf :: DepF
  }
makeLenses ''QModules

Replacement in server/Aftok/Snaplet.hs at line 23 [37.1088]
B:BD[37.1705] → [37.1705:1770]
```
  { _qm  :: Snaplet QModules
  , _sess :: Snaplet SessionManager
```
[37.1705]
[37.1770]
```
  { _sess :: Snaplet SessionManager
```

Replacement in server/Aftok/Snaplet.hs at line 33 [37.1088]

B:BD[37.2007] → [37.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)

[37.2007]

[12.4063]

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

Deletion in server/Main.hs at line 33 [38.5188]
∅:D[2.3379] → [11.2219:2273]
B:BD[5.8476] → [11.2219:2273]
```
  qms   <- nestSnaplet "qmodules" qm qdbpgSnapletInit
```
Replacement in server/Main.hs at line 64 [38.5188]
B:BD[5.9014] → [39.217:252]
```
  return $ App qms sesss pgs auths
```
[5.9014]
[40.1077]
```
  return $ App sesss pgs auths
```

Refactor QDB to use a free monad algebra instead.

Dependencies

In channels

Change contents

Insertion in aftok.cabal at line 30 [3.1]

Insertion in aftok.cabal at line 45 [3.1]

Insertion in aftok.cabal at line 49 [3.1]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 1 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 3 [5.456]

Insertion in lib/Aftok/Database/PostgreSQL.hs at line 8 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 28 [5.456]

Deletion in lib/Aftok/Database/PostgreSQL.hs at line 49 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 89 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 91 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 113 [5.456]

Insertion in lib/Aftok/Database/PostgreSQL.hs at line 123 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 125 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 131 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 136 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 142 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 146 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 159 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 166 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 182 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 187 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 192 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 197 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 203 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 209 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 215 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 226 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 231 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 236 [5.456]

Insertion in lib/Aftok/Database/PostgreSQL.hs at line 242 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 248 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 254 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 260 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 271 [5.456]

Replacement in lib/Aftok/Database/PostgreSQL.hs at line 276 [5.456]

Replacement in lib/Aftok/Database.hs at line 1 [3.4936]

Insertion in lib/Aftok/Database.hs at line 6 [3.4936]

Insertion in lib/Aftok/Database.hs at line 12 [3.4936]

Replacement in lib/Aftok/Database.hs at line 61 [3.4936]

Replacement in lib/Aftok/Database.hs at line 91 [3.4936]

Replacement in lib/Aftok/Database.hs at line 105 [3.4936]

Replacement in lib/Aftok/Database.hs at line 108 [3.4936]

Replacement in lib/Aftok/Database.hs at line 111 [3.4936]

Deletion in lib/Aftok/Database.hs at line 114 [3.4936]

Replacement in lib/Aftok/Json.hs at line 82 [25.19]

Replacement in lib/Aftok/TimeLog.hs at line 10 [27.846]

Deletion in lib/Aftok/TimeLog.hs at line 15 [27.846]

Insertion in lib/Aftok/TimeLog.hs at line 98 [27.846]

Replacement in lib/Aftok/TimeLog.hs at line 106 [27.846]

Deletion in lib/Aftok/TimeLog.hs at line 164 [27.846]

Replacement in lib/Aftok/TimeLog.hs at line 167 [27.846]

Replacement in lib/Aftok/TimeLog.hs at line 175 [27.846]

Replacement in lib/Aftok/TimeLog.hs at line 179 [27.846]

File addition: Util.hs (----------)

Replacement in lib/Aftok.hs at line 1 [27.2457]

Replacement in lib/Aftok.hs at line 7 [27.2457]

Insertion in lib/Aftok.hs at line 19 [27.2457]

Insertion in lib/Aftok.hs at line 23 [27.2457]

Insertion in lib/Aftok.hs at line 46 [27.2457]

Insertion in lib/Aftok.hs at line 68 [27.2457]

Replacement in server/Aftok/Snaplet/Auth.hs at line 6 [35.203]

Replacement in server/Aftok/Snaplet/Auth.hs at line 16 [35.203]

Deletion in server/Aftok/Snaplet/Auth.hs at line 34 [35.203]

Replacement in server/Aftok/Snaplet/Auth.hs at line 35 [35.203]

Replacement in server/Aftok/Snaplet/Auth.hs at line 40 [35.203]

Replacement in server/Aftok/Snaplet/Auth.hs at line 44 [35.203]

Deletion in server/Aftok/Snaplet/Projects.hs at line 7 [15.2363]

Deletion in server/Aftok/Snaplet/Projects.hs at line 15 [15.2363]

Replacement in server/Aftok/Snaplet/Projects.hs at line 16 [15.2363]

Replacement in server/Aftok/Snaplet/Projects.hs at line 18 [15.2363]

Deletion in server/Aftok/Snaplet/Projects.hs at line 24 [15.2363]

Replacement in server/Aftok/Snaplet/Projects.hs at line 28 [15.2363]

Replacement in server/Aftok/Snaplet/Projects.hs at line 30 [15.2363]

Deletion in server/Aftok/Snaplet/Projects.hs at line 32 [15.2363]

Replacement in server/Aftok/Snaplet/Projects.hs at line 33 [15.2363]

Replacement in server/Aftok/Snaplet/Projects.hs at line 37 [15.2363]