Add route to allow crediting of events to users/projects.

[?]

Oct 20, 2016, 1:47 AM

O722AOKEWXWJPRHGJREU6QPW7HEFPPRETZIAADZ2RMAXHARCNEKAC

Dependencies

[2] RN7EI6IN Update database layer to use CreditTo
[3] SCXG6TJW Make log reduction safer in presence of overlapping events.
[4] XTBSG4C7 Adding serveJSON combinator to eliminate some boilerplate from handlers.
[5] IZEVQF62 Work in progress replacing sqlite with postgres.
[6] KNSI575V Cleanup of EventLog types.
[7] GCVQD44V Create amends endpoint, switch to UUID primary keys
[8] 4U7F3CPI THE GREAT RENAMING OF THINGS!
[9] HALRDT2F Added initial auction create route.
[10] NVOCQVAS Initial failing tests.
[11] TLQ72DSJ Lenses, sqlite-simple
[12] 7KZP4RHZ Switch from Data.Time to Data.Thyme
[13] MB5SHULB Add route for accepting an invitation with an existing account
[14] QMRKFEPG Refactor QDB to use a free monad algebra instead.
[15] A6HKMINB Attempting to improve JSON handling.
[16] POX3UAMT Enabling logging of time to contributor/project accounts
[17] O5FVTOM6 Undo JSON silliness, enable a couple more routes.
[18] ASF3UPJL Add auction creation and bid handlers
[19] Z3MK2PJ5 Add GET handler for retrieving auction data.
[20] EZQG2APB Update task list.
[21] 2XQD6KKK Add invitation logic and clean up DBProg error handling.
[22] RPAJLHMT Change to use UUIDs instead of ints for primary keys.
[23] MGOF7IUF Update TASKS list to reflect completed projects.
[24] NEDDHXUK Reformat via stylish-haskell
[25] BROSTG5K Beginning of modularization of server.
[*] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[*] WZUHEZSB Start of migration back toward snap.
[*] W35DDBFY Factor common JSON conversions up into client lib module.
[*] ADMKQQGC Initial empty Snap project.

Change contents

edit in aftok.cabal at line 118

[28.161]

[3.1]

, errors
replacement in lib/Aftok/Json.hs at line 63

[3.5089]→[3.4579:4614](∅→∅),[3.4614]→[3.383:460](∅→∅)

verstr <- v .: "schemaVersion"
vers <- either fail pure $ PC.parseOnly versionParser (encodeUtf8 verstr)

[3.5089]

[3.4690]

verstr <- v .: "schemaVersion"
vers <- either fail pure $ PC.parseOnly versionParser (encodeUtf8 verstr)
edit in lib/Aftok/Json.hs at line 149

[3.1799]

[3.1799]

logEventJSON :: LogEvent -> Value
logEventJSON ev = object [ eventName ev .= object [ "eventTime" .= (ev ^. eventTime) ] ]
replacement in lib/Aftok/Json.hs at line 156

[3.1706]→[3.1909:1992](∅→∅),[3.1909]→[3.1909:1992](∅→∅)

, "eventType" .= eventName ev
, "eventTime" .= (ev ^. eventTime)

[3.1706]

[3.1992]

, "event" .= logEventJSON ev
edit in lib/Aftok/Json.hs at line 213

[3.6407]→[3.3236:3322](∅→∅),[3.3322]→[2.4621:4676](∅→∅),[2.4676]→[3.3376:3478](∅→∅),[3.3376]→[3.3376:3478](∅→∅),[3.3478]→[2.4677:4678](∅→∅)

parseCreditTo :: Value -> Parser CreditTo
parseCreditTo = unversion $ \x -> case x of
Version 1 0 -> withObject "BtcAddr" parseCreditToV1
Version 2 0 -> withObject "CreditTo" parseCreditToV2
_ -> badVersion "EventAmendment" x
edit in lib/Aftok/Json.hs at line 218

[3.3479]

[3.3479]

parseCreditTo :: Value -> Parser CreditTo
parseCreditTo = unversion $ \v -> case v of
Version 1 0 -> withObject "BtcAddr" parseCreditToV1
Version 2 0 -> withObject "CreditTo" parseCreditToV2
_ -> badVersion "EventAmendment" v
edit in lib/Aftok/Json.hs at line 249

[3.4290]

parseLogEvent :: Object -> Parser LogEvent
parseLogEvent x =
(StartWork <$> x .: "start") <|> (StopWork <$> x .: "stop")

parseLogEntry :: Value -> Parser LogEntry
parseLogEntry = unversion parseLogEntry' where
parseLogEntry' (Version 2 0) (Object x) =
LogEntry <$> (x .: "creditTo" >>= parseCreditTo)
<*> (x .: "event" >>= parseLogEvent)
<*> (x .: "eventMeta")
parseLogEntry' v x = badVersion "LogEntry" v x
replacement in lib/Aftok/TimeLog.hs at line 54

[3.1757]→[3.3855:3928](∅→∅),[3.3855]→[3.3855:3928](∅→∅)

nameEvent "start" = return StartWork
nameEvent "stop" = return StopWork

[3.1757]

[3.3928]

nameEvent "start" = pure StartWork
nameEvent "stop" = pure StopWork
replacement in server/Aftok/Snaplet/WorkLog.hs at line 11

[3.5642]→[3.9813:9836](∅→∅)

import Aftok

[3.5642]

[3.9836]

import Aftok (parseBtcAddr)
replacement in server/Aftok/Snaplet/WorkLog.hs at line 36

[3.10182]→[3.12757:12851](∅→∅),[3.8301]→[3.12757:12851](∅→∅)

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

[3.10182]

[3.6347]

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

recordLogEntryHandler :: Handler App App EventId
recordLogEntryHandler = do
uid <- requireUserId
pid <- requireProjectId
requestBody <- readRequestBody 4096
timestamp <- liftIO C.getCurrentTime
case A.eitherDecode requestBody >>= parseEither parseLogEntry of
Left err -> snapError 400 $ "Unable to parse log entry " <> (tshow requestBody) <> ": " <> tshow err
Right entry -> snapEval $ createEvent pid uid (event.eventTime .~ timestamp $ entry)
replacement in server/Main.hs at line 39

[3.2275]→[3.2275:2397](∅→∅),[3.2397]→[3.1075:1145](∅→∅)

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

[3.2275]

[3.212]

let loginRoute = requireLogin >> redirect "/home"
registerRoute = void $ method POST registerHandler
acceptInviteRoute = void $ method POST acceptInvitationHandler
replacement in server/Main.hs at line 43

[3.213]→[3.1578:1664](∅→∅),[3.1664]→[3.12647:12738](∅→∅),[3.12647]→[3.12647:12738](∅→∅)

projectCreateRoute = serveJSON projectIdJSON $ method POST projectCreateHandler
listProjectsRoute = serveJSON (fmap qdbProjectJSON) $ method GET projectListHandler

[3.213]

[3.2397]

projectCreateRoute = serveJSON projectIdJSON $ method POST projectCreateHandler
listProjectsRoute = serveJSON (fmap qdbProjectJSON) $ method GET projectListHandler
replacement in server/Main.hs at line 46

[3.2398]→[3.12739:12819](∅→∅),[3.12819]→[3.1665:1747](∅→∅),[3.1747]→[3.3245:3333](∅→∅),[3.2480]→[3.3245:3333](∅→∅),[3.3333]→[3.1634:1721](∅→∅),[3.1721]→[3.12820:12970](∅→∅),[3.7876]→[3.12820:12970](∅→∅)

projectRoute = serveJSON projectJSON $ method GET projectGetHandler
logEventRoute f = serveJSON eventIdJSON $ method POST (logWorkHandler f)
logEntriesRoute = serveJSON (fmap logEntryJSON) $ method GET logEntriesHandler
logIntervalsRoute = serveJSON workIndexJSON $ method GET loggedIntervalsHandler
payoutsRoute = serveJSON payoutsJSON $ method GET payoutsHandler
inviteRoute = void . method POST $ projectInviteHandler cfg

[3.2398]

[3.12970]

projectRoute = serveJSON projectJSON $ method GET projectGetHandler
logWorkRoute f = serveJSON eventIdJSON $ method POST (logWorkHandler f)
recordLogEntryRoute = serveJSON eventIdJSON $ method POST recordLogEntryHandler
logEntriesRoute = serveJSON (fmap logEntryJSON) $ method GET logEntriesHandler
logIntervalsRoute = serveJSON workIndexJSON $ method GET loggedIntervalsHandler
payoutsRoute = serveJSON payoutsJSON $ method GET payoutsHandler
inviteRoute = void . method POST $ projectInviteHandler cfg
replacement in server/Main.hs at line 54

[3.12971]→[3.1748:1834](∅→∅),[3.1834]→[3.1722:1802](∅→∅),[3.4230]→[3.1722:1802](∅→∅),[3.1802]→[3.1835:1914](∅→∅)

auctionCreateRoute = serveJSON auctionIdJSON $ method POST auctionCreateHandler
auctionRoute = serveJSON auctionJSON $ method GET auctionGetHandler
auctionBidRoute = serveJSON bidIdJSON $ method POST auctionBidHandler

[3.12971]

[3.4230]

auctionCreateRoute = serveJSON auctionIdJSON $ method POST auctionCreateHandler
auctionRoute = serveJSON auctionJSON $ method GET auctionGetHandler
auctionBidRoute = serveJSON bidIdJSON $ method POST auctionBidHandler
replacement in server/Main.hs at line 58

[3.4231]→[3.7876:7960](∅→∅),[3.12971]→[3.7876:7960](∅→∅),[3.7876]→[3.7876:7960](∅→∅)

amendEventRoute = serveJSON amendmentIdJSON $ method PUT amendEventHandler

[3.4231]

[3.2569]

amendEventRoute = serveJSON amendmentIdJSON $ method PUT amendEventHandler
replacement in server/Main.hs at line 68

[3.3549]→[3.2968:3049](∅→∅),[3.8018]→[3.2968:3049](∅→∅),[3.13135]→[3.2968:3049](∅→∅),[3.2968]→[3.2968:3049](∅→∅),[3.3049]→[3.11924:12004](∅→∅)

, ("projects/:projectId/logStart/:btcAddr", logEventRoute StartWork)
, ("projects/:projectId/logEnd/:btcAddr", logEventRoute StopWork)

[3.13135]

[3.3631]

, ("projects/:projectId/logStart/:btcAddr", logWorkRoute StartWork)
, ("projects/:projectId/logEnd/:btcAddr", logWorkRoute StopWork)
, ("projects/:projectId/logWorkEvent", recordLogEntryRoute)