Adding serveJSON combinator to eliminate some boilerplate from handlers.

[?]

Mar 17, 2015, 11:42 PM

XTBSG4C7SCZUFOU2BTNFR6B6TCGYI35BWUV4PVTS3N7KNH5VEARQC

Dependencies

[2] EZQG2APB Update task list.
[3] W35DDBFY Factor common JSON conversions up into client lib module.
[4] PBD7LZYQ Postgres & auth are beginning to function.
[5] BROSTG5K Beginning of modularization of server.
[6] 4IQVQL4T Added client for payouts endpoint.
[7] LD4GLVSF More database stuff.
[8] Z7KS5XHH Very WIP. Wow.
[9] IZEVQF62 Work in progress replacing sqlite with postgres.
[10] I2KHGVD4 Require project permissions for access to most data.
[11] 2G3GNDDU Event logging is now functioning in postgres.
[*] ADMKQQGC Initial empty Snap project.
[*] 2Y2QZFVF Switch to more modern cabal2nix-based workflow.
[*] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.

Change contents

edit in lib/Quixotic/Database/PostgreSQL.hs at line 217

[3.1369]→[3.1369:1370](∅→∅)
replacement in lib/Quixotic/Json.hs at line 9

[3.215]→[3.215:231](∅→∅)

import Data.Map

[3.215]

[3.231]

import qualified Data.Map as M
replacement in lib/Quixotic/Json.hs at line 20

[3.2143]→[2.3779:3816](∅→∅)

toJSON $ mapKeys (^. _BtcAddr) p

[3.2143]

[3.484]

toJSON $ M.mapKeys (^. _BtcAddr) p
replacement in lib/Quixotic/Json.hs at line 24

[3.748]→[3.2178:2225](∅→∅)

PayoutsJ . mapKeys BtcAddr <$> parseJSON v

[3.748]

[3.2225]

PayoutsJ . M.mapKeys BtcAddr <$> parseJSON v
edit in lib/Quixotic/Json.hs at line 37

[3.2559]

[3.485]

newtype ProjectJ = ProjectJ Project
makePrisms ''ProjectJ

instance ToJSON ProjectJ where
toJSON (ProjectJ p) =
object [ "projectName" .= (p ^. projectName)
, "inceptionDate" .= (p ^. inceptionDate)
, "initiator" .= (p ^. (initiator._UserId)) ]
edit in lib/Quixotic/Json.hs at line 47

[3.486]

[3.2560]

newtype WidxJ = WidxJ WorkIndex
makePrisms ''WidxJ
edit in lib/Quixotic/Json.hs at line 50

[3.2561]

instance ToJSON WidxJ where
toJSON (WidxJ widx) =
toJSON $ (fmap IntervalJ) <$> (M.mapKeysWith (++) (^._BtcAddr) widx)
edit in server/Main.hs at line 10

[14.170]

[3.918]

import qualified Data.Aeson as A
edit in server/Main.hs at line 13

[15.2567]

[3.942]

import Quixotic.Json
replacement in server/Main.hs at line 57

[3.1105]→[3.1105:1196](∅→∅),[3.1196]→[3.1826:1879](∅→∅),[3.3862]→[3.1826:1879](∅→∅),[3.1879]→[3.1197:1396](∅→∅)

, ("projects/:projectId/log/:btcAddr", method GET loggedIntervalsHandler)
, ("projects/:projectId", method GET ok)
, ("projects", void $ method POST projectCreateHandler)
, ("projects", void $ method GET projectListHandler)
, ("payouts/:projectId", method GET payoutsHandler)

[3.1105]

[3.8999]

, ("projects/:projectId/log/:btcAddr", serveJSON WidxJ $ method GET loggedIntervalsHandler)
, ("projects/:projectId", serveJSON ProjectJ $ method GET projectGetHandler)
, ("projects", void $ method POST projectCreateHandler)
, ("projects", serveJSON (fmap (ProjectJ._project)) $ method GET projectListHandler)
, ("payouts/:projectId", serveJSON PayoutsJ $ method GET payoutsHandler)
edit in server/Main.hs at line 90

[14.1197]

serveJSON :: (MonadSnap m, A.ToJSON a) => (b -> a) -> m b -> m ()
serveJSON f ma = do
modifyResponse $ addHeader "content-type" "application/json"
writeLBS =<< (A.encode . f <$> ma)
edit in server/Quixotic/Snaplet/Projects.hs at line 24

[3.2914]

[3.2914]

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

[3.3443]→[3.3443:3516](∅→∅)

projectListHandler :: Handler App App [Project]
projectListHandler = ok

[3.3443]

projectListHandler :: Handler App App [QDBProject]
projectListHandler = do
QDB{..} <- view qdb <$> with qm get
uid <- requireUserId
liftPG . runReaderT $ findUserProjects uid
edit in server/Quixotic/Snaplet/WorkLog.hs at line 8

[3.5625]→[2.4291:4322](∅→∅)

import qualified Data.Map as M
edit in server/Quixotic/Snaplet/WorkLog.hs at line 11

[3.5683]→[3.5683:5704](∅→∅)

import Quixotic.Json
replacement in server/Quixotic/Snaplet/WorkLog.hs at line 35

[3.6348]→[3.6348:6393](∅→∅)

loggedIntervalsHandler :: Handler App App ()

[3.6348]

[3.3428]

loggedIntervalsHandler :: Handler App App WorkIndex
replacement in server/Quixotic/Snaplet/WorkLog.hs at line 40

[3.3515]→[3.3515:3565](∅→∅),[3.3565]→[3.6518:6581](∅→∅),[3.6518]→[3.6518:6581](∅→∅),[3.6581]→[2.4461:4546](∅→∅)

widx <- liftPG . runReaderT $ readWorkIndex pid
modifyResponse $ addHeader "content-type" "application/json"
writeLBS . A.encode . fmap (fmap IntervalJ) $ M.mapKeysWith (++) (^._BtcAddr) widx

[3.3515]

[3.6631]

liftPG . runReaderT $ readWorkIndex pid
replacement in server/Quixotic/Snaplet/WorkLog.hs at line 42

[3.6632]→[3.6632:6669](∅→∅)

payoutsHandler :: Handler App App ()

[3.6632]

[3.3650]

payoutsHandler :: Handler App App Payouts
replacement in server/Quixotic/Snaplet/WorkLog.hs at line 49

[3.6823]→[3.6823:6886](∅→∅),[3.6886]→[3.4209:4266](∅→∅)

modifyResponse $ addHeader "content-type" "application/json"
writeLBS . A.encode . PayoutsJ $ payouts df ptime widx

[3.6779]

[3.3781]

pure $ payouts df ptime widx