Enabling logging of time to contributor/project accounts

[?]

Jun 19, 2016, 9:20 PM

POX3UAMTGCNS3SU5I6IKDNCCSHEAUSFBZ3WCMQ3EXKPNXETOI6BAC

Dependencies

[2] 373LXH2X Add MAYBE.md, update task list.
[3] ASF3UPJL Add auction creation and bid handlers
[4] Z7KS5XHH Very WIP. Wow.
[5] 7HPY3QPF Fix linting errors. (yay hlint!)
[6] N4NDAZYT Initial implementation of payouts.
[7] KNSI575V Cleanup of EventLog types.
[8] NEDDHXUK Reformat via stylish-haskell
[9] 7DBNV3GV Initial, stack-based impl of time log event reduction.
[10] AVDFWICB More musings for the TASKS file.
[11] 5DRIWGLU Improving TimeLog specs
[12] W35DDBFY Factor common JSON conversions up into client lib module.
[13] EZQG2APB Update task list.
[14] NVOCQVAS Initial failing tests.
[15] 7XN3I3QJ Add 'loggedIntervals' endpoint.
[16] 4U7F3CPI THE GREAT RENAMING OF THINGS!
[17] Y35QCWYW Minor improvement in WorkIndex type to eliminate duplicated information.
[18] GKGVYBZG Added JSON serialization to TimeLog
[19] MGOF7IUF Update TASKS list to reflect completed projects.
[20] GCVQD44V Create amends endpoint, switch to UUID primary keys
[21] SLL7262C Make depreciation functions more flexible.
[22] HALRDT2F Added initial auction create route.
[23] RPAJLHMT Change to use UUIDs instead of ints for primary keys.
[24] NLZ3JXLO Fix formatting with stylish-haskell.
[25] QMRKFEPG Refactor QDB to use a free monad algebra instead.
[26] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[27] A6HKMINB Attempting to improve JSON handling.
[28] SCXG6TJW Make log reduction safer in presence of overlapping events.
[29] OV5AKJHA Remove unused LogInterval type.
[30] O5FVTOM6 Undo JSON silliness, enable a couple more routes.
[31] TLQ72DSJ Lenses, sqlite-simple
[*] 2XQD6KKK Add invitation logic and clean up DBProg error handling.
[*] 7KZP4RHZ Switch from Data.Time to Data.Thyme

Change contents

edit in TASKS.md at line 26

[4.79]

[4.1518]

* Events
* User-identified events
- Associate events with user identifier as well as BTC address, and add
late resolution of BTC addresses at point of payout calculation.
replacement in TASKS.md at line 35

[4.1860]→[4.1860:1952](∅→∅)

* Payouts should not include events younger than <commit_delay hours> to permit amends.

[4.1860]

[4.1952]

* Payouts should not include events younger than <commit_delay hours> to permit amends.
replacement in TASKS.md at line 41

[2.1816]→[4.2054:2140](∅→∅),[4.2054]→[4.2054:2140](∅→∅)

* Include hours won in resource auction - requires confirmation that contribution

[2.1816]

[4.2140]

* Include hours won in resource auction - requires confirmation that contribution - Kris wip
edit in TASKS.md at line 43

[4.2203]

[4.2203]

* Ensure that we avoid creating dust transactions on the blockchain. Any payout fragment
falling below the estimated cost of redemption should be instead deducted from the
cost to the purchaser?
replacement in TASKS.md at line 56

[4.2512]→[4.228:248](∅→∅)

Webserver
---------

[4.2512]

[4.1]

Server
------
replacement in TASKS.md at line 68

[4.2758]→[4.249:281](∅→∅)

Payouts Service
---------------

[4.2758]

[4.281]

Scheduled event Service
-----------------------
replacement in TASKS.md at line 71

[4.282]→[4.2775:2808](∅→∅),[4.2775]→[4.2775:2808](∅→∅),[4.2836]→[4.2836:2875](∅→∅)

* Read blockchain transactions
* Payout Address Update validation

[4.282]

[4.2940]

* Based on blockchain transactions:
edit in aftok.cabal at line 64

[33.1051]

[34.2887]

, unordered-containers
edit in lib/Aftok/Json.hs at line 16

[4.1270]

[4.231]

import Data.HashMap.Strict as O
edit in lib/Aftok/Json.hs at line 75

[4.4903]

[4.4903]

v2 :: Value -> Value
v2 = versioned $ Version 2 0
replacement in lib/Aftok/Json.hs at line 80

[4.4963]→[4.4963:4979](∅→∅),[4.4979]→[4.1605:1631](∅→∅),[4.1631]→[4.5006:5114](∅→∅),[4.5006]→[4.5006:5114](∅→∅)

unv1 name f v =
let p (Version 1 0) = f
p ver = const . fail $ "Unrecognized " <> name <> " schema version: " <> show ver
in unversion p v

[4.4963]

[4.5114]

unv1 name f = unversion $ \x -> case x of
Version 1 0 -> f
_ -> badVersion name x

badVersion :: String -> Version -> Value -> Parser a
badVersion name ver = const . fail $ "Unrecognized " <> name <> " schema version: " <> show ver
edit in lib/Aftok/Json.hs at line 123

[4.2561]

[3.580]

creditToJSON :: CreditTo -> Value
creditToJSON (CreditToAddress addr) = v2 $ object [ "creditToAddress" .= addr ]
creditToJSON (CreditToUser uid) = v2 $ object [ "creditToUser" .= (uid ^. _UserId) ]
creditToJSON (CreditToProject pid) = v2 $ object [ "creditToProject" .= projectIdJSON pid ]
replacement in lib/Aftok/Json.hs at line 130

[4.5372]→[4.5372:5410](∅→∅)

toJSON $ MS.mapKeys (^. _BtcAddr) m

[4.5372]

[4.1904]

toJSON $ (creditToJSON *** id) <$> MS.assocs m
replacement in lib/Aftok/Json.hs at line 132

[4.1905]→[4.1905:1941](∅→∅),[4.1941]→[4.5411:5449](∅→∅),[4.5449]→[4.1180:1264](∅→∅)

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

[4.1905]

[4.2061]

workIndexJSONV1 :: WorkIndex -> Value
workIndexJSONV1 (WorkIndex widx) = v1 $
toJSON $ (L.toList . fmap intervalJSON) <$>
MS.mapKeysMonotonic (^? (_CreditToAddress._BtcAddr)) widx
replacement in lib/Aftok/Json.hs at line 142

[4.1833]→[4.5520:5558](∅→∅),[4.5558]→[4.1867:1909](∅→∅),[4.1867]→[4.1867:1909](∅→∅)

logEntryJSON (LogEntry a ev m) = v1 $
object [ "btcAddr" .= (a ^. _BtcAddr)

[4.1833]

[4.1909]

logEntryJSON (LogEntry c ev m) = v2 $
object [ "creditTo" .= creditToJSON c
replacement in lib/Aftok/Json.hs at line 159

[4.5811]→[4.1697:1744](∅→∅)

Payouts . MS.mapKeys BtcAddr <$> parseJSON v

[4.5811]

[4.5859]

Payouts . MS.mapKeys (CreditToAddress . BtcAddr) <$> parseJSON v
replacement in lib/Aftok/Json.hs at line 162

[4.5925]→[4.1745:1769](∅→∅),[4.1769]→[4.5950:6047](∅→∅),[4.5950]→[4.5950:6047](∅→∅),[4.6047]→[4.1770:1919](∅→∅),[4.1919]→[4.6202:6236](∅→∅),[4.6202]→[4.6202:6236](∅→∅),[4.6236]→[4.1920:1954](∅→∅),[4.1954]→[4.6271:6317](∅→∅),[4.6271]→[4.6271:6317](∅→∅),[4.6317]→[4.1955:1978](∅→∅),[4.1978]→[4.6341:6406](∅→∅),[4.6341]→[4.6341:6406](∅→∅)

parseEventAmendment t =
let parseA x "timeChange" = TimeChange t <$> x .: "eventTime"
parseA x "addrChage" = do
addrText <- x .: "btcAddr"
maybe
(fail $ show addrText <> "is not a valid BTC address")
(pure . AddressChange t)
$ parseBtcAddr addrText
parseA x "metadataChange" =
MetadataChange t <$> x .: "eventMeta"
parseA _ other =
fail $ "Amendment value " <> other <> " not recognized."

[4.5925]

[4.6406]

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

parseEventAmendmentV1 :: ModTime -> Value -> Parser EventAmendment
parseEventAmendmentV1 t v@(Object x) =
let parseA :: Text -> Parser EventAmendment
parseA "timeChange" = TimeChange t <$> x .: "eventTime"
parseA "addrChange" = CreditToChange t <$> parseCreditTo v
parseA "metadataChange" = MetadataChange t <$> x .: "eventMeta"
parseA id = fail . show $ "Amendment type " <> id <> " not recognized."
in x .: "amendment" >>= parseA

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

parseEventAmendmentV2 :: ModTime -> Value -> Parser EventAmendment
parseEventAmendmentV2 t v@(Object x) =
let parseA :: Text -> Parser EventAmendment
parseA "timeChange" = TimeChange t <$> x .: "eventTime"
parseA "creditToChange" = CreditToChange t <$> parseCreditTo v
parseA "metadataChange" = MetadataChange t <$> x .: "eventMeta"
parseA id = fail . show $ "Amendment type " <> id <> " not recognized."
in x .: "amendment" >>= parseA

parseEventAmendmentV2 t x =
fail $ "Value " <> show x <> " is not a JSON object."

parseBtcAddrJson :: Value -> Parser BtcAddr
parseBtcAddrJson v = do
t <- parseJSON v
maybe (fail $ show t <> " is not a valid BTC address") pure $ parseBtcAddr t
replacement in lib/Aftok/Json.hs at line 196

[4.6407]→[4.6407:6529](∅→∅),[4.6529]→[4.1979:2003](∅→∅)

p (Object x) = x .: "amendment" >>= parseA x
p x = fail $ "Value " <> show x <> " missing 'amendment' field."
in unv1 "amendment" p

[4.6407]

[4.6554]

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

parseCreditToV1 :: Object -> Parser CreditTo
parseCreditToV1 x = CreditToAddress <$> (parseBtcAddrJson =<< (x .: "btcAddr"))
edit in lib/Aftok/Json.hs at line 205

[4.6555]

parseCreditToV2 :: Object -> Parser CreditTo
parseCreditToV2 x =
let parseCreditToAddr (Object x') = do
addrText <- O.lookup "creditToAddress" x'
pure (CreditToAddress <$> parseBtcAddrJson addrText)
parseCreditToAddr x' = Nothing

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

parseCreditToProject (Object x') = Nothing
parseCreditToProject x' = 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/Project.hs at line 15

[4.1382]→[4.1382:1437](∅→∅)

newtype ProjectId = ProjectId UUID deriving (Show, Eq)

[4.1382]

[4.1437]

newtype ProjectId = ProjectId UUID deriving (Show, Eq, Ord)
replacement in lib/Aftok/TimeLog.hs at line 5

[4.1805]→[4.907:924](∅→∅),[4.4159]→[4.907:924](∅→∅),[4.5325]→[4.907:924](∅→∅),[4.907]→[4.907:924](∅→∅),[4.924]→[4.1083:1130](∅→∅),[4.1130]→[4.2033:2069](∅→∅)

( LogEntry(..)
, btcAddr, event, eventMeta
, LogEvent(..)
, eventName, nameEvent, eventTime

[4.4159]

[4.2136]

( LogEntry(..), creditTo, event, eventMeta
, CreditTo(..), _CreditToAddress, _CreditToUser, _CreditToProject
, LogEvent(..), eventName, nameEvent, eventTime
edit in lib/Aftok/TimeLog.hs at line 36

[4.4695]

[4.1224]

import Aftok.Project (ProjectId)
edit in lib/Aftok/TimeLog.hs at line 57

[4.3954]

[4.431]

data CreditTo
-- payouts are made directly to this address, or to an address replacing this one
= CreditToAddress BtcAddr
-- payouts are distributed as requested by the specified contributor
| CreditToUser UserId
-- payouts are distributed to this project's contributors
| CreditToProject ProjectId
deriving (Show, Eq, Ord)
makePrisms ''CreditTo
replacement in lib/Aftok/TimeLog.hs at line 69

[4.4721]→[4.4721:4747](∅→∅)

{ _btcAddr :: BtcAddr

[4.4721]

[4.4747]

{ _creditTo :: CreditTo
replacement in lib/Aftok/TimeLog.hs at line 77

[4.4791]→[4.1817:1865](∅→∅),[4.259]→[4.1817:1865](∅→∅)

let ordElems e = (e ^. event, e ^. btcAddr)

[4.4791]

[4.343]

let ordElems e = (e ^. event, e ^. creditTo)
replacement in lib/Aftok/TimeLog.hs at line 87

[4.6772]→[4.6772:6824](∅→∅)

| AddressChange ModTime BtcAddr

[4.6772]

[4.6824]

| CreditToChange ModTime CreditTo
replacement in lib/Aftok/TimeLog.hs at line 93

[4.2287]→[4.5972:6021](∅→∅)

newtype Payouts = Payouts (Map BtcAddr Rational)

[4.5971]

[4.6021]

newtype Payouts = Payouts (Map CreditTo Rational)
replacement in lib/Aftok/TimeLog.hs at line 96

[4.6562]→[4.384:468](∅→∅)

newtype WorkIndex = WorkIndex (Map BtcAddr (NonEmpty Interval)) deriving (Show, Eq)

[4.6043]

[4.468]

newtype WorkIndex = WorkIndex (Map CreditTo (NonEmpty Interval)) deriving (Show, Eq)
replacement in lib/Aftok/TimeLog.hs at line 148

[4.2114]→[4.2114:2169](∅→∅)

type RawIndex = Map BtcAddr [Either LogEvent Interval]

[4.2114]

[4.2169]

type RawIndex = Map CreditTo [Either LogEvent Interval]
replacement in lib/Aftok.hs at line 27

[4.10878]→[4.2221:2270](∅→∅),[4.2764]→[4.2221:2270](∅→∅)

newtype UserId = UserId UUID deriving (Show, Eq)

[4.10878]

[4.2771]

newtype UserId = UserId UUID deriving (Show, Eq, Ord)