Clean up schema version handling.

[?]

Oct 22, 2016, 6:59 PM

7VGYLTMURLVSVUYFW7TCRZTDQ6RE2EPSPPA43XKHDOBFWYVVSJHQC

Dependencies

[2] FXJQACES Ensure that auction is not ended at the time of bid
[3] GKLIPHR5 Fix error in parsing of event metadata
[4] 2LZYVHFS Upgrade to Stack-based build in Docker
[5] 2XQD6KKK Add invitation logic and clean up DBProg error handling.
[6] 5OI44E4E Add authentication to auction search.
[7] SPJCFHXW Update shell scripts to point to https://aftok.com and prompt for input.
[8] HYV3VQAD Fix a couple of stupid typos.
[9] ASF3UPJL Add auction creation and bid handlers
[10] NLZ3JXLO Fix formatting with stylish-haskell.
[11] O5FVTOM6 Undo JSON silliness, enable a couple more routes.
[12] 4ZLEDBK7 Initial attempts at dockerizing, cabal isn't cooperating.
[13] Z3MK2PJ5 Add GET handler for retrieving auction data.
[14] RPAJLHMT Change to use UUIDs instead of ints for primary keys.
[15] JEOPOOPT Dockerfile now builds correctly.
[16] XTBSG4C7 Adding serveJSON combinator to eliminate some boilerplate from handlers.
[17] M3KUPGZK Add invitation email template.
[18] BWN72T44 Don't accept work timestamp from an external source.
[19] QMRKFEPG Refactor QDB to use a free monad algebra instead.
[20] XJ4EYMIH Let curl prompt for http password, rather than bash.
[21] 7HPY3QPF Fix linting errors. (yay hlint!)
[22] A6HKMINB Attempting to improve JSON handling.
[23] HALRDT2F Added initial auction create route.
[24] RN7EI6IN Update database layer to use CreditTo
[25] UILI6PIL The route-based logStart/logStop is nicer.
[26] Z7KS5XHH Very WIP. Wow.
[27] POX3UAMT Enabling logging of time to contributor/project accounts
[28] GCVQD44V Create amends endpoint, switch to UUID primary keys
[29] O722AOKE Add route to allow crediting of events to users/projects.
[*] W35DDBFY Factor common JSON conversions up into client lib module.
[*] 2G3GNDDU Event logging is now functioning in postgres.

Change contents

replacement in Dockerfile at line 17

[5.47]→[5.885:926](∅→∅),[5.787]→[5.885:926](∅→∅),[5.885]→[5.885:926](∅→∅),[5.926]→[4.296:439](∅→∅)

ADD ./aftok.cabal /opt/aftok/aftok.cabal
ADD ./stack.yaml /opt/aftok/stack.yaml
ADD ./lib /opt/aftok/lib
ADD ./server /opt/aftok/server
ADD ./test /opt/aftok/test

[5.47]

[5.48]

RUN mkdir -p /opt/aftok/bin
edit in Dockerfile at line 19

[5.67]

[4.440]

ADD ./aftok.cabal /opt/aftok/aftok.cabal
ADD ./docker/stack.yaml /opt/aftok/stack.yaml
replacement in Dockerfile at line 25

[5.1025]→[5.872:913](∅→∅),[5.913]→[4.483:499](∅→∅)

# Install and build aftok-server sources
RUN stack build

[5.1025]

[5.1081]

ADD ./lib /opt/aftok/lib
ADD ./server /opt/aftok/server
ADD ./test /opt/aftok/test

# build and install and aftok-server sources
RUN stack install
replacement in docker/aftok-server.sh at line 3

[5.1544]→[5.1544:1592](∅→∅)

/opt/aftok/dist/build/aftok-server/aftok-server

[5.1544]

/opt/aftok/bin/aftok-server
file addition: stack.yaml (----------)

[5.1510]

flags: {}
packages:
- '.'
extra-deps:
- snaplet-postgresql-simple-0.6.0.4
- resource-pool-catchio-0.2.1.0
resolver: lts-5.3
#allow-newer: true
local-bin-path: /opt/aftok/bin
replacement in lib/Aftok/Json.hs at line 54

[5.4331]→[5.4331:4468](∅→∅)

versioned :: Version -> Value -> Value
versioned ver v = object [ "schemaVersion" .= tshow ver
, "value" .= v ]

[5.4331]

[5.186]

versioned :: Version -> Object -> Value
versioned ver o = Object $ uncurry O.insert ("schemaVersion" .= tshow ver) o
replacement in lib/Aftok/Json.hs at line 61

[5.4578]→[5.4996:5089](∅→∅),[5.187]→[5.4996:5089](∅→∅),[5.5089]→[5.18:51](∅→∅)

unversion :: (Version -> Value -> Parser a) -> Value -> Parser a
unversion f (Object v) = do
verstr <- v .: "schemaVersion"

[5.4578]

[5.51]

unversion :: String -> (Version -> Object -> Parser a) -> Value -> Parser a
unversion name f o = do
verstr <- withObject name (.: "schemaVersion") o
replacement in lib/Aftok/Json.hs at line 65

[5.129]→[5.4690:4717](∅→∅),[5.460]→[5.4690:4717](∅→∅),[5.4690]→[5.4690:4717](∅→∅),[5.4717]→[5.1588:1604](∅→∅),[5.1604]→[5.4734:4806](∅→∅),[5.4734]→[5.4734:4806](∅→∅)

v .: "value" >>= f vers

unversion _ x =
fail $ show x <> " did not contain the expected version information."

[5.129]

[5.4806]

withObject name (f vers) o
replacement in lib/Aftok/Json.hs at line 71

[5.4853]→[5.4853:4874](∅→∅)

v1 :: Value -> Value

[5.4853]

[5.4874]

v1 :: Object -> Value
replacement in lib/Aftok/Json.hs at line 74

[5.792]→[5.792:813](∅→∅)

v2 :: Value -> Value

[5.792]

[5.813]

v2 :: Object -> Value
replacement in lib/Aftok/Json.hs at line 77

[5.4904]→[5.4904:4963](∅→∅),[5.4963]→[5.843:939](∅→∅)

unv1 :: String -> (Value -> Parser a) -> Value -> Parser a
unv1 name f = unversion $ \x -> case x of
Version 1 0 -> f
_ -> badVersion name x

[5.4904]

[5.939]

unv1 :: String -> (Object -> Parser a) -> Value -> Parser a
unv1 name f = unversion name $ p where
p (Version 1 0) = f
p ver = badVersion name ver
replacement in lib/Aftok/Json.hs at line 82

[5.940]→[5.940:993](∅→∅)

badVersion :: String -> Version -> Value -> Parser a

[5.940]

[5.993]

badVersion :: forall v a. String -> Version -> v -> Parser a
edit in lib/Aftok/Json.hs at line 85

[5.5115]

[5.5115]

-- convenience function to produce Object rather than Value
obj :: [Pair] -> Object
obj = O.fromList
replacement in lib/Aftok/Json.hs at line 95

[5.6666]→[5.1049:1102](∅→∅),[5.1102]→[5.5274:5318](∅→∅),[5.6721]→[5.5274:5318](∅→∅),[5.5274]→[5.5274:5318](∅→∅),[5.5318]→[5.1682:1693](∅→∅),[5.1682]→[5.1682:1693](∅→∅)

object [ "projectId" .= tshow (pid ^. _ProjectId)
, "project" .= projectJSON project
]

[5.6666]

[5.249]

obj [ "projectId" .= tshow (pid ^. _ProjectId)
, "project" .= projectJSON project
]
replacement in lib/Aftok/Json.hs at line 101

[5.311]→[5.311:365](∅→∅)

object [ "projectId" .= tshow (pid ^. _ProjectId) ]

[5.311]

[5.1693]

obj [ "projectId" .= tshow (pid ^. _ProjectId) ]
replacement in lib/Aftok/Json.hs at line 105

[5.5340]→[5.5315:5417](∅→∅),[5.5315]→[5.5315:5417](∅→∅),[5.5417]→[5.461:538](∅→∅)

object [ "projectName" .= (p ^. projectName)
, "inceptionDate" .= (p ^. inceptionDate)
, "initiator" .= tshow (p ^. (P.initiator._UserId))
]

[5.5340]

[5.538]

obj [ "projectName" .= (p ^. projectName)
, "inceptionDate" .= (p ^. inceptionDate)
, "initiator" .= tshow (p ^. (P.initiator._UserId))
]
replacement in lib/Aftok/Json.hs at line 112

[5.427]→[5.427:481](∅→∅)

object [ "auctionId" .= tshow (pid ^. _AuctionId) ]

[5.427]

[5.481]

obj [ "auctionId" .= tshow (pid ^. _AuctionId) ]
replacement in lib/Aftok/Json.hs at line 116

[5.592]→[5.592:782](∅→∅),[5.782]→[5.1168:1179](∅→∅),[5.1696]→[5.1168:1179](∅→∅),[5.1168]→[5.1168:1179](∅→∅)

object [ "projectId" .= tshow (x ^. (A.projectId._ProjectId))
, "initiator" .= tshow (x ^. (A.initiator._UserId))
, "raiseAmount" .= (x ^. (raiseAmount._Satoshi))
]

[5.592]

[5.483]

obj [ "projectId" .= tshow (x ^. (A.projectId._ProjectId))
, "initiator" .= tshow (x ^. (A.initiator._UserId))
, "raiseAmount" .= (x ^. (raiseAmount._Satoshi))
]
replacement in lib/Aftok/Json.hs at line 123

[5.533]→[5.533:579](∅→∅)

object [ "bidId" .= tshow (pid ^. _BidId) ]

[5.533]

[5.2560]

obj [ "bidId" .= tshow (pid ^. _BidId) ]
replacement in lib/Aftok/Json.hs at line 126

[5.1124]→[5.3150:3342](∅→∅),[5.3342]→[5.1296:1389](∅→∅),[5.1296]→[5.1296:1389](∅→∅)

creditToJSON (CreditToAddress addr) = v2 $ object [ "creditToAddress" .= (addr ^. _BtcAddr) ]
creditToJSON (CreditToUser uid) = v2 $ object [ "creditToUser" .= tshow (uid ^. _UserId) ]
creditToJSON (CreditToProject pid) = v2 $ object [ "creditToProject" .= projectIdJSON pid ]

[5.1124]

[5.580]

creditToJSON (CreditToAddress addr) = v2 $ obj [ "creditToAddress" .= (addr ^. _BtcAddr) ]
creditToJSON (CreditToUser uid) = v2 $ obj [ "creditToUser" .= tshow (uid ^. _UserId) ]
creditToJSON (CreditToProject pid) = v2 $ obj [ "creditToProject" .= projectIdJSON pid ]
replacement in lib/Aftok/Json.hs at line 136

[5.3577]→[5.3577:3622](∅→∅)

in toJSON $ fmap payoutsRec (MS.assocs m)

[5.3577]

[5.1904]

in obj $ [ "payouts" .= fmap payoutsRec (MS.assocs m) ]
replacement in lib/Aftok/Json.hs at line 144

[5.3924]→[5.3924:3969](∅→∅)

in toJSON $ fmap widxRec (MS.assocs widx)

[5.3924]

[5.2061]

in obj $ [ "workIndex" .= fmap widxRec (MS.assocs widx) ]
replacement in lib/Aftok/Json.hs at line 148

[5.5483]→[5.5483:5519](∅→∅)

object [ "eventId" .= tshow eid ]

[5.5483]

[5.1798]

obj [ "eventId" .= tshow eid ]
replacement in lib/Aftok/Json.hs at line 156

[5.1665]→[5.1665:1706](∅→∅),[5.1706]→[5.256:294](∅→∅),[5.294]→[5.1992:2031](∅→∅),[5.1992]→[5.1992:2031](∅→∅)

object [ "creditTo" .= creditToJSON c
, "event" .= logEventJSON ev
, "eventMeta" .= m
]

[5.1665]

[5.5559]

obj [ "creditTo" .= creditToJSON c
, "event" .= logEventJSON ev
, "eventMeta" .= m
]
replacement in lib/Aftok/Json.hs at line 163

[5.5641]→[5.5641:5681](∅→∅)

object [ "amendmentId" .= tshow aid ]

[5.5641]

[5.5681]

obj [ "amendmentId" .= tshow aid ]
edit in lib/Aftok/Json.hs at line 169

[5.2134]

[5.5725]

parseCreditTo :: Value -> Parser CreditTo
parseCreditTo = unversion "CreditTo" $ p where
p (Version 1 0) = parseCreditToV1
p (Version 2 0) = parseCreditToV2
p ver = badVersion "EventAmendment" ver

parseCreditToV1 :: Object -> Parser CreditTo
parseCreditToV1 x = CreditToAddress <$> (parseBtcAddrJson =<< (x .: "btcAddr"))

parseCreditToV2 :: Object -> Parser CreditTo
parseCreditToV2 o =
let parseCreditToAddr o' =
fmap CreditToAddress . parseBtcAddrJson <$> O.lookup "creditToAddress" o'

parseCreditToUser o' =
fmap (CreditToUser . UserId) . parseUUID <$> O.lookup "creditToUser" o'

parseCreditToProject o' =
fmap (CreditToProject . ProjectId) . parseUUID <$> O.lookup "creditToProject" o'

notFound = fail $ "Value " <> show o <> " does not represent a CreditTo value."
parseV v = (parseCreditToAddr v <|> parseCreditToUser v <|> parseCreditToProject v)

in fromMaybe notFound $ parseV o
replacement in lib/Aftok/Json.hs at line 195

[5.5769]→[5.3970:4400](∅→∅)

parsePayoutsJSON = unversion $ \ver -> case ver of
(Version 1 _) -> \v -> Payouts . MS.mapKeys (CreditToAddress . BtcAddr) <$> parseJSON v
(Version 2 0) -> \v -> do
xs <- parseJSON v
let parsePayoutRecord x = (,) <$> (parseCreditTo =<< (x .: "creditTo"))
<*> x .: "payoutRatio"
Payouts . MS.fromList <$> traverse parsePayoutRecord xs
_ -> badVersion "Payouts" ver

[5.5769]

[5.5859]

parsePayoutsJSON = unversion "Payouts" $ p where
p :: Version -> Object -> Parser Payouts
p (Version 1 _) v = Payouts . MS.mapKeys (CreditToAddress . BtcAddr) <$> parseJSON (Object v)
p (Version 2 0) v =
let parsePayoutRecord x = (,) <$> (parseCreditToV2 =<< (x .: "creditTo")) <*> x .: "payoutRatio"
in Payouts . MS.fromList <$> (traverse parsePayoutRecord =<< parseJSON (Object v))
p ver x = badVersion "Payouts" ver x
replacement in lib/Aftok/Json.hs at line 204

[5.5925]→[5.1775:1956](∅→∅)

parseEventAmendment t = unversion $ \v -> case v of
Version 1 0 -> parseEventAmendmentV1 t
Version 2 0 -> parseEventAmendmentV2 t
_ -> badVersion "EventAmendment" v

[5.5925]

[5.1956]

parseEventAmendment t = unversion "EventAmendment" $ p where
p (Version 1 _) = parseEventAmendmentV1 t
p (Version 2 0) = parseEventAmendmentV2 t
p ver = badVersion "EventAmendment" ver
replacement in lib/Aftok/Json.hs at line 209

[5.1957]→[5.1957:2063](∅→∅)

parseEventAmendmentV1 :: ModTime -> Value -> Parser EventAmendment
parseEventAmendmentV1 t v@(Object x) =

[5.1957]

[5.2063]

parseEventAmendmentV1 :: ModTime -> Object -> Parser EventAmendment
parseEventAmendmentV1 t o =
replacement in lib/Aftok/Json.hs at line 212

[5.2109]→[5.2109:2314](∅→∅)

parseA "timeChange" = TimeChange t <$> x .: "eventTime"
parseA "addrChange" = CreditToChange t <$> parseCreditTo v
parseA "metadataChange" = MetadataChange t <$> x .: "eventMeta"

[5.2109]

[5.4401]

parseA "timeChange" = TimeChange t <$> o .: "eventTime"
parseA "addrChange" = CreditToChange t <$> parseCreditToV1 o
parseA "metadataChange" = MetadataChange t <$> o .: "eventMeta"
replacement in lib/Aftok/Json.hs at line 216

[5.4481]→[5.2392:2428](∅→∅),[5.2392]→[5.2392:2428](∅→∅),[5.2428]→[5.4482:4510](∅→∅),[5.4510]→[5.2456:2512](∅→∅),[5.2456]→[5.2456:2512](∅→∅)

in x .: "amendment" >>= parseA

parseEventAmendmentV1 _ x =
fail $ "Value " <> show x <> " is not a JSON object."

[5.4481]

[5.2512]

in o .: "amendment" >>= parseA
replacement in lib/Aftok/Json.hs at line 218

[5.2513]→[5.2513:2619](∅→∅)

parseEventAmendmentV2 :: ModTime -> Value -> Parser EventAmendment
parseEventAmendmentV2 t v@(Object x) =

[5.2513]

[5.2619]

parseEventAmendmentV2 :: ModTime -> Object -> Parser EventAmendment
parseEventAmendmentV2 t o =
replacement in lib/Aftok/Json.hs at line 221

[5.2665]→[5.2665:2870](∅→∅)

parseA "timeChange" = TimeChange t <$> x .: "eventTime"
parseA "creditToChange" = CreditToChange t <$> parseCreditTo v
parseA "metadataChange" = MetadataChange t <$> x .: "eventMeta"

[5.2665]

[5.4511]

parseA "timeChange" = TimeChange t <$> o .: "eventTime"
parseA "creditToChange" = CreditToChange t <$> parseCreditToV2 o
parseA "metadataChange" = MetadataChange t <$> o .: "eventMeta"
replacement in lib/Aftok/Json.hs at line 225

[5.4591]→[5.2948:2983](∅→∅),[5.2948]→[5.2948:2983](∅→∅)

in x .: "amendment" >>= parseA

[5.4591]

[5.2983]

in o .: "amendment" >>= parseA
edit in lib/Aftok/Json.hs at line 227

[5.2984]→[5.4592:4620](∅→∅),[5.4620]→[5.3012:3069](∅→∅),[5.3012]→[5.3012:3069](∅→∅)

parseEventAmendmentV2 _ x =
fail $ "Value " <> show x <> " is not a JSON object."
edit in lib/Aftok/Json.hs at line 236

[5.4851]→[5.3478:3479](∅→∅),[5.3478]→[5.3478:3479](∅→∅),[5.3479]→[5.295:539](∅→∅),[5.539]→[5.3479:3605](∅→∅),[5.3479]→[5.3479:3605](∅→∅),[5.2003]→[5.6554:6555](∅→∅),[5.3605]→[5.6554:6555](∅→∅),[5.6554]→[5.6554:6555](∅→∅),[5.6555]→[5.3606:3825](∅→∅),[5.3825]→[5.4852:4888](∅→∅)

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

parseCreditToV1 :: Object -> Parser CreditTo
parseCreditToV1 x = CreditToAddress <$> (parseBtcAddrJson =<< (x .: "btcAddr"))

parseCreditToV2 :: Object -> Parser CreditTo
parseCreditToV2 x =
let parseCreditToAddr (Object x') = do
addrText <- O.lookup "creditToAddress" x'
pure (CreditToAddress <$> parseBtcAddrJson addrText)
parseCreditToAddr _ = Nothing
edit in lib/Aftok/Json.hs at line 237

[5.3863]→[5.4889:5073](∅→∅),[5.5073]→[5.3946:3947](∅→∅),[5.3946]→[5.3946:3947](∅→∅),[5.3947]→[5.5074:5164](∅→∅),[5.5164]→[5.4036:4290](∅→∅),[5.4036]→[5.4036:4290](∅→∅)

parseCreditToUser (Object x') = do
userText <- O.lookup "creditToUser" x'
pure (CreditToUser . UserId <$> parseUUID userText)
parseCreditToUser _ = Nothing

--parseCreditToProject (Object x') = Nothing
parseCreditToProject _ = Nothing

notFound = fail $ "Value " <> show x <> " does not represent a CreditTo value."
parseV v = (parseCreditToAddr v <|> parseCreditToUser v <|> parseCreditToProject v)

in do
body <- x .: "creditTo"
fromMaybe notFound $ parseV body
replacement in lib/Aftok/Json.hs at line 238

[5.87]→[5.87:137](∅→∅),[5.137]→[5.164:263](∅→∅),[5.164]→[5.164:263](∅→∅),[5.263]→[3.3:39](∅→∅)

parseLogEntry f = unversion parseLogEntry' where
parseLogEntry' (Version 2 0) (Object x) = do
creditTo' <- x .: "creditTo" >>= parseCreditTo
eventMeta' <- x .:? "eventMeta"

[5.87]

[5.138]

parseLogEntry f = unversion "LogEntry" p where
p (Version 2 0) o = do
creditTo' <- o .: "creditTo" >>= parseCreditToV2
eventMeta' <- o .:? "eventMeta"
replacement in lib/Aftok/Json.hs at line 244

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

parseLogEntry' v x = badVersion "LogEntry" v x

[5.665]

[5.987]

p v o = badVersion "LogEntry" v o
replacement in scripts/log_end.sh at line 8

[5.562]→[3.67:186](∅→∅)

curl -v -k -u $USER -X POST -d "{\"creditTo\": {\"creditToUser\": \"$UID\"}}" "https://aftok.com/projects/$PID/logEnd"

[5.562]

curl -v -k -u $USER -X POST -d "{\"schemaVersion\": \"2.0\", \"creditTo\": {\"creditToUser\": \"$UID\"}}" "https://aftok.com/projects/$PID/logEnd"
replacement in scripts/log_start.sh at line 8

[5.803]→[3.240:361](∅→∅)

curl -v -k -u $USER -X POST -d "{\"creditTo\": {\"creditToUser\": \"$UID\"}}" "https://aftok.com/projects/$PID/logStart"

[5.803]

curl -v -k -u $USER -X POST -d "{\"schemaVersion\": \"2.0\", \"creditTo\": {\"creditToUser\": \"$UID\"}}" "https://aftok.com/projects/$PID/logStart"
replacement in server/Aftok/Snaplet/Auctions.hs at line 30

[5.3137]→[5.3137:3282](∅→∅),[5.3282]→[5.861:885](∅→∅)

auctionCreateParser = unv1 "auctions" $ \v ->
case v of
(Object o) -> CA <$> o .: "raiseAmount"
<*> o .: "auctionEnd"
_ -> mzero

[5.3137]

[5.885]

auctionCreateParser = unv1 "auctions" p where
p o = CA <$> o .: "raiseAmount" <*> o .: "auctionEnd"
replacement in server/Aftok/Snaplet/Auctions.hs at line 34

[5.947]→[5.947:1163](∅→∅),[5.1163]→[5.3282:3306](∅→∅),[5.3282]→[5.3282:3306](∅→∅)

bidCreateParser uid t = unv1 "bids" $ \v ->
case v of
(Object o) -> Bid uid <$> (Seconds <$> o .: "bidSeconds")
<*> (Satoshi <$> o .: "bidAmount")
<*> pure t
_ -> mzero

[5.947]

[5.3306]

bidCreateParser uid t = unv1 "bids" p where
p o = Bid uid <$> (Seconds <$> o .: "bidSeconds")
<*> (Satoshi <$> o .: "bidAmount")
<*> pure t
edit in server/Aftok/Snaplet/Auctions.hs at line 63

[5.1576]→[2.781:786](∅→∅)