Update database layer to use CreditTo

[?]

Oct 15, 2016, 5:12 AM

RN7EI6INGUUHGMNY5RU3NH56WPLRZY5ZMYDNFMNE3TGV4ESFLQIAC

Dependencies

[2] POX3UAMT Enabling logging of time to contributor/project accounts
[3] 3QVT6MA6 Add database support for event amend operations.
[4] FD7SV5I6 Fix handling of event_t columns.
[5] KNSI575V Cleanup of EventLog types.
[6] A6HKMINB Attempting to improve JSON handling.
[7] QMRKFEPG Refactor QDB to use a free monad algebra instead.
[8] NLZ3JXLO Fix formatting with stylish-haskell.
[9] IZEVQF62 Work in progress replacing sqlite with postgres.
[10] NEDDHXUK Reformat via stylish-haskell
[11] Z7KS5XHH Very WIP. Wow.
[12] O5FVTOM6 Undo JSON silliness, enable a couple more routes.
[13] 7KZP4RHZ Switch from Data.Time to Data.Thyme
[14] 7HPY3QPF Fix linting errors. (yay hlint!)
[15] GCVQD44V Create amends endpoint, switch to UUID primary keys
[16] 2XQD6KKK Add invitation logic and clean up DBProg error handling.
[17] ASF3UPJL Add auction creation and bid handlers
[*] W35DDBFY Factor common JSON conversions up into client lib module.
[*] NVOCQVAS Initial failing tests.
[*] SCXG6TJW Make log reduction safer in presence of overlapping events.

Change contents

edit in lib/Aftok/Database/PostgreSQL.hs at line 19

[4.1559]

[4.1011]

import Database.PostgreSQL.Simple.Types (Null)
edit in lib/Aftok/Database/PostgreSQL.hs at line 37

[4.2026]→[4.2026:2027](∅→∅),[4.2027]→[4.39:94](∅→∅),[4.1124]→[4.39:94](∅→∅),[4.94]→[4.4:48](∅→∅),[4.1165]→[4.4:48](∅→∅),[4.48]→[4.1739:1769](∅→∅),[4.1769]→[4.113:158](∅→∅),[4.113]→[4.113:158](∅→∅),[4.158]→[4.1770:1814](∅→∅),[4.1814]→[4.203:469](∅→∅),[4.203]→[4.203:469](∅→∅),[4.469]→[4.1815:1824](∅→∅),[4.1824]→[4.479:522](∅→∅),[4.479]→[4.479:522](∅→∅),[4.522]→[4.1825:1867](∅→∅),[4.1867]→[4.565:765](∅→∅),[4.565]→[4.565:765](∅→∅)

eventTypeParser :: FieldParser (C.UTCTime -> LogEvent)
eventTypeParser f v = do
tn <- typename f
case tn of
"event_t" ->
let err = UnexpectedNull (B.unpack tn)
(tableOid f)
(maybe "" B.unpack (name f))
"UTCTime -> LogEvent"
"columns of type event_t should not contain null values"
in maybe (conversionError err) (nameEvent . decodeUtf8) v
_ ->
let err = Incompatible (B.unpack tn)
(tableOid f)
(maybe "" B.unpack (name f))
"UTCTime -> LogEvent"
"column was not of type event_t"
in conversionError err
edit in lib/Aftok/Database/PostgreSQL.hs at line 61

[4.1910]

[4.271]

nullField :: RowParser Null
nullField = field

eventTypeParser :: FieldParser (C.UTCTime -> LogEvent)
eventTypeParser f v = do
tn <- typename f
case tn of
"event_t" ->
let err = UnexpectedNull (B.unpack tn)
(tableOid f)
(maybe "" B.unpack (name f))
"UTCTime -> LogEvent"
"columns of type event_t should not contain null values"
in maybe (conversionError err) (nameEvent . decodeUtf8) v
_ ->
let err = Incompatible (B.unpack tn)
(tableOid f)
(maybe "" B.unpack (name f))
"UTCTime -> LogEvent"
"column was not of type event_t"
in conversionError err
edit in lib/Aftok/Database/PostgreSQL.hs at line 84

[4.272]

[4.241]

creditToParser :: FieldParser (RowParser CreditTo)
creditToParser f v = do
tn <- typename f
let parser :: Text -> Conversion (RowParser CreditTo)
parser tname = pure $ case tname of
"credit_to_btc_addr" -> CreditToAddress <$> (fieldWith btcAddrParser <* nullField <* nullField)
"credit_to_user" -> CreditToUser <$> (nullField *> fieldWith uidParser <* nullField)
"credit_to_project" -> CreditToProject <$> (nullField *> nullField *> fieldWith pidParser)
_ -> empty

case tn of
"credit_to_t" -> maybe empty (parser . decodeUtf8) v
_ -> conversionError $
Incompatible
(B.unpack tn)
(tableOid f)
(maybe "" B.unpack (name f))
"RowParser CreditTo"
"column was not of type event_t"
replacement in lib/Aftok/Database/PostgreSQL.hs at line 108

[4.1928]→[4.1928:1967](∅→∅)

LogEntry <$> fieldWith btcAddrParser

[4.1928]

[4.336]

LogEntry <$> join (fieldWith creditToParser)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 190

[3.182]→[3.182:316](∅→∅)

\(project_id, user_id, credit_to_btc_addr, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?) \

[3.182]

[3.316]

\(project_id, user_id, credit_to_type, credit_to_btc_addr, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?, ?) \
replacement in lib/Aftok/Database/PostgreSQL.hs at line 193

[3.341]→[3.341:425](∅→∅)

( pid, uid, addr ^. _BtcAddr, eventName e, fromThyme $ e ^. eventTime, m)

[3.341]

[3.425]

( pid, uid, creditToName c, addr ^. _BtcAddr, eventName e, fromThyme $ e ^. eventTime, m)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 195

[3.426]→[3.426:455](∅→∅)

CreditToProject pid ->

[3.426]

[3.455]

CreditToProject pid' ->
replacement in lib/Aftok/Database/PostgreSQL.hs at line 198

[3.516]→[3.516:652](∅→∅)

\(project_id, user_id, credit_to_project_id, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?) \

[3.516]

[3.652]

\(project_id, user_id, credit_to_type, credit_to_project_id, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?, ?) \
replacement in lib/Aftok/Database/PostgreSQL.hs at line 201

[3.677]→[3.677:762](∅→∅)

( pid, uid, pid ^. _ProjectId, eventName e, fromThyme $ e ^. eventTime, m)

[3.677]

[3.762]

( pid, uid, creditToName c, pid' ^. _ProjectId, eventName e, fromThyme $ e ^. eventTime, m)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 203

[3.763]→[3.763:789](∅→∅)

CreditToUser uid ->

[3.763]

[3.789]

CreditToUser uid' ->
replacement in lib/Aftok/Database/PostgreSQL.hs at line 206

[3.850]→[3.850:983](∅→∅)

\(project_id, user_id, credit_to_user_id, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?) \

[3.850]

[3.983]

\(project_id, user_id, credit_to_type, credit_to_user_id, event_type, event_time, event_metadata) \
\VALUES (?, ?, ?, ?, ?, ?, ?) \
replacement in lib/Aftok/Database/PostgreSQL.hs at line 209

[3.1008]→[3.1008:1090](∅→∅)

( pid, uid, pid ^. _UserId, eventName e, fromThyme $ e ^. eventTime, m)

[3.1008]

[4.1807]

( pid, uid, creditToName c, uid' ^. _UserId, eventName e, fromThyme $ e ^. eventTime, m)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 213

[4.277]→[4.1059:1162](∅→∅),[4.1059]→[4.1059:1162](∅→∅)

"SELECT project_id, user_id, btc_addr, event_type, event_time, event_metadata FROM work_events \

[4.277]

[4.1162]

"SELECT project_id, user_id, \
\credit_to_type, credit_to_btc_addr, credit_to_user_id, credit_to_project_id, \
\event_type, event_time, event_metadata FROM work_events \
replacement in lib/Aftok/Database/PostgreSQL.hs at line 242

[4.1952]→[3.1217:1305](∅→∅)

dbEval (AmendEvent (EventId eid) (CreditToChange mt creditTo)) =
case creditTo of

[4.1952]

[3.1305]

dbEval (AmendEvent (EventId eid) (CreditToChange mt c)) =
case c of
replacement in lib/Aftok/Database/PostgreSQL.hs at line 249

[3.1532]→[3.1532:1617](∅→∅)

( eid, fromThyme $ mt ^. _ModTime, "credit_to_address", addr ^. _BtcAddr )

[3.1532]

[4.2903]

( eid, fromThyme $ mt ^. _ModTime, creditToName c, addr ^. _BtcAddr )
replacement in lib/Aftok/Database/PostgreSQL.hs at line 256

[3.1846]→[3.1846:1932](∅→∅)

( eid, fromThyme $ mt ^. _ModTime, "credit_to_project", pid ^. _ProjectId )

[3.1846]

[3.1932]

( eid, fromThyme $ mt ^. _ModTime, creditToName c, pid ^. _ProjectId )
edit in lib/Aftok/Database/PostgreSQL.hs at line 259

[3.1960]

[3.1960]

pinsert AmendmentId
replacement in lib/Aftok/Database/PostgreSQL.hs at line 263

[3.2128]→[3.2128:2208](∅→∅)

( eid, fromThyme $ mt ^. _ModTime, "credit_to_user", uid ^. _UserId )

[3.2128]

[3.2208]

( eid, fromThyme $ mt ^. _ModTime, creditToName c, uid ^. _UserId )
edit in lib/Aftok/Json.hs at line 17

[2.790]

[19.231]

import Data.UUID as U
replacement in lib/Aftok/Json.hs at line 125

[2.1124]→[2.1124:1296](∅→∅)

creditToJSON (CreditToAddress addr) = v2 $ object [ "creditToAddress" .= addr ]
creditToJSON (CreditToUser uid) = v2 $ object [ "creditToUser" .= (uid ^. _UserId) ]

[2.1124]

[2.1296]

creditToJSON (CreditToAddress addr) = v2 $ object [ "creditToAddress" .= (addr ^. _BtcAddr) ]
creditToJSON (CreditToUser uid) = v2 $ object [ "creditToUser" .= tshow (uid ^. _UserId) ]
replacement in lib/Aftok/Json.hs at line 130

[4.1727]→[4.5341:5372](∅→∅),[4.5372]→[2.1390:1439](∅→∅)

payoutsJSON (Payouts m) = v1 $
toJSON $ (creditToJSON *** id) <$> MS.assocs m

[4.1727]

[4.1904]

payoutsJSON (Payouts m) = v2 $
let payoutsRec :: (CreditTo, Rational) -> Value
payoutsRec (c, r) = object [ "creditTo" .= creditToJSON c
, "payoutRatio" .= r
]
in toJSON $ fmap payoutsRec (MS.assocs m)
replacement in lib/Aftok/Json.hs at line 137

[4.1905]→[2.1440:1625](∅→∅)

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

[4.1905]

[4.2061]

workIndexJSON :: WorkIndex -> Value
workIndexJSON (WorkIndex widx) = v2 $
let widxRec :: (CreditTo, NonEmpty Interval) -> Value
widxRec (c, l) = object [ "creditTo" .= creditToJSON c
, "intervals" .= (intervalJSON <$> L.toList l)
]
in toJSON $ fmap widxRec (MS.assocs widx)
replacement in lib/Aftok/Json.hs at line 166

[4.5769]→[4.5769:5811](∅→∅),[4.5811]→[2.1707:1774](∅→∅)

parsePayoutsJSON = unv1 "payouts" $ \v ->
Payouts . MS.mapKeys (CreditToAddress . BtcAddr) <$> parseJSON v

[4.5769]

[4.5859]

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
replacement in lib/Aftok/Json.hs at line 187

[2.2314]→[2.2314:2392](∅→∅)

parseA id = fail . show $ "Amendment type " <> id <> " not recognized."

[2.2314]

[2.2392]

parseA tid = fail . show $ "Amendment type " <> tid <> " not recognized."
replacement in lib/Aftok/Json.hs at line 190

[2.2428]→[2.2428:2456](∅→∅)

parseEventAmendmentV1 t x =

[2.2428]

[2.2456]

parseEventAmendmentV1 _ x =
replacement in lib/Aftok/Json.hs at line 199

[2.2870]→[2.2870:2948](∅→∅)

parseA id = fail . show $ "Amendment type " <> id <> " not recognized."

[2.2870]

[2.2948]

parseA tid = fail . show $ "Amendment type " <> tid <> " not recognized."
replacement in lib/Aftok/Json.hs at line 202

[2.2984]→[2.2984:3012](∅→∅)

parseEventAmendmentV2 t x =

[2.2984]

[2.3012]

parseEventAmendmentV2 _ x =
replacement in lib/Aftok/Json.hs at line 212

[2.3322]→[2.3322:3376](∅→∅)

Version 1 0 -> withObject "BtcAddr" parseCreditToV1

[2.3322]

[2.3376]

Version 1 0 -> withObject "BtcAddr" parseCreditToV1
edit in lib/Aftok/Json.hs at line 215

[2.3478]

[2.3478]

parseUUID :: Value -> Parser U.UUID
parseUUID v = do
str <- parseJSON v
maybe (fail $ "Value " <> str <> "Could not be parsed as a valid UUID.") pure $ U.fromString str
replacement in lib/Aftok/Json.hs at line 229

[2.3825]→[2.3825:3862](∅→∅)

parseCreditToAddr x' = Nothing

[2.3825]

[2.3862]

parseCreditToAddr _ = Nothing
replacement in lib/Aftok/Json.hs at line 231

[2.3863]→[2.3863:3946](∅→∅)

parseCreditToUser (Object x') = Nothing
parseCreditToUser x' = Nothing

[2.3863]

[2.3946]

parseCreditToUser (Object x') = do
userText <- O.lookup "creditToUser" x'
pure (CreditToUser . UserId <$> parseUUID userText)
parseCreditToUser _ = Nothing
replacement in lib/Aftok/Json.hs at line 236

[2.3947]→[2.3947:4036](∅→∅)

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

[2.3947]

[2.4036]

--parseCreditToProject (Object x') = Nothing
parseCreditToProject _ = Nothing
replacement in lib/Aftok/TimeLog.hs at line 6

[2.4399]→[2.4399:4467](∅→∅)

, CreditTo(..), _CreditToAddress, _CreditToUser, _CreditToProject

[2.4399]

[2.4467]

, CreditTo(..), _CreditToAddress, _CreditToUser, _CreditToProject, creditToName
edit in lib/Aftok/TimeLog.hs at line 68

[21.432]

[4.4696]

creditToName :: CreditTo -> Text
creditToName (CreditToAddress _) = "credit_to_address"
creditToName (CreditToUser _) = "credit_to_user"
creditToName (CreditToProject _) = "credit_to_project"
replacement in migrations/2016-10-14_02-49-36_event-amendments.txt at line 10

[3.2739]→[3.2739:2811](∅→∅)

alter table work_events rename column btc_addr to credit_to_btc_addr;

[3.2739]

[3.2811]

alter table work_events rename column btc_addr to credit_to_address;