Work in progress replacing sqlite with postgres.

[?]

Jan 20, 2015, 3:29 PM

IZEVQF627FA7VV25KJAWYWGGC35LZUUBBQRPN5ZAINTQLPEDRTEAC

Dependencies

[2] JKMHA2QG SQLite support is now relatively sane.
[3] NJZ3DKZY THEY CAN TALK!
[4] MK7ODWHU Some minor renaming.
[5] ADMKQQGC Initial empty Snap project.
[6] 5W5M56VJ Move library code to 'lib'
[7] TZQJVHBA Add auction functions to ADB.
[8] WFZDMVUX Rename ADB -> QDB
[9] 7XN3I3QJ Add 'loggedIntervals' endpoint.
[10] 2Y2QZFVF Switch to more modern cabal2nix-based workflow.
[11] GKGVYBZG Added JSON serialization to TimeLog
[12] 7DBNV3GV Initial, stack-based impl of time log event reduction.
[13] WO2MINIF Auctions now compile!
[14] FRPWIKCN Added log event parsing to Quixotic.Database.SQLite
[15] W35DDBFY Factor common JSON conversions up into client lib module.
[16] TLQ72DSJ Lenses, sqlite-simple
[17] MWUPXTBF A few steps down a road to be abandoned.
[18] NTPC7KJE Trivial changes, feature scratchpad.
[19] Z3M53KTL Adrift.
[20] EMVTF2IW WIP moving back to snap.
[21] 64VI73NP Server now compiles using abstracted SQLite
[22] TCOAKCGG Completed conversion to snap.
[23] LAROLAYU WIP
[24] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[25] NVOCQVAS Initial failing tests.
[26] RSEB2NFG Replacing Snap with Scotty.
[27] 75N3UJ4J More progression toward lenses.
[28] WZUHEZSB Start of migration back toward snap.
[29] LUM4VQJI Increment.
[*] OBFPJS2G Project successfully builds and tests under nix.

Change contents

edit in lib/Quixotic/Auction.hs at line 7

[5.116]→[5.3:21](∅→∅),[5.5213]→[5.3:21](∅→∅)

import Data.Group
replacement in lib/Quixotic/Auction.hs at line 8

[5.43]→[5.43:59](∅→∅)

import Quixotic

[5.43]

[5.59]

import Network.Bitcoin
edit in lib/Quixotic/Auction.hs at line 13

[5.59]

[5.5248]

makePrisms ''AuctionId
edit in lib/Quixotic/Auction.hs at line 19

[5.5323]→[5.5323:5324](∅→∅)
edit in lib/Quixotic/Auction.hs at line 27

[5.122]→[5.5404:5405](∅→∅),[5.5404]→[5.5404:5405](∅→∅)
replacement in lib/Quixotic/Auction.hs at line 34

[5.241]→[5.241:301](∅→∅)

btc bid = toRational $ bid ^. (bidAmount . satoshis)

[5.241]

[5.301]

btc bid = toRational $ bid ^. bidAmount
replacement in lib/Quixotic/Auction.hs at line 43

[5.538]→[5.343:470](∅→∅)

| (total ++ x ^. bidAmount) < (auction ^. raiseAmount) =
x : (takeWinningBids (total ++ x ^. bidAmount) xs)

[5.538]

[5.652]

| total + (x ^. bidAmount) < (auction ^. raiseAmount) =
x : (takeWinningBids (total + (x ^. bidAmount)) xs)
replacement in lib/Quixotic/Auction.hs at line 47

[5.727]→[5.583:732](∅→∅),[5.732]→[5.471:581](∅→∅)

| total < auction ^. raiseAmount =
let remainder = (auction ^. raiseAmount) ++ invert total
winFraction :: Rational
winFraction = (toRational $ remainder ^. satoshis) / (toRational $ x ^. (bidAmount . satoshis))

[5.727]

[5.581]

| total < (auction ^. raiseAmount) =
let remainder = (auction ^. raiseAmount) - total
winFraction = toRational $ remainder / (x ^. bidAmount)
replacement in lib/Quixotic/Auction.hs at line 57

[5.1147]→[5.1147:1188](∅→∅)

in takeWinningBids mempty $ sort bids

[5.1147]

in takeWinningBids (fromInteger 0) $ sort bids
file addition: PostgreSQL.hs (----------)

[5.40]

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

module Quixotic.Database.PostgreSQL (postgresQDB) where

import Blaze.ByteString.Builder (fromByteString)
import ClassyPrelude
import Control.Lens
import Data.Fixed
import Data.Hourglass
import qualified Data.List as DL
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.ToField
import Database.PostgreSQL.Simple.FromField
import Database.PostgreSQL.Simple.ToRow
import Database.PostgreSQL.Simple.FromRow
import Network.Bitcoin

import Quixotic
import Quixotic.Auction
import Quixotic.Database
import Quixotic.TimeLog
import Quixotic.Users

eventTypeParser :: FieldParser EventType
eventTypeParser f v = fromField f v >>= nameEvent

uidParser :: FieldParser UserId
uidParser f v = UserId <$> fromField f v

secondsParser :: FieldParser Seconds
secondsParser f v = Seconds <$> fromField f v

usernameParser :: FieldParser UserName
usernameParser f v = UserName <$> fromField f v

btcAddrParser :: FieldParser BtcAddr
btcAddrParser f v = BtcAddr <$> fromField f v

btcParser :: FieldParser BTC
btcParser f v = fromField f v

workEventParser :: RowParser WorkEvent
workEventParser = WorkEvent <$> fieldWith eventTypeParser <*> field

logEntryParser :: RowParser LogEntry
logEntryParser = LogEntry <$> fieldWith btcAddrParser <*> workEventParser

auctionRowParser :: RowParser Auction
auctionRowParser = Auction <$> fieldWith btcParser <*> field

bidRowParser :: RowParser Bid
bidRowParser = Bid <$> fieldWith uidParser
<*> fieldWith secondsParser
<*> fieldWith btcParser
<*> field

userRowParser :: RowParser User
userRowParser = User <$> fieldWith usernameParser
<*> fieldWith btcAddrParser
<*> field

-- Local newtypes to permit field serialization
newtype PBTC = PBTC { pBTC :: BTC }
instance ToField PBTC where
toField (PBTC btc) = Plain . fromByteString . fromString $ showFixed False btc

-- Local newtypes to permit row deserialization via
-- typeclass. Wish I could just pass the RowParser instances

newtype PLogEntry = PLogEntry { pLogEntry :: LogEntry }
instance FromRow PLogEntry where
fromRow = PLogEntry <$> logEntryParser

newtype PBid = PBid { pBid :: Bid }
instance FromRow PBid where
fromRow = PBid <$> bidRowParser

newtype PUser = PUser { pUser :: User }
instance FromRow PUser where
fromRow = PUser <$> userRowParser

newtype PAuction = PAuction { pAuction :: Auction }
instance FromRow PAuction where
fromRow = PAuction <$> auctionRowParser

recordEvent' :: UserId -> LogEntry -> ReaderT Connection IO ()
recordEvent' (UserId uid) (LogEntry a e) = do
conn <- ask
void . lift $ execute conn
"INSERT INTO work_events (user_id, btc_addr, event_type, event_time) VALUES (?, ?, ?, ?)"
( uid
, a ^. address
, e ^. (eventType . to eventName)
, e ^. eventTime
)

readWorkIndex' :: ReaderT Connection IO WorkIndex
readWorkIndex' = do
conn <- ask
rows <- lift $ query_ conn
"SELECT btc_addr, event_type, event_time from work_events"
pure . workIndex $ fmap pLogEntry rows

newAuction' :: Auction -> ReaderT Connection IO AuctionId
newAuction' auc = do
conn <- ask
aucIds <- lift $ query conn
"INSERT INTO auctions (raise_amount, end_time) VALUES (?, ?) RETURNING id"
(auc ^. (raiseAmount.to PBTC), auc ^. auctionEnd)
pure . AuctionId . fromOnly $ DL.head aucIds

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 (aucId ^. _AuctionId))
pure . fmap pAuction $ headMay rows

recordBid' :: AuctionId -> Bid -> ReaderT Connection IO ()
recordBid' (AuctionId aucId) bid = do
conn <- ask
void . lift $ execute conn
"INSERT INTO bids (auction_id, user_id, bid_seconds, bid_amount, bid_time) values (?, ?, ?, ?, ?)"
( aucId
, bid ^. (bidUser._UserId)
, case bid ^. bidSeconds of (Seconds i) -> i
, bid ^. (bidAmount.to PBTC)
, 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 $ (aucId ^. _AuctionId))
pure $ fmap pBid rows

createUser' :: User -> ReaderT Connection IO UserId
createUser' user = do
conn <- ask
uids <- lift $ query conn
"INSERT INTO users (handle, btc_addr, email) VALUES (?, ?) RETURNING id"
(user ^. (username._UserName), user ^. (userAddress.address), user ^. userEmail)
pure . UserId . fromOnly $ DL.head uids

findUser' :: UserId -> ReaderT Connection IO (Maybe User)
findUser' (UserId uid) = do
conn <- ask
users <- lift $ query conn
"SELECT handle, btc_addr, email FROM users WHERE id = ?"
(Only uid)
pure . fmap pUser $ headMay users

findUserByHandle' :: Handle -> ReaderT Connection IO (Maybe QDBUser)
findUserByHandle' = undefined

postgresQDB :: QDB (ReaderT Connection IO)
postgresQDB = QDB
{ recordEvent = recordEvent'
, readWorkIndex = readWorkIndex'
, newAuction = newAuction'
, readAuction = readAuction'
, recordBid = recordBid'
, readBids = readBids'
, createUser = createUser'
, findUser = findUser'
, findUserByHandle = findUserByHandle'
}
edit in lib/Quixotic/Database/SQLite.hs at line 11

[2.65]

[5.102]

import qualified Text.Read as R
replacement in lib/Quixotic/Database/SQLite.hs at line 37

[5.1399]→[5.1399:1462](∅→∅)

let auctionParser = Auction <$> (fmap BTC field) <*> field

[5.1399]

[5.1462]

let auctionParser = Auction <$> fmap R.read field <*> field
replacement in lib/Quixotic/Database/SQLite.hs at line 45

[2.151]→[2.151:249](∅→∅)

let bidParser = Bid <$> fmap UserId field <*> fmap Seconds field <*> fmap BTC field <*> field

[2.151]

[2.249]

let bidParser = Bid <$> fmap UserId field <*> fmap Seconds field <*> fmap R.read field <*> field
edit in lib/Quixotic/Database/SQLite.hs at line 62

[2.631]→[2.631:656](∅→∅)

newtype PBTC = PBTC BTC
replacement in lib/Quixotic/Database/SQLite.hs at line 63

[2.657]→[2.657:722](∅→∅),[2.722]→[5.797:798](∅→∅),[5.1498]→[5.797:798](∅→∅),[5.797]→[5.797:798](∅→∅),[5.798]→[5.1499:1580](∅→∅)

instance ToField PBTC where
toField (PBTC (BTC i)) = toField i

recordEvent' :: LogEntry -> ReaderT Connection IO ()
recordEvent' logEntry = do

[2.657]

[5.1580]

-- TODO: Record the user id
recordEvent' :: UserId -> LogEntry -> ReaderT Connection IO ()
recordEvent' _ logEntry = do
replacement in lib/Quixotic/Database/SQLite.hs at line 83

[5.2151]→[5.2151:2208](∅→∅)

(auc ^. (raiseAmount . satoshis), auc ^. auctionEnd)

[5.2151]

[5.2208]

(show $ auc ^. raiseAmount, auc ^. auctionEnd)
replacement in lib/Quixotic/Database/SQLite.hs at line 102

[2.895]→[2.895:925](∅→∅)

, PBTC $ bid ^. bidAmount

[2.895]

[2.925]

, show $ bid ^. bidAmount
replacement in lib/Quixotic/Database/SQLite.hs at line 115

[5.2989]→[2.1227:1249](∅→∅)

createUser' user = do

[5.2989]

[2.1249]

createUser' u = do
replacement in lib/Quixotic/Database/SQLite.hs at line 119

[2.1341]→[2.1341:1398](∅→∅)

(user ^. (userAddress . address), user ^. userEmail)

[2.1341]

[2.1398]

(u ^. (userAddress . address), u ^. userEmail)
replacement in lib/Quixotic/Database/SQLite.hs at line 122

[5.736]→[5.3014:3045](∅→∅)

sqliteQDB :: QDB IO Connection

[5.736]

[5.3045]

sqliteQDB :: QDB (ReaderT Connection IO)
edit in lib/Quixotic/Database/SQLite.hs at line 131

[5.3270]

[5.3270]

, findUser = \_ -> pure Nothing
, findUserByHandle = \_ -> pure Nothing
replacement in lib/Quixotic/Database.hs at line 1

[5.4936]→[5.391:426](∅→∅)

{-# LANGUAGE NoImplicitPrelude #-}

[5.4936]

[5.426]

{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-}
edit in lib/Quixotic/Database.hs at line 6

[5.838]

[5.5521]

import Control.Lens
replacement in lib/Quixotic/Database.hs at line 12

[5.5045]→[5.161:181](∅→∅),[5.181]→[5.5568:5614](∅→∅),[5.5065]→[5.5568:5614](∅→∅),[5.5614]→[5.839:882](∅→∅),[5.882]→[5.5674:5725](∅→∅),[5.5674]→[5.5674:5725](∅→∅),[5.5725]→[5.3276:3388](∅→∅),[5.3388]→[2.1444:1491](∅→∅),[2.1491]→[5.5885:5930](∅→∅),[5.5885]→[5.5885:5930](∅→∅)

data QDB m a = QDB
{ recordEvent :: LogEntry -> ReaderT a m ()
, readWorkIndex :: ReaderT a m WorkIndex
, newAuction :: Auction -> ReaderT a m AuctionId
, readAuction :: AuctionId -> ReaderT a m (Maybe Auction)
, recordBid :: AuctionId -> Bid -> ReaderT a m ()
, readBids :: AuctionId -> ReaderT a m [Bid]
, createUser :: User -> ReaderT a m UserId

[5.5045]

[5.5159]

data QDBUser = QDBUser
{ _userId :: UserId
, _user :: User
}
makeLenses ''QDBUser

data QDB m = QDB
{ recordEvent :: UserId -> LogEntry -> m ()
, readWorkIndex :: m WorkIndex
, newAuction :: Auction -> m AuctionId
, readAuction :: AuctionId -> m (Maybe Auction)
, recordBid :: AuctionId -> Bid -> m ()
, readBids :: AuctionId -> m [Bid]
, createUser :: User -> m UserId
, findUser :: UserId -> m (Maybe User)
, findUserByHandle :: Handle -> m (Maybe QDBUser)
edit in lib/Quixotic/Users.hs at line 11

[2.1598]

[5.6088]

makePrisms ''UserId
edit in lib/Quixotic/Users.hs at line 13

[5.6089]

[5.6089]

newtype UserName = UserName Text deriving (Show, Eq)
makePrisms ''UserName
replacement in lib/Quixotic/Users.hs at line 17

[5.6106]→[2.1599:1627](∅→∅)

{ _userAddress :: BtcAddr

[5.6106]

[2.1627]

{ _username :: UserName
, _userAddress :: BtcAddr
edit in lib/Quixotic/Users.hs at line 21

[5.6159]→[2.1651:1652](∅→∅)
edit in lib/Quixotic/Users.hs at line 22

[2.1670]
edit in lib/Quixotic.hs at line 9

[5.1787]→[5.1270:1288](∅→∅)

import Data.Group
edit in lib/Quixotic.hs at line 12

[5.1198]→[5.2661:2662](∅→∅),[5.1932]→[5.2661:2662](∅→∅),[5.2661]→[5.2661:2662](∅→∅),[5.2662]→[5.4901:4967](∅→∅),[5.1272]→[5.1996:2013](∅→∅),[5.4967]→[5.1996:2013](∅→∅),[5.1996]→[5.1996:2013](∅→∅),[5.2013]→[5.1354:1384](∅→∅),[5.1354]→[5.1354:1384](∅→∅),[5.1384]→[5.4968:5009](∅→∅),[5.2053]→[5.1427:1514](∅→∅),[5.5009]→[5.1427:1514](∅→∅),[5.1427]→[5.1427:1514](∅→∅),[5.1514]→[5.5010:5046](∅→∅),[5.2091]→[5.1553:1581](∅→∅),[5.5046]→[5.1553:1581](∅→∅),[5.1553]→[5.1553:1581](∅→∅)

newtype BTC = BTC { _satoshis :: Int64 } deriving (Show, Eq, Ord)
makeLenses ''BTC

instance Semigroup BTC where
(<>) (BTC b1) (BTC b2) = BTC $ b1 + b2

instance Monoid BTC where
mempty = BTC 0
mappend = (<>)

instance Group BTC where
invert (BTC b) = BTC . negate $ b

instance Abelian BTC where
edit in quixotic.cabal at line 23

[5.672]

[5.672]

Quixotic.Database.PostgreSQL
edit in quixotic.cabal at line 40

[5.5169]

[5.1947]

, postgresql-simple >= 0.4.9 && < 0.5
, blaze-builder
edit in quixotic.cabal at line 88

[31.3216]

[5.443]

, postgresql-simple
, snap >= 0.13 && < 0.14
edit in quixotic.cabal at line 92

[5.545]

[31.3217]

, snaplet-postgresql-simple >= 0.6
, resource-pool-catchio
replacement in server/Main.hs at line 2

[5.1459]→[5.95:128](∅→∅)

{-# LANGUAGE RecordWildCards #-}

[5.1459]

[5.5255]

{-# LANGUAGE RecordWildCards, TemplateHaskell #-}
edit in server/Main.hs at line 9

[5.643]

[5.191]

import Control.Lens.TH
replacement in server/Main.hs at line 15

[5.170]→[5.226:256](∅→∅),[5.660]→[5.226:256](∅→∅),[5.122]→[5.226:256](∅→∅)

import Database.SQLite.Simple

[5.660]

[5.918]

import Data.Pool
import Database.PostgreSQL.Simple
replacement in server/Main.hs at line 20

[5.2543]→[5.185:217](∅→∅)

import Quixotic.Database.SQLite

[5.2543]

[5.920]

import Quixotic.Database.PostgreSQL
edit in server/Main.hs at line 27

[5.218]

[5.5492]

import Snap.Snaplet
import Snap.Snaplet.Auth
import Snap.Snaplet.Auth.Backends.PostgresqlSimple
import Snap.Snaplet.PostgresqlSimple
import Snap.Snaplet.Session
import Snap.Snaplet.Session.Backends.CookieSession
edit in server/Main.hs at line 34

[5.5493]→[5.1478:1492](∅→∅),[5.1492]→[5.1634:1644](∅→∅),[5.1644]→[5.219:255](∅→∅),[5.255]→[5.257:284](∅→∅),[5.189]→[5.257:284](∅→∅),[5.284]→[5.256:339](∅→∅),[5.246]→[5.2594:2595](∅→∅),[5.304]→[5.2594:2595](∅→∅),[5.334]→[5.2594:2595](∅→∅),[5.339]→[5.2594:2595](∅→∅),[5.1673]→[5.2594:2595](∅→∅),[5.6332]→[5.2594:2595](∅→∅),[5.1492]→[5.2594:2595](∅→∅),[5.2595]→[5.207:245](∅→∅),[5.245]→[5.335:353](∅→∅),[5.353]→[4.2:210](∅→∅),[4.210]→[5.6540:6545](∅→∅),[5.504]→[5.6540:6545](∅→∅),[5.6540]→[5.6540:6545](∅→∅),[5.6545]→[5.1931:1932](∅→∅),[5.1931]→[5.1931:1932](∅→∅)

main :: IO ()
main = do
cfg <- loadQConfig "quixotic.cfg"
db <- open $ dbName cfg
sconf <- snapConfig cfg
simpleHttpServe sconf $ runReaderT (site sqliteQDB) db

site :: QDB IO a -> ReaderT a Snap ()
site qdb = route
[ ("logStart/:btcAddr", logWorkHandler qdb StartWork)
, ("logEnd/:btcAddr", logWorkHandler qdb StopWork)
, ("loggedIntervals/:btcAddr", loggedIntervalsHandler qdb)
, ("payouts", payoutsHandler qdb)
]
edit in server/Main.hs at line 37

[5.383]

[3.42]

, authSiteKey :: FilePath
, cookieTimeout :: Maybe Int
replacement in server/Main.hs at line 41

[3.95]→[5.288:309](∅→∅),[5.430]→[5.288:309](∅→∅),[5.288]→[5.288:309](∅→∅)

, dbName :: String

[3.95]

[5.309]

-- , dbName :: String
edit in server/Main.hs at line 43

[5.314]

[5.314]

type PQDB = QDB (ReaderT Connection IO)

data App = App
{ _qdb :: Snaplet PQDB
, _sess :: Snaplet SessionManager
, _db :: Snaplet Postgres
, _auth :: Snaplet (AuthManager App)
}
makeLenses ''App
edit in server/Main.hs at line 54

[5.315]

[5.431]

main :: IO ()
main = do
cfg <- loadQConfig "quixotic.cfg"
sconf <- snapConfig cfg
--simpleHttpServe sconf $ runReaderT (site sqliteQDB) db
serveSnaplet sconf $ appInit cfg

appInit :: QConfig -> SnapletInit App App
appInit QConfig{..} = makeSnaplet "quixotic" "Quixotic Time Tracker" Nothing $ do
qdbs <- nestSnaplet "qdb" qdb qdbpgSnapletInit
sesss <- nestSnaplet "sessions" sess $
initCookieSessionManager (fpToString authSiteKey) "quookie" cookieTimeout
pgs <- nestSnaplet "db" db pgsInit
auths <- nestSnaplet "auth" auth $ initPostgresAuth sess pgs
addRoutes [ ("logStart/:btcAddr", logWorkHandler StartWork)
, ("logEnd/:btcAddr", logWorkHandler StopWork)
-- , ("loggedIntervals/:btcAddr", loggedIntervalsHandler qdb)
-- , ("payouts", payoutsHandler qdb)
]
return $ App qdbs sesss pgs auths
edit in server/Main.hs at line 84

[3.143]

[3.143]

<*> (fmap fpFromText $ C.require cfg "siteKey")
<*> C.lookup cfg "cookieTimeout"
replacement in server/Main.hs at line 88

[3.264]→[5.795:829](∅→∅),[5.795]→[5.795:829](∅→∅)

<*> C.require cfg "db"

[3.264]

[5.829]

-- <*> C.require cfg "db"
replacement in server/Main.hs at line 98

[5.1078]→[5.1078:1126](∅→∅)

snapConfig :: QConfig -> IO (SC.Config Snap ())

[5.1078]

[5.1126]

snapConfig :: QConfig -> IO (SC.Config Snap a)
replacement in server/Main.hs at line 101

[5.5696]→[4.211:300](∅→∅),[4.300]→[5.649:669](∅→∅),[5.649]→[5.649:669](∅→∅),[5.669]→[5.6623:6664](∅→∅),[5.620]→[5.6623:6664](∅→∅),[5.6664]→[5.670:884](∅→∅)

logWorkHandler :: QDB IO a -> EventType -> ReaderT a Snap ()
logWorkHandler qdb ev = do
let QDB{..} = qdb
addrBytes <- lift $ getParam "btcAddr"
timestamp <- lift $ liftIO getCurrentTime
maybe
(lift $ snapError 400 "")
(\a -> mapReaderT liftIO $ recordEvent (LogEntry a (WorkEvent ev timestamp)))
(fmap decodeUtf8 addrBytes >>= parseBtcAddr)

[5.5696]

[5.6062]

qdbpgSnapletInit :: SnapletInit a PQDB
qdbpgSnapletInit = makeSnaplet "qdbpg" "QDB on Postgresql" Nothing $ do
return postgresQDB
replacement in server/Main.hs at line 105

[5.6063]→[4.301:389](∅→∅),[4.389]→[5.790:981](∅→∅),[5.790]→[5.790:981](∅→∅)

loggedIntervalsHandler :: QDB IO a -> ReaderT a Snap ()
loggedIntervalsHandler qdb = do
let QDB{..} = qdb
widx <- mapReaderT liftIO $ readWorkIndex
lift . modifyResponse $ addHeader "content-type" "application/json"
lift . writeLBS . A.encode $ mapKeys (^. address) widx

[5.6063]

[5.981]

logWorkHandler :: EventType -> Handler App App ()
logWorkHandler evType = do
QDB{..} <- with qdb mempty
pg <- with db getPostgresState
authedUser <- with auth currentUser
qUid <-
addrBytes <- getParam "btcAddr"
timestamp <- liftIO getCurrentTime
let workEvent = WorkEvent evType timestamp
btcAddr = fmap decodeUtf8 addrBytes >>= parseBtcAddr
storeEv uid addr = runReaderT . recordEvent uid $ LogEntry addr workEvent
maybe (snapError 400 "") (liftPG . storeEv) btcAddr
replacement in server/Main.hs at line 118

[5.982]→[4.390:463](∅→∅),[4.463]→[5.910:985](∅→∅),[5.910]→[5.910:985](∅→∅),[5.759]→[5.986:1072](∅→∅),[5.1072]→[3.412:482](∅→∅),[3.482]→[5.1072:1144](∅→∅),[5.1072]→[5.1072:1144](∅→∅)

payoutsHandler :: QDB IO a -> ReaderT a Snap ()
payoutsHandler qdb = do
let QDB{..} = qdb
dep = linearDepreciation (Months 6) (Months 60)
ptime <- lift . liftIO $ getCurrentTime
widx <- mapReaderT liftIO $ readWorkIndex
lift . modifyResponse $ addHeader "content-type" "application/json"
lift . writeLBS . A.encode . PayoutsResponse $ payouts dep ptime widx

[5.982]

[5.1016]

--loggedIntervalsHandler :: QDB IO a -> ReaderT a Snap ()
--loggedIntervalsHandler qdb = do
-- let QDB{..} = qdb
-- widx <- mapReaderT liftIO $ readWorkIndex
-- lift . modifyResponse $ addHeader "content-type" "application/json"
-- lift . writeLBS . A.encode $ mapKeys (^. address) widx
--
--payoutsHandler :: QDB IO a -> ReaderT a Snap ()
--payoutsHandler qdb = do
-- let QDB{..} = qdb
-- dep = linearDepreciation (Months 6) (Months 60)
-- ptime <- lift . liftIO $ getCurrentTime
-- widx <- mapReaderT liftIO $ readWorkIndex
-- lift . modifyResponse $ addHeader "content-type" "application/json"
-- lift . writeLBS . A.encode . PayoutsResponse $ payouts dep ptime widx