Undo JSON silliness, enable a couple more routes.

[?]

May 7, 2015, 5:40 AM

O5FVTOM6YFBLEPF3S576K6IMT6ZZ5VQCSB3YVXNS4CKBITKCRZ7AC

Dependencies

[2] KNSI575V Cleanup of EventLog types.
[3] NVOCQVAS Initial failing tests.
[4] BROSTG5K Beginning of modularization of server.
[5] 5DRIWGLU Improving TimeLog specs
[6] N4NDAZYT Initial implementation of payouts.
[7] W35DDBFY Factor common JSON conversions up into client lib module.
[8] Z7KS5XHH Very WIP. Wow.
[9] EZQG2APB Update task list.
[10] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[11] I2KHGVD4 Require project permissions for access to most data.
[12] 7DBNV3GV Initial, stack-based impl of time log event reduction.
[13] 2OIPAQCB Merge branch 'master' of github.com:nuttycom/ananke
[14] VJPT6HDR Fix remaining type errors after addition of login handler.
[15] 7KZP4RHZ Switch from Data.Time to Data.Thyme
[16] P6NR2CGX Beginning of implementation of depreciation.
[17] TNR3TEHK Switch to Postgres + snaplet arch compiles.
[18] 2G3GNDDU Event logging is now functioning in postgres.
[19] 4IQVQL4T Added client for payouts endpoint.
[20] RSEB2NFG Replacing Snap with Scotty.
[21] SCXG6TJW Make log reduction safer in presence of overlapping events.
[22] Z3M53KTL Adrift.
[23] LD4GLVSF More database stuff.
[24] 4QX5E5AC Initial compilation of payouts function succeeds.
[25] Y35QCWYW Minor improvement in WorkIndex type to eliminate duplicated information.
[26] 7XN3I3QJ Add 'loggedIntervals' endpoint.
[27] 5XFJNUAZ Start of addition of project infrastructure.
[28] A6HKMINB Attempting to improve JSON handling.
[29] 2Y2QZFVF Switch to more modern cabal2nix-based workflow.
[30] PBD7LZYQ Postgres & auth are beginning to function.
[31] IZEVQF62 Work in progress replacing sqlite with postgres.
[32] XTBSG4C7 Adding serveJSON combinator to eliminate some boilerplate from handlers.
[33] TLQ72DSJ Lenses, sqlite-simple
[34] EMVTF2IW WIP moving back to snap.
[35] SLL7262C Make depreciation functions more flexible.
[*] HE3JTXO3 Added client call to payouts.
[*] ADMKQQGC Initial empty Snap project.

Change contents

edit in lib/Quixotic/Client.hs at line 8

[3.151]

[37.3]

import Data.Aeson.Types
edit in lib/Quixotic/Client.hs at line 13

[3.172]

[3.193]

import Quixotic.Json
replacement in lib/Quixotic/Client.hs at line 27

[3.120]→[3.411:444](∅→∅),[3.411]→[3.411:444](∅→∅),[3.444]→[3.1079:1120](∅→∅)

payoutsResponse <- asJSON resp
pure $ payoutsResponse ^. responseBody

[3.120]

[3.506]

valueResponse <- asValue resp
either fail pure (parseEither parsePayoutsJSON $ valueResponse ^. responseBody)
edit in lib/Quixotic/Database/PostgreSQL.hs at line 134

[3.314]

[3.473]

newtype PProject = PProject { pProject :: Project }
instance FromRow PProject where
fromRow = PProject <$> projectRowParser
replacement in lib/Quixotic/Database/PostgreSQL.hs at line 152

[3.1362]→[3.1362:1426](∅→∅),[3.1426]→[2.959:1024](∅→∅)

recordEvent' :: ProjectId -> UserId -> LogEntry -> QDBM EventId
recordEvent' (ProjectId pid) (UserId uid) (LogEntry a e m) = do

[3.1362]

[3.1489]

createEvent' :: ProjectId -> UserId -> LogEntry -> QDBM EventId
createEvent' (ProjectId pid) (UserId uid) (LogEntry a e m) = do
replacement in lib/Quixotic/Database/PostgreSQL.hs at line 189

[3.3625]→[3.2412:2466](∅→∅),[3.2466]→[3.834:859](∅→∅),[3.834]→[3.834:859](∅→∅)

newAuction' :: ProjectId -> Auction -> QDBM AuctionId
newAuction' pid auc = do

[3.3625]

[3.2467]

createAuction' :: ProjectId -> Auction -> QDBM AuctionId
createAuction' pid auc = do
replacement in lib/Quixotic/Database/PostgreSQL.hs at line 196

[3.3929]→[3.2487:2537](∅→∅),[3.2537]→[3.3996:4020](∅→∅),[3.3996]→[3.3996:4020](∅→∅)

readAuction' :: AuctionId -> QDBM (Maybe Auction)
readAuction' aucId = do

[3.3929]

[3.2538]

findAuction' :: AuctionId -> QDBM (Maybe Auction)
findAuction' aucId = do
replacement in lib/Quixotic/Database/PostgreSQL.hs at line 203

[3.4201]→[3.2556:2598](∅→∅),[3.2598]→[3.4260:4298](∅→∅),[3.4260]→[3.4260:4298](∅→∅)

recordBid' :: AuctionId -> Bid -> QDBM ()
recordBid' (AuctionId aucId) bid = do

[3.4201]

[3.2599]

createBid' :: AuctionId -> Bid -> QDBM ()
createBid' (AuctionId aucId) bid = do
edit in lib/Quixotic/Database/PostgreSQL.hs at line 253

[3.273]

[3.704]

findProject' :: ProjectId -> QDBM (Maybe Project)
findProject' (ProjectId pid) = do
projects <- pquery
"SELECT project_name, inception_date, initiator_id FROM projects WHERE id = ?"
(Only pid)
pure . fmap pProject $ headMay projects
replacement in lib/Quixotic/Database/PostgreSQL.hs at line 272

[3.5587]→[3.5587:5618](∅→∅)

{ recordEvent = recordEvent'

[3.5587]

[3.3037]

{ createEvent = createEvent'
replacement in lib/Quixotic/Database/PostgreSQL.hs at line 275

[3.5654]→[3.5654:5741](∅→∅)

, newAuction = newAuction'
, readAuction = readAuction'
, recordBid = recordBid'

[3.5654]

[3.5741]

, createAuction = createAuction'
, findAuction = findAuction'

, createBid = createBid'
edit in lib/Quixotic/Database/PostgreSQL.hs at line 281

[3.5766]

[3.5766]
edit in lib/Quixotic/Database/PostgreSQL.hs at line 285

[3.751]

[3.1371]
edit in lib/Quixotic/Database/PostgreSQL.hs at line 287

[3.1406]

[3.1406]

, findProject = findProject'
replacement in lib/Quixotic/Database.hs at line 25

[3.6687]→[3.3068:3134](∅→∅)

{ recordEvent :: ProjectId -> UserId -> LogEntry -> m EventId

[3.6687]

[3.3134]

{ createEvent :: ProjectId -> UserId -> LogEntry -> m EventId
replacement in lib/Quixotic/Database.hs at line 28

[3.342]→[3.342:399](∅→∅),[3.399]→[3.1500:1598](∅→∅)

, newAuction :: ProjectId -> Auction -> m AuctionId
, readAuction :: AuctionId -> m (Maybe Auction)
, recordBid :: AuctionId -> Bid -> m ()

[3.342]

[3.1598]

, createAuction :: ProjectId -> Auction -> m AuctionId
, findAuction :: AuctionId -> m (Maybe Auction)
, createBid :: AuctionId -> Bid -> m ()
edit in lib/Quixotic/Database.hs at line 33

[3.1640]

[3.578]
edit in lib/Quixotic/Database.hs at line 37

[3.855]

[3.1449]
edit in lib/Quixotic/Database.hs at line 39

[3.1493]

[3.1641]

, findProject :: ProjectId -> m (Maybe Project)
edit in lib/Quixotic/Json.hs at line 11

[3.3653]→[3.3653:3670](∅→∅)

import Data.Data
edit in lib/Quixotic/Json.hs at line 13

[3.3769]

[3.231]

import Data.Data
import Data.List.NonEmpty as L
import Data.Map.Strict as MS
edit in lib/Quixotic/Json.hs at line 18

[3.248]

[3.272]

import Quixotic.Database
import Quixotic.Interval
import Quixotic.TimeLog
edit in lib/Quixotic/Json.hs at line 61

[3.486]

[3.5266]

qdbProjectJSON :: QDBProject -> Value
qdbProjectJSON qp =
object [ "projectId" .= (qp ^. (projectId._ProjectId))
, "project" .= projectJSON (qp ^. project)
]
edit in lib/Quixotic/Json.hs at line 73

[3.2561]

payoutsJSON :: Payouts -> Value
payoutsJSON (Payouts m) = toJSON $ MS.mapKeys (^. _BtcAddr) m

parsePayoutsJSON :: Value -> Parser Payouts
parsePayoutsJSON v =
Payouts . MS.mapKeys BtcAddr <$> parseJSON v

workIndexJSON :: WorkIndex -> Value
workIndexJSON (WorkIndex widx) =
toJSON $ (L.toList . fmap intervalJSON) <$> (MS.mapKeysMonotonic (^._BtcAddr) widx)

eventIdJSON :: EventId -> Value
eventIdJSON (EventId eid) = toJSON eid
replacement in lib/Quixotic/TimeLog.hs at line 9

[3.3854]→[3.3:40](∅→∅),[3.40]→[3.5479:5508](∅→∅),[3.107]→[3.5479:5508](∅→∅)

, WorkIndex(WorkIndex), _WorkIndex
, workIndex, workIndexJSON

[3.3594]

[3.3]

, WorkIndex(WorkIndex), _WorkIndex, workIndex
replacement in lib/Quixotic/TimeLog.hs at line 11

[3.12]→[3.5509:5553](∅→∅)

, EventId(EventId), _EventId, eventIdJSON

[3.12]

[3.5553]

, EventId(EventId), _EventId
edit in lib/Quixotic/TimeLog.hs at line 25

[3.3878]→[3.5636:5660](∅→∅)

import Data.Aeson.Types
edit in lib/Quixotic/TimeLog.hs at line 35

[3.635]→[3.5661:5682](∅→∅)

import Quixotic.Json
edit in lib/Quixotic/TimeLog.hs at line 82

[3.6043]→[3.6043:6562](∅→∅)

payoutsJSON :: Payouts -> Value
payoutsJSON (Payouts m) = toJSON $ MS.mapKeys (^. _BtcAddr) m

parsePayoutsJSON :: Value -> Parser Payouts
parsePayoutsJSON v =
Payouts . MS.mapKeys BtcAddr <$> parseJSON v

instance A.ToJSON Payouts where
toJSON = versioned (Version 1 0 0) . payoutsJSON

instance A.FromJSON Payouts where
parseJSON v = let parsePayouts (Version 1 0 0) = parsePayoutsJSON
parsePayouts v' = \_ -> fail . show $ printVersion v'
in unversion parsePayouts $ v
edit in lib/Quixotic/TimeLog.hs at line 84

[3.491]→[3.491:492](∅→∅),[3.351]→[3.6563:6599](∅→∅),[3.6599]→[3.493:613](∅→∅)

workIndexJSON :: WorkIndex -> Value
workIndexJSON (WorkIndex widx) =
toJSON $ (L.toList . fmap intervalJSON) <$> (MS.mapKeysMonotonic (^._BtcAddr) widx)
edit in lib/Quixotic/TimeLog.hs at line 85

[3.6694]→[3.6694:6766](∅→∅)

eventIdJSON :: EventId -> Value
eventIdJSON (EventId eid) = toJSON eid
replacement in server/Main.hs at line 48

[3.8476]→[3.2:55](∅→∅)

qms <- nestSnaplet "qmodules" qm qdbpgSnapletInit

[3.8476]

[3.8526]

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

[3.8755]→[3.6991:7055](∅→∅),[3.7055]→[3.851:914](∅→∅),[3.179]→[3.851:914](∅→∅),[3.914]→[3.7056:7504](∅→∅),[3.7504]→[3.847:926](∅→∅),[3.847]→[3.847:926](∅→∅),[3.926]→[3.7505:7585](∅→∅)

addRoutes [ ("login", requireLogin >> (redirect "/home"))
, ("register", void $ method POST registerHandler)
, ("projects/:projectId/logStart/:btcAddr", serveJSON eventIdJSON . method POST $ logWorkHandler StartWork)
, ("projects/:projectId/logEnd/:btcAddr", serveJSON eventIdJSON . method POST $ logWorkHandler StopWork)
, ("projects/:projectId/log/:btcAddr", serveJSON workIndexJSON $ method GET loggedIntervalsHandler)
, ("projects/:projectId", serveJSON projectJSON $ method GET projectGetHandler)
, ("projects", void $ method POST projectCreateHandler)
, ("payouts/:projectId", serveJSON id $ method GET payoutsHandler)

[3.8755]

[3.8999]

let loginRoute = requireLogin >> redirect "/home"
registerRoute = void $ method POST registerHandler

logEventRoute f = serveJSON eventIdJSON . method POST $ logWorkHandler f
loggedIntervalsRoute = serveJSON workIndexJSON $ method GET loggedIntervalsHandler

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

payoutsRoute = serveJSON payoutsJSON $ method GET payoutsHandler

addRoutes [ ("login", loginRoute)
, ("register", registerRoute)
, ("projects/:projectId/logStart/:btcAddr", logEventRoute StartWork)
, ("projects/:projectId/logEnd/:btcAddr", logEventRoute StopWork)
, ("projects/:projectId/log/:btcAddr", loggedIntervalsRoute)
, ("projects/:projectId", projectRoute)
, ("projects", listProjectsRoute)
, ("projects", projectCreateRoute)
, ("payouts/:projectId", payoutsRoute)
edit in server/Quixotic/Snaplet/Projects.hs at line 24

[3.2914]→[3.1312:1381](∅→∅)

projectGetHandler :: Handler App App Project
projectGetHandler = ok
edit in server/Quixotic/Snaplet/Projects.hs at line 40

[3.1564]

projectGetHandler :: Handler App App Project
projectGetHandler = do
QDB{..} <- view qdb <$> with qm get
uid <- requireUserId
pid <- requireProjectAccess uid
mp <- liftPG . runReaderT $ findProject pid
maybe (snapError 404 $ "Project not found for id " <> tshow pid) pure mp
replacement in server/Quixotic/Snaplet/WorkLog.hs at line 30

[2.3324]→[2.3324:3394](∅→∅)

storeEv addr = runReaderT . recordEvent pid uid $ logEntry addr

[2.3324]

[3.6163]

storeEv addr = runReaderT . createEvent pid uid $ logEntry addr