Lenses, sqlite-simple

[?]

Dec 15, 2014, 5:37 AM

TLQ72DSJD7GGPWN6HGBHAVPBRQFKEQ6KSK43U7JWWID4ZWAF47JAC

Dependencies

[2] MXLZBRQN Trickle.
[3] LUM4VQJI Increment.
[4] FRPWIKCN Added log event parsing to Quixotic.Database.SQLite
[5] A2J7B4SC Initial impl of depreciation function.
[6] NVOCQVAS Initial failing tests.
[7] P6NR2CGX Beginning of implementation of depreciation.
[8] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[9] 2OIPAQCB Merge branch 'master' of github.com:nuttycom/ananke
[10] 7DBNV3GV Initial, stack-based impl of time log event reduction.
[11] 64VI73NP Server now compiles using abstracted SQLite
[12] 5W5M56VJ Move library code to 'lib'
[13] RSEB2NFG Replacing Snap with Scotty.
[14] JUUMYIQE Add groupBy utility function for use in TimeLog.
[15] LAROLAYU WIP
[16] WFZDMVUX Rename ADB -> QDB
[17] 75N3UJ4J More progression toward lenses.
[18] MWUPXTBF A few steps down a road to be abandoned.
[19] N4NDAZYT Initial implementation of payouts.
[20] Y35QCWYW Minor improvement in WorkIndex type to eliminate duplicated information.
[21] 4QX5E5AC Initial compilation of payouts function succeeds.
[22] 2KZPOGRB Once you get Haskell to compile, the tests pass!
[23] GKGVYBZG Added JSON serialization to TimeLog
[24] TZQJVHBA Add auction functions to ADB.
[25] EMVTF2IW WIP moving back to snap.
[26] WO2MINIF Auctions now compile!
[27] NTPC7KJE Trivial changes, feature scratchpad.

Change contents

replacement in lib/Quixotic/Auction.hs at line 12

[4.5214]→[4.3:57](∅→∅)

newtype AuctionId = AuctionId Int deriving (Show, Eq)

[4.5214]

[4.5248]

newtype AuctionId = AuctionId Int64 deriving (Show, Eq)
replacement in lib/Quixotic/Auction.hs at line 16

[4.141]→[4.141:165](∅→∅)

, _endsAt :: UTCTime

[4.141]

[4.5319]

, _auctionEnd :: UTCTime
replacement in lib/Quixotic/Auction.hs at line 22

[4.5339]→[4.189:257](∅→∅)

{ _userId :: UserId
, _seconds :: Seconds
, _btcAmount :: BTC

[4.5339]

[4.106]

{ _bidUser :: UserId
, _bidSeconds :: Seconds
, _bidAmount :: BTC
, _bidTime :: UTCTime
replacement in lib/Quixotic/Auction.hs at line 34

[4.288]→[4.288:454](∅→∅)

bidSeconds bid = toRational $ bid ^. seconds
bidAmount bid = toRational $ bid ^. (btcAmount . btc)
costRatio bid = bidSeconds bid / bidAmount bid

[4.288]

[4.293]

secs bid = toRational $ bid ^. bidSeconds
btc bid = toRational $ bid ^. (bidAmount . satoshis)
costRatio bid = secs bid / btc bid
replacement in lib/Quixotic/Auction.hs at line 44

[4.538]→[4.455:582](∅→∅)

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

[4.538]

[4.652]

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

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

winFraction = (toRational $ remainder ^. btc) / (toRational $ x ^. (btcAmount . btc))
remainderSeconds = Seconds . round $ winFraction * (toRational $ x ^. seconds)

[4.732]

[4.925]

winFraction = (toRational $ remainder ^. satoshis) / (toRational $ x ^. (bidAmount . satoshis))
remainderSeconds = Seconds . round $ winFraction * (toRational $ x ^. bidSeconds)
replacement in lib/Quixotic/Auction.hs at line 54

[4.926]→[4.926:999](∅→∅)

in [x & seconds .~ remainderSeconds & btcAmount .~ remainder]

[4.926]

[4.1080]

in [x & bidSeconds .~ remainderSeconds & bidAmount .~ remainder]
edit in lib/Quixotic/Database/SQLite.hs at line 2

[4.79]

[4.1148]

{-# LANGUAGE TemplateHaskell #-}
edit in lib/Quixotic/Database/SQLite.hs at line 7

[4.101]

[4.1002]

import Control.Error.Safe
replacement in lib/Quixotic/Database/SQLite.hs at line 11

[4.1045]→[4.3798:3821](∅→∅),[4.3798]→[4.3798:3821](∅→∅)

import Database.SQLite

[4.1045]

[4.102]

import Database.SQLite.Simple
edit in lib/Quixotic/Database/SQLite.hs at line 18

[4.1093]→[4.3922:3923](∅→∅),[4.1191]→[4.3922:3923](∅→∅),[4.3922]→[4.3922:3923](∅→∅),[4.3923]→[4.55:142](∅→∅),[4.142]→[4.1266:1307](∅→∅),[4.1266]→[4.1266:1307](∅→∅),[4.1307]→[4.60:103](∅→∅),[4.103]→[4.143:159](∅→∅),[4.1307]→[4.143:159](∅→∅),[4.159]→[4.116:187](∅→∅),[4.116]→[4.116:187](∅→∅),[4.187]→[4.1094:1245](∅→∅),[4.1245]→[4.330:336](∅→∅),[4.330]→[4.330:336](∅→∅),[4.336]→[4.4076:4077](∅→∅),[4.4076]→[4.4076:4077](∅→∅),[4.4077]→[4.337:505](∅→∅),[4.505]→[4.1246:1294](∅→∅),[4.1294]→[4.544:583](∅→∅),[4.544]→[4.544:583](∅→∅),[4.583]→[4.104:159](∅→∅),[4.159]→[4.4371:4372](∅→∅),[4.633]→[4.4371:4372](∅→∅),[4.4371]→[4.4371:4372](∅→∅),[4.4372]→[4.634:733](∅→∅),[4.733]→[3.4:217](∅→∅),[3.217]→[4.1295:1296](∅→∅),[4.96]→[4.1295:1296](∅→∅),[4.1296]→[3.218:293](∅→∅),[3.293]→[4.160:191](∅→∅),[4.1361]→[4.160:191](∅→∅),[4.191]→[2.4:106](∅→∅),[2.106]→[4.285:341](∅→∅),[4.285]→[4.285:341](∅→∅),[4.341]→[2.107:172](∅→∅)

sqliteQDB :: SQLiteHandle -> IO (QDB (EitherT Text IO) SQLiteHandle)
sqliteQDB db = do
_ <- defineTableOpt db True eventTable
_ <- defineTableOpt db True auctionTable
return $ QDB
{ recordEvent = recordEvent'
, readWorkIndex = readWorkIndex'
, newAuction = newAuction'
, readAuction = readAuction'
, recordBid = recordBid'
, readBids = readBids'
, createUser = createUser'
}

recordEvent' :: LogEntry -> ReaderT SQLiteHandle (EitherT Text IO) ()
recordEvent' (LogEntry ba ev) = do
db <- ask
lift . lift . void $ insertRow db "workEvents"
[ ("btcAddr", ba ^. address ^. from packed)
, ("event", unpack (eventName ev))
, ("eventTime", formatSqlTime (logTime ev))
]

readWorkIndex' :: ReaderT SQLiteHandle (EitherT Text IO) WorkIndex
readWorkIndex' = do
db <- ask
let selection = execStatement db "SELECT btcAddr, event, eventTime from workEvents"
rows <- lift . EitherT $ fmap (over _Left pack) selection
return . intervals . catMaybes $ fmap parseLogEntry (join rows)

newAuction' :: Auction -> ReaderT SQLiteHandle (EitherT Text IO) AuctionId
newAuction' a = do
db <- ask
_ <- lift . lift $ insertRow db "auctions"
[ ("raiseAmount", show $ a ^. (raiseAmount . btc))
, ("eventTime", formatSqlTime $ a ^. endsAt)
]
lift . lift . fmap (AuctionId . fromInteger) $ getLastRowID db
replacement in lib/Quixotic/Database/SQLite.hs at line 19

[4.1386]→[4.1386:1451](∅→∅),[4.1451]→[3.294:559](∅→∅)

readAuction' :: AuctionId -> ReaderT a (EitherT Text IO) Auction
readAuction' (AuctionId aid) = do
db <- ask
let selection = execParamStatement db
"SELECT raiseAmount, endsAt FROM auctions WHERE ROWID = :aid"
[("aid", Int aid)]
rows <- lift . EitherT $ fmap (over _Left pack) selection

[4.1386]

[3.559]

newtype PLogEntry = PLogEntry LogEntry
makePrisms ''PLogEntry
edit in lib/Quixotic/Database/SQLite.hs at line 22

[3.560]

[4.1476]

instance ToRow PLogEntry where
toRow (PLogEntry (LogEntry a e)) =
toRow (a ^. address, e ^. (eventType . to eventName), e ^. eventTime)
replacement in lib/Quixotic/Database/SQLite.hs at line 26

[4.1477]→[4.1477:1657](∅→∅)

recordBid' :: UTCTime -> Bid -> ReaderT a (EitherT Text IO) ()
recordBid' = undefined

readBids' :: AuctionId -> ReaderT a (EitherT Text IO) [(UTCTime, Bid)]
readBids' = undefined

[4.1477]

[4.1657]

instance FromRow PLogEntry where
fromRow =
let workEventParser = WorkEvent <$> (field >>= nameEvent) <*> field
logEntryParser = LogEntry <$> (fmap BtcAddr field) <*> workEventParser
in fmap PLogEntry logEntryParser
replacement in lib/Quixotic/Database/SQLite.hs at line 32

[4.1658]→[4.1658:1740](∅→∅)

createUser' :: User -> ReaderT a (EitherT Text IO) UserId
createUser' = undefined

[4.1658]

[4.4555]

newtype PAuction = PAuction Auction
makePrisms ''PAuction
replacement in lib/Quixotic/Database/SQLite.hs at line 35

[4.4556]→[3.561:629](∅→∅),[3.629]→[4.155:313](∅→∅),[4.155]→[4.155:313](∅→∅),[4.313]→[3.630:797](∅→∅)

parseLogEntry :: Row Value -> Maybe LogEntry
parseLogEntry row = do
a <- lookup "btcAddr" row >>= valueAddr
t <- lookup "eventTime" row >>= valueTime
ev <- lookup "event" row >>= (valueEvent t)
return $ LogEntry a ev

parseAuction :: Row Value -> Maybe Auction
parseAuction row =
Auction <$> (lookup "raiseAmount" row >>= valueBTC)
<*> (lookup "endsAt" row >>= valueTime)

[4.4556]

[3.797]

instance FromRow PAuction where
fromRow =
let auctionParser = Auction <$> (fmap BTC field) <*> field
in fmap PAuction auctionParser
replacement in lib/Quixotic/Database/SQLite.hs at line 40

[3.798]→[3.798:884](∅→∅)

valueBTC :: Value -> Maybe BTC
valueBTC (Int i) _ = Just $ BTC i
valueBTC _ = Nothing

[3.798]

[3.884]

recordEvent' :: LogEntry -> ReaderT Connection IO ()
recordEvent' logEntry = do
conn <- ask
lift $ execute conn
"INSERT INTO work_events (btc_addr, event_type, event_time) VALUES (?, ?, ?)"
(logEntry ^. (from _PLogEntry))
replacement in lib/Quixotic/Database/SQLite.hs at line 47

[3.885]→[4.313:349](∅→∅),[4.313]→[4.313:349](∅→∅),[4.349]→[4.346:389](∅→∅),[4.389]→[4.394:416](∅→∅),[4.394]→[4.394:416](∅→∅)

valueAddr :: Value -> Maybe BtcAddr
valueAddr (Text t) = parseBtcAddr $ pack t
valueAddr _ = Nothing

[3.885]

[4.416]

readWorkIndex' :: ReaderT Connection IO WorkIndex
readWorkIndex' = do
conn <- ask
rows <- lift $ query_ conn
"SELECT btc_addr, event_type, event_time from workEvents"
lift . return . workIndex $ fmap (^. _PLogEntry) rows
replacement in lib/Quixotic/Database/SQLite.hs at line 54

[4.417]→[4.417:538](∅→∅)

valueTime :: Value -> Maybe UTCTime
valueTime (Text t) = parseTime defaultTimeLocale "%c" t
valueTime _ = Nothing

[4.417]

[4.538]

newAuction' :: Auction -> ReaderT Connection IO AuctionId
newAuction' auc = do
conn <- ask
lift $ execute conn
"INSERT INTO auctions (raise_amount, end_time) VALUES (?, ?)"
(auc ^. (raiseAmount . satoshis), auc ^. auctionEnd)
lift . fmap AuctionId $ lastInsertRowId conn
replacement in lib/Quixotic/Database/SQLite.hs at line 62

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

valueEvent :: UTCTime -> Value -> Maybe WorkEvent
valueEvent t (Text "start") = Just (StartWork t)
valueEvent t (Text "stop") = Just (StopWork t)
valueEvent _ _ = Nothing

[4.539]

[4.1616]

readAuction' :: AuctionId -> ReaderT Connection IO (Maybe Auction)
readAuction' (AuctionId aid) = do
conn <- ask
rows <- lift $ query conn
"SELECT raise_amount, end_time FROM auctions WHERE ROWID = ?"
(Only aid)
lift . return . headMay $ fmap (^. _PAuction) rows
replacement in lib/Quixotic/Database/SQLite.hs at line 70

[4.1617]→[4.4556:4645](∅→∅),[4.4556]→[4.4556:4645](∅→∅)

formatSqlTime :: UTCTime -> String
formatSqlTime t = formatTime defaultTimeLocale "%c" t

[4.1617]

[4.4645]

recordBid' :: AuctionId -> Bid -> ReaderT Connection IO ()
recordBid' (AuctionId aid) bid = do
conn <- ask
lift $ execute conn
"INSERT INTO bids (auction_id, user_id, bid_seconds, bid_amount, bid_time) values (?, ?, ?, ?, ?)"
(aid, bid ^. bidUser, bid ^. bidSeconds, bid ^. bidAmount, bid ^. bidTime)
replacement in lib/Quixotic/Database/SQLite.hs at line 77

[4.4646]→[4.4646:4669](∅→∅),[4.4669]→[3.886:1061](∅→∅)

eventTable :: SQLTable
eventTable = Table "workEvents"
[ Column "btcAddr" (SQLVarChar 256) []
, Column "event" (SQLVarChar 64) []
, Column "eventTime" (SQLDateTime DATETIME) []
] []

[4.4646]

[4.4898]

readBids' :: AuctionId -> ReaderT Connection IO [(UTCTime, Bid)]
readBids' = undefined
replacement in lib/Quixotic/Database/SQLite.hs at line 80

[4.4899]→[4.506:531](∅→∅),[4.531]→[3.1062:1209](∅→∅)

auctionTable :: SQLTable
auctionTable = Table "auctions"
[ Column "raiseAmouont" (SQLInt BIG False False) []
, Column "endsAt" (SQLDateTime DATETIME) []
] []

[4.4899]

[4.735]

createUser' :: User -> ReaderT Connection IO UserId
createUser' = undefined
edit in lib/Quixotic/Database/SQLite.hs at line 83

[4.736]

sqliteQDB :: QDB IO Connection
sqliteQDB = QDB
{ recordEvent = recordEvent'
, readWorkIndex = readWorkIndex'
, newAuction = newAuction'
, readAuction = readAuction'
, recordBid = recordBid'
, readBids = readBids'
, createUser = createUser'
}
replacement in lib/Quixotic/Database.hs at line 14

[4.5725]→[4.5725:5827](∅→∅)

, readAuction :: AuctionId -> ReaderT a m Auction
, recordBid :: UTCTime -> Bid -> ReaderT a m ()

[4.5725]

[4.5827]

, readAuction :: AuctionId -> ReaderT a m (Maybe Auction)
, recordBid :: AuctionId -> Bid -> ReaderT a m ()
replacement in lib/Quixotic/TimeLog.hs at line 1

[4.846]→[4.489:564](∅→∅)

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

[4.846]

[4.883]

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
edit in lib/Quixotic/TimeLog.hs at line 8

[4.924]

[4.924]

, btcAddr, event
edit in lib/Quixotic/TimeLog.hs at line 10

[4.944]

[4.75]

, EventType(..)
, eventName, nameEvent
edit in lib/Quixotic/TimeLog.hs at line 13

[4.93]

[4.93]

, eventType, eventTime
edit in lib/Quixotic/TimeLog.hs at line 15

[4.107]

[4.3]

, workIndex
edit in lib/Quixotic/TimeLog.hs at line 19

[4.5357]→[4.5357:5371](∅→∅)

, eventName
edit in lib/Quixotic/TimeLog.hs at line 20

[4.973]→[4.973:987](∅→∅)

, intervals
edit in lib/Quixotic/TimeLog.hs at line 25

[4.587]

[4.168]

import Control.Lens
edit in lib/Quixotic/TimeLog.hs at line 31

[4.1081]→[4.83:122](∅→∅)

import qualified Data.Aeson.Types as A
replacement in lib/Quixotic/TimeLog.hs at line 35

[4.1225]→[4.201:251](∅→∅),[4.251]→[4.2666:2736](∅→∅)

data WorkEvent = StartWork { logTime :: UTCTime }
| StopWork { logTime :: UTCTime } deriving (Show, Eq)

[4.1225]

[4.5414]

data EventType = StartWork | StopWork deriving (Show, Eq)
replacement in lib/Quixotic/TimeLog.hs at line 37

[4.5415]→[4.661:692](∅→∅),[4.692]→[4.5448:5515](∅→∅),[4.1760]→[4.5448:5515](∅→∅),[4.5448]→[4.5448:5515](∅→∅)

eventName :: WorkEvent -> Text
eventName (StartWork _) = "start"
eventName (StopWork _) = "stop"

[4.5415]

[4.1282]

eventName :: EventType -> Text
eventName StartWork = "start"
eventName StopWork = "stop"

nameEvent :: MonadPlus m => Text -> m EventType
nameEvent "start" = return StartWork
nameEvent "stop" = return StopWork
nameEvent _ = mzero
edit in lib/Quixotic/TimeLog.hs at line 46

[4.1283]

[4.302]

data WorkEvent = WorkEvent
{ _eventType :: EventType
, _eventTime :: UTCTime
} deriving (Show, Eq)
makeLenses ''WorkEvent
replacement in lib/Quixotic/TimeLog.hs at line 53

[4.336]→[4.336:365](∅→∅),[4.365]→[4.693:732](∅→∅),[4.732]→[4.406:539](∅→∅),[4.406]→[4.406:539](∅→∅)

parseJSON (Object jv) = do
t <- jv .: "type" :: A.Parser Text
case t of
"start" -> StartWork <$> jv .: "timestamp"
"stop" -> StopWork <$> jv .: "timestamp"
_ -> mzero

[4.336]

[4.2737]

parseJSON (Object jv) =
WorkEvent <$> (jv .: "type" >>= nameEvent) <*> jv .: "timestamp"
replacement in lib/Quixotic/TimeLog.hs at line 59

[4.566]→[4.566:613](∅→∅)

{ btcAddr :: BtcAddr
, event :: WorkEvent

[4.566]

[4.613]

{ _btcAddr :: BtcAddr
, _event :: WorkEvent
edit in lib/Quixotic/TimeLog.hs at line 62

[4.637]

[4.1724]

makeLenses ''LogEntry
replacement in lib/Quixotic/TimeLog.hs at line 65

[4.671]→[4.671:800](∅→∅)

parseJSON (Object jv) = LogEntry <$>
jv .: "btcAddr" <*>
jv .: "workEvent"

[4.671]

[4.2123]

parseJSON (Object jv) =
LogEntry <$> jv .: "btcAddr" <*> jv .: "workEvent"
replacement in lib/Quixotic/TimeLog.hs at line 114

[4.600]→[4.352:403](∅→∅),[4.1582]→[4.352:403](∅→∅),[4.2354]→[4.352:403](∅→∅),[4.403]→[4.942:966](∅→∅),[4.966]→[4.885:1007](∅→∅)

intervals :: Foldable f => f LogEntry -> WorkIndex
intervals logEntries =
let logSum = F.foldl' appendLogEntry MS.empty logEntries
in MS.map (bimap (fmap event) (fmap workInterval)) $ logSum

[4.1582]

[4.448]

workIndex :: Foldable f => f LogEntry -> WorkIndex
workIndex logEntries =
let logSum :: RawIndex
logSum = F.foldl' appendLogEntry MS.empty logEntries
in MS.map (bimap (fmap (^. event)) (fmap workInterval)) $ logSum
replacement in lib/Quixotic/TimeLog.hs at line 123

[4.2117]→[4.2117:2210](∅→∅),[4.2210]→[4.277:320](∅→∅)

appendLogEntry workIndex entry =
let acc = reduceToIntervals $ pushEntry entry workIndex
in insert (btcAddr entry) acc workIndex

[4.2117]

[4.2252]

appendLogEntry idx entry =
let acc = reduceToIntervals $ pushEntry entry idx
in insert (entry ^. btcAddr) acc idx
replacement in lib/Quixotic/TimeLog.hs at line 128

[4.2318]→[4.1008:1089](∅→∅)

pushEntry entry = first (entry :) . MS.findWithDefault ([], []) (btcAddr entry)

[4.2318]

[4.869]

pushEntry entry = first (entry :) . MS.findWithDefault ([], []) (entry ^. btcAddr)
replacement in lib/Quixotic/TimeLog.hs at line 131

[4.772]→[4.2760:2859](∅→∅)

reduceToIntervals ((LogEntry addr (StopWork end')) : (LogEntry _ (StartWork start')) : xs, acc) =

[4.772]

[4.2859]

reduceToIntervals ((LogEntry addr (WorkEvent StopWork end')) : (LogEntry _ (WorkEvent StartWork start')) : xs, acc) =
replacement in lib/Quixotic.hs at line 14

[4.2662]→[3.1211:1272](∅→∅)

newtype BTC = BTC { _btc :: Int64 } deriving (Show, Eq, Ord)

[4.2662]

[4.1996]

newtype BTC = BTC { _satoshis :: Int64 } deriving (Show, Eq, Ord)
replacement in lib/Quixotic.hs at line 18

[4.1384]→[4.2014:2053](∅→∅)

(<>) b1 b2 = BTC $ _btc b1 + _btc b2

[4.1384]

[4.1427]

(<>) (BTC b1) (BTC b2) = BTC $ b1 + b2
replacement in lib/Quixotic.hs at line 25

[4.1514]→[4.2054:2091](∅→∅)

invert b = BTC . negate . _btc $ b

[4.1514]

[4.1553]

invert (BTC b) = BTC . negate $ b
edit in quixotic.cabal at line 32

[4.1892]

[4.1892]

, safe >= 0.3.8
, errors >= 1.4.7
replacement in quixotic.cabal at line 35

[4.1909]→[4.1909:1947](∅→∅)

, sqlite == 0.5.2.2

[4.1909]

[4.1947]

, sqlite-simple >= 0.4.8 && < 0.5