Initial work on payments API

[?]

Dec 21, 2016, 5:23 AM

DFOBMSAODB3NKW37B272ZXA2ML5HMIH3N3C4GT2DPEQS7ZFK4SNAC

Dependencies

[2] NAS4BFL4 Trivial stylish-haskell reformat.
[3] M4KM76DG Merge branch 'stackify'
[4] EZQG2APB Update task list.
[5] 2XQD6KKK Add invitation logic and clean up DBProg error handling.
[6] BXGLKYRX Added primitive user registration handler.
[7] RN7EI6IN Update database layer to use CreditTo
[8] FXJQACES Ensure that auction is not ended at the time of bid
[9] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[10] RB2ETNIF Add skeletal PureScript client project.
[11] POX3UAMT Enabling logging of time to contributor/project accounts
[12] A6HKMINB Attempting to improve JSON handling.
[13] 2Y2QZFVF Switch to more modern cabal2nix-based workflow.
[14] EKY7U7SK Finish conversion to stack.
[15] NVOCQVAS Initial failing tests.
[16] DLZRD7VB Add a preliminary, probably somewhat broken set of setup instructions.
[17] KEP5WUFJ Convert project to stack-based build.
[18] T44T2PDL Rename trust.txt to README.md
[19] E2KOBKIJ Add setup script detailing the setup of the docker host.
[20] 5W5M56VJ Move library code to 'lib'
[21] O5FVTOM6 Undo JSON silliness, enable a couple more routes.
[22] OBFPJS2G Project successfully builds and tests under nix.
[23] Z3MK2PJ5 Add GET handler for retrieving auction data.
[24] EQXRXRZD Changed to use tasty instead of test-framework
[25] Y35QCWYW Minor improvement in WorkIndex type to eliminate duplicated information.
[26] 45AI46JN Move readme to inception.md
[27] 373LXH2X Add MAYBE.md, update task list.
[28] HALRDT2F Added initial auction create route.
[29] IZEVQF62 Work in progress replacing sqlite with postgres.
[30] RSEB2NFG Replacing Snap with Scotty.
[31] 4ZLEDBK7 Initial attempts at dockerizing, cabal isn't cooperating.
[32] ADMKQQGC Initial empty Snap project.
[33] NTPC7KJE Trivial changes, feature scratchpad.
[34] LAROLAYU WIP
[35] PBD7LZYQ Postgres & auth are beginning to function.
[36] NEDDHXUK Reformat via stylish-haskell
[37] LEINLS3X Update deployment documentation.
[38] IRG4KNAE Trivial deletion.
[39] TNR3TEHK Switch to Postgres + snaplet arch compiles.
[40] 5OI44E4E Add authentication to auction search.
[41] 4U7F3CPI THE GREAT RENAMING OF THINGS!
[42] WO2MINIF Auctions now compile!
[43] EKI57EJR Add alternative implementation of auction winner determination.
[44] 75N3UJ4J More progression toward lenses.
[45] EPOYLP7O A little .gitignore cleanup.
[46] AXKKXBWN Initial attempt at writing down my ideas for a company based on trust.
[47] 2WOOGXDH Use dbmigrations to manage database state.
[48] 7DBNV3GV Initial, stack-based impl of time log event reduction.
[49] 7VGYLTMU Clean up schema version handling.
[50] 45QJYWN3 Fixing up the README. Still struggling with the ending.
[51] ZP62WC47 Begin conversion to build with stack.
[52] QMRKFEPG Refactor QDB to use a free monad algebra instead.
[53] QO4NFWIY Added sample config file.
[54] 3QVT6MA6 Add database support for event amend operations.
[55] Z7KS5XHH Very WIP. Wow.
[56] ASF3UPJL Add auction creation and bid handlers
[57] GCVQD44V Create amends endpoint, switch to UUID primary keys
[*] BROSTG5K Beginning of modularization of server.
[*] WZUHEZSB Start of migration back toward snap.
[*] NLZ3JXLO Fix formatting with stylish-haskell.
[*] W35DDBFY Factor common JSON conversions up into client lib module.
[*] BWN72T44 Don't accept work timestamp from an external source.

Change contents

file deletion: .ghci (----------)

[3.2]→[3.104:133](∅→∅),[3.133]→[3.1:1](∅→∅)

:set -isrc
:set -hide-package MonadCatchIO-mtl
:set -hide-package monads-fd
:set -XOverloadedStrings
replacement in TASKS.md at line 28

[3.41]→[3.41:193](∅→∅)

- Associate events with user identifier as well as BTC address, and add
late resolution of BTC addresses at point of payout calculation.

[3.41]

[3.1518]

- add late resolution of BTC addresses at point of payout calculation.
edit in aftok.cabal at line 22

[59.164]

[3.139]

, KindSignatures
edit in aftok.cabal at line 25

[3.203]

[3.203]

Aftok.Billables
edit in aftok.cabal at line 31

[3.393]

[3.1]

Aftok.Payments
edit in aftok.cabal at line 33

[3.37]

[3.393]

Aftok.Time
edit in aftok.cabal at line 40

[3.280]

[3.280]

, bippy == 0.1.0.0
replacement in aftok.cabal at line 42

[3.316]→[3.15:50](∅→∅)

, aeson == 0.9.*

[3.316]

[3.50]

, aeson >= 0.11.2
edit in aftok.cabal at line 54

[3.589]

[3.589]

, haskoin-core >= 0.4
replacement in aftok.cabal at line 62

[3.815]→[3.207:242](∅→∅)

, postgresql-simple == 0.5.*

[3.815]

[3.862]

, postgresql-simple >= 0.5.2.0
edit in aftok.cabal at line 84

[59.325]

[3.2112]

, KindSignatures
edit in aftok.cabal at line 113

[59.486]

[3.1833]

, KindSignatures
edit in aftok.cabal at line 116

[3.1863]

[60.33]

other-modules: Aftok.QConfig
, Aftok.Snaplet
, Aftok.Snaplet.Auctions
, Aftok.Snaplet.Auth
, Aftok.Snaplet.Projects
, Aftok.Snaplet.Users
, Aftok.Snaplet.Util
, Aftok.Snaplet.WorkLog
edit in aftok.cabal at line 133

[59.504]

[3.1144]

, bippy
file addition: Billables.hs (----------)

[3.679]

{-# LANGUAGE TemplateHaskell #-}

module Aftok.Billables where

import ClassyPrelude

import Control.Lens (makeLenses)

import Data.UUID
import Aftok.Time (Days(..))

newtype BillableId = BillableId UUID deriving (Show, Eq)

data BillingFrequency
= Annually
| Monthly Int
| SemiMonthly
| Weekly Int
makeLenses ''BillingFrequency

data Recurrence
= Recurring { _frequency :: BillingFrequency }
| OneTime
makeLenses ''Recurrence

data Billable (p :: *) (c :: *) = Billable
{ _project :: p
, _name :: Text
, _description :: Text
, _recurrence :: Recurrence
, _amount :: c
, _gracePeriod :: Days
}
makeLenses ''Billable

monthly :: BillingFrequency
monthly = Monthly 1

bimonthly :: BillingFrequency
bimonthly = Monthly 2

quarterly :: BillingFrequency
quarterly = Monthly 3

seminannually :: BillingFrequency
seminannually = Monthly 6

annually :: BillingFrequency
annually = Annually
replacement in lib/Aftok/Database/PostgreSQL.hs at line 17

[3.1453]→[3.1453:1507](∅→∅)

import Database.PostgreSQL.Simple.FromField

[3.1453]

[3.1507]

import Database.PostgreSQL.Simple.FromField
edit in lib/Aftok/Database/PostgreSQL.hs at line 20

[3.65]

[3.1011]

import Network.Haskoin.Crypto (addrToBase58)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 56

[3.1499]→[3.1499:1545](∅→∅)

btcAddrParser f v = BtcAddr <$> fromField f v

[3.1499]

[3.1545]

btcAddrParser f v = do
addrMay <- parseBtcAddr <$> fromField f v
let err = ConversionFailed { errSQLType = "text"
, errSQLTableOid = tableOid f
, errSQLField = maybe "" B.unpack (name f)
, errHaskellType = "BtcAddr"
, errMessage = "could not deserialize value to a valid BTC address"
}
maybe (conversionError err) pure addrMay
replacement in lib/Aftok/Database/PostgreSQL.hs at line 80

[3.243]→[3.243:533](∅→∅)

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"

[3.243]

[3.533]

let err = UnexpectedNull { errSQLType = B.unpack tn
, errSQLTableOid = tableOid f
, errSQLField = maybe "" B.unpack (name f)
, errHaskellType = "UTCTime -> LogEvent"
, errMessage = "columns of type event_t should not contain null values"
}
replacement in lib/Aftok/Database/PostgreSQL.hs at line 88

[3.607]→[3.607:863](∅→∅)

let err = Incompatible (B.unpack tn)
(tableOid f)
(maybe "" B.unpack (name f))
"UTCTime -> LogEvent"
"column was not of type event_t"

[3.607]

[3.863]

let err = Incompatible { errSQLType = B.unpack tn
, errSQLTableOid = tableOid f
, errSQLField = maybe "" B.unpack (name f)
, errHaskellType = "UTCTime -> LogEvent"
, errMessage = "column was not of type event_t"
}
replacement in lib/Aftok/Database/PostgreSQL.hs at line 149

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

<*> fieldWith btcAddrParser

[3.958]

[3.2210]

<*> fieldWith (optionalField btcAddrParser)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 207

[3.341]→[3.1886:1986](∅→∅)

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

[3.341]

[3.425]

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

[3.1532]→[3.2822:2902](∅→∅)

( eid, fromThyme $ mt ^. _ModTime, creditToName c, addr ^. _BtcAddr )

[3.1532]

[3.2903]

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

[3.492]→[3.492:536](∅→∅)

, auc ^. (raiseAmount.to fromSatoshi)

[3.492]

[3.536]

, auc ^. (raiseAmount . satoshi)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 314

[3.3733]→[3.761:803](∅→∅)

, bid ^. (bidAmount.to fromSatoshi)

[3.3733]

[3.3080]

, bid ^. (bidAmount . satoshi)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 324

[3.3322]→[3.4008:4027](∅→∅),[3.4008]→[3.4008:4027](∅→∅)

pinsert UserId

[3.3322]

[3.4027]

let addrMay :: Maybe ByteString
addrMay = user' ^? (userAddress . traverse . _BtcAddr . to addrToBase58)
in pinsert UserId
replacement in lib/Aftok/Database/PostgreSQL.hs at line 328

[3.4109]→[3.3119:3217](∅→∅)

(user' ^. (username._UserName), user' ^. (userAddress._BtcAddr), user' ^. userEmail._Email)

[3.4109]

[3.704]

( user' ^. (username._UserName)
, addrMay
, user' ^. userEmail._Email
)
edit in lib/Aftok/Database/PostgreSQL.hs at line 391

[3.5684]

[3.1044]

dbEval (CreateBillable _) = error "Not implemented"
dbEval (ReadBillable _) = error "Not implemented"
dbEval (CreatePaymentRequest _ _) = error "Not implemented"
dbEval (CreatePayment _ ) = error "Not implemented"
edit in lib/Aftok/Database/PostgreSQL.hs at line 399

[3.4454]
edit in lib/Aftok/Database.hs at line 14

[2.800]

[61.301]

import Aftok.Billables as B
edit in lib/Aftok/Database.hs at line 16

[61.333]

[2.801]

import Aftok.Payments
edit in lib/Aftok/Database.hs at line 19

[61.364]

[61.364]

import Aftok.Types
edit in lib/Aftok/Database.hs at line 53

[3.7074]

[3.7074]

CreateBillable :: Billable ProjectId Satoshi -> DBOp BillableId
ReadBillable :: BillableId -> DBOp (Maybe (Billable ProjectId Satoshi))

CreatePaymentRequest :: UserId -> PaymentRequest ProjectId BillableId -> DBOp PaymentRequestId
CreatePayment :: Payment PaymentRequestId UserId -> DBOp PaymentId
edit in lib/Aftok/Database.hs at line 172

[3.9333]

[3.833]

-- Billing ops
edit in lib/Aftok/Database.hs at line 175

[3.834]

[3.834]

createBillable :: UserId -> Billable ProjectId Satoshi -> DBProg BillableId
createBillable uid b = withProjectAuth (b ^. B.project) uid $ CreateBillable b

readBillable :: BillableId -> DBProg (Maybe (Billable ProjectId Satoshi))
readBillable = fc . ReadBillable

--createPaymentRequest :: BillableId -> DBProg PaymentRequestId
--createPaymentRequest bid = do
-- billable <- readBillable bid

readPaymentHistory :: UserId -> DBProg [Payment PaymentRequestId UserId]
readPaymentHistory = error "Not yet implemented"
replacement in lib/Aftok/Database.hs at line 211

[3.22]→[3.22:80](∅→∅)

createBid :: AuctionId -> UserId -> Bid -> DBProg (BidId)

[3.22]

[2.888]

createBid :: AuctionId -> UserId -> Bid -> DBProg BidId
edit in lib/Aftok/Json.hs at line 18

[61.1270]

[63.3]

import qualified Data.Text as T
edit in lib/Aftok/Json.hs at line 29

[3.201]

[62.272]

import Aftok.Util (traverseKeys)
replacement in lib/Aftok/Json.hs at line 121

[3.1694]→[3.1694:1750](∅→∅)

, "raiseAmount" .= (x ^. (raiseAmount._Satoshi))

[3.1694]

[3.1750]

, "raiseAmount" .= (x ^. (raiseAmount . satoshi))
replacement in lib/Aftok/Json.hs at line 179

[2.1191]→[3.2642:2722](∅→∅),[3.2642]→[3.2642:2722](∅→∅)

parseCreditToV1 x = CreditToAddress <$> (parseBtcAddrJson =<< (x .: "btcAddr"))

[2.1191]

[3.2722]

parseCreditToV1 x = CreditToAddress <$> (parseJSON =<< (x .: "btcAddr"))
replacement in lib/Aftok/Json.hs at line 184

[2.1241]→[3.2819:2901](∅→∅),[3.2819]→[3.2819:2901](∅→∅)

fmap CreditToAddress . parseBtcAddrJson <$> O.lookup "creditToAddress" o'

[2.1241]

[3.2901]

fmap CreditToAddress . parseJSON <$> O.lookup "creditToAddress" o'
replacement in lib/Aftok/Json.hs at line 200

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

p (Version 1 _) v = Payouts . MS.mapKeys (CreditToAddress . BtcAddr) <$> parseJSON (Object v)

[3.3443]

[2.1305]

p (Version 1 _) v =
let parseKey :: String -> Parser CreditTo
parseKey k = maybe
(fail $ "Key " <> k <> " cannot be parsed as a valid BTC address.")
(pure . CreditToAddress)
(parseBtcAddr $ T.pack k)
in Payouts <$> join (traverseKeys parseKey <$> parseJSON (Object v))
replacement in lib/Aftok/Json.hs at line 211

[3.3752]→[3.3752:3791](∅→∅)

p ver x = badVersion "Payouts" ver x

[3.3752]

[3.5859]

p ver x =
badVersion "Payouts" ver x
edit in lib/Aftok/Json.hs at line 238

[2.1397]→[3.2983:2984](∅→∅),[3.4673]→[3.2983:2984](∅→∅),[3.2983]→[3.2983:2984](∅→∅),[3.3069]→[3.3069:3235](∅→∅)

parseBtcAddrJson :: Value -> Parser BtcAddr
parseBtcAddrJson v = do
t <- parseJSON v
maybe (fail $ show t <> " is not a valid BTC address") pure $ parseBtcAddr t
file addition: Payments.hs (----------)

[3.679]

{-# LANGUAGE TemplateHaskell #-}

module Aftok.Payments where

import ClassyPrelude

import Control.Lens (makeLenses)

import Data.Thyme.Clock as C
import Data.UUID

import qualified Network.Bippy.Proto as P

newtype PaymentRequestId = PaymentRequestId UUID deriving (Show, Eq)

newtype PaymentId = PaymentId UUID deriving (Show, Eq)

data PaymentRequest (p :: *) (b :: *) = PaymentRequest
{ _project :: p
, _paymentRequest :: P.PaymentRequest
, _paymentRequestDate :: C.UTCTime
, _billable :: b
}
makeLenses ''PaymentRequest

data Payment r u = Payment
{ _request :: r
, _payment :: P.Payment
, _paymentDate :: C.UTCTime
, _payor :: u
}
makeLenses ''Payment
edit in lib/Aftok/Project.hs at line 8

[3.1198]

[3.1198]
edit in lib/Aftok/Project.hs at line 12

[3.1325]

[3.1325]
file addition: Time.hs (----------)

[3.679]

module Aftok.Time where

import ClassyPrelude

newtype Days = Days Int
replacement in lib/Aftok/Types.hs at line 4

[3.851]→[3.851:876](∅→∅)

module Aftok.Types where

[3.851]

[3.876]

module Aftok.Types (Satoshi(..), satoshi) where
edit in lib/Aftok/Types.hs at line 8

[3.848]

[3.915]

import Network.Bippy.Types (Satoshi(..))
replacement in lib/Aftok/Types.hs at line 10

[3.916]→[3.916:1031](∅→∅),[3.1031]→[3.849:870](∅→∅)

newtype Satoshi = Satoshi { fromSatoshi :: Word64 }
deriving (Show, Eq, Ord, Num, Real, Bounded)
makePrisms ''Satoshi

[3.916]

[3.1036]

satoshi :: Lens' Satoshi Word64
satoshi inj (Satoshi value) = Satoshi <$> inj value
edit in lib/Aftok/Types.hs at line 13

[3.1037]→[3.5321:5322](∅→∅)
edit in lib/Aftok/Util.hs at line 8

[3.5676]

[3.10199]

import Data.Map.Strict as M
edit in lib/Aftok/Util.hs at line 20

[3.10494]

traverseKeys :: (Ord k, Applicative f) => (a -> f k) -> Map a b -> f (Map k b)
traverseKeys f m =
let insf a b m' = flip insert b <$> f a <*> m'
in foldrWithKey insf (pure M.empty) m
replacement in lib/Aftok.hs at line 15

[3.2593]→[3.4149:4205](∅→∅)

newtype BtcAddr = BtcAddr Text deriving (Show, Eq, Ord)

[3.2593]

[3.4205]

import Network.Haskoin.Crypto (Address(..), base58ToAddr)

newtype BtcAddr = BtcAddr Address deriving (Show, Eq, Ord)
replacement in lib/Aftok.hs at line 21

[3.2130]→[3.4227:4286](∅→∅)

parseBtcAddr = Just . BtcAddr -- FIXME: perform validation

[3.2130]

[3.10705]

parseBtcAddr addr = BtcAddr <$> (base58ToAddr . encodeUtf8) addr

instance FromJSON BtcAddr where
parseJSON v = do
t <- parseJSON v
maybe (fail $ show t <> " is not a valid BTC address") pure $ parseBtcAddr t
replacement in lib/Aftok.hs at line 45

[3.6217]→[3.2911:2939](∅→∅),[3.2911]→[3.2911:2939](∅→∅)

, _userAddress :: BtcAddr

[3.6217]

[3.6218]

, _userAddress :: Maybe BtcAddr
replacement in migrations/2016-10-13_05-36-55_user-event-log.txt at line 5

[3.187]→[3.187:233](∅→∅)

create extension if not exists "uuid-ossp";

[3.187]

[3.233]

--create extension if not exists "uuid-ossp";
file addition: 2016-12-31_03-45-17_create-payments.txt (----------)

[3.1]

Description: Create tables for persistence of billable & payments data.
Created: 2016-12-31 03:45:38.125915 UTC
Depends: 2016-10-13_05-36-55_user-event-log
Apply: |
create type aftok_event_t as enum(
'create_user',
'create_project',
'add_user_to_project',
'create_invitation',
'accept_invitation',
'create_event',
'amend_event',
'create_auction',
'create_bid',
'create_billable',
'create_payment_request',
'create_payment'
);

-- a log of raw events - the current state of the database
-- should be reproducible by replaying the entire history of
-- events
create table if not exists aftok_events (
id uuid primary key default uuid_generate_v4(),
event_time timestamp with time zone not null,
event_type aftok_event_t not null,
event_json json not null
);

create type recurrence_t as enum ('onetime', 'weekly', 'semimonthly', 'monthly', 'annually');

create table if not exists billables (
id uuid primary key default uuid_generate_v4(),
project_id uuid not null references projects(id),
event_id uuid not null references aftok_events(id),
name text not null,
description text,
recurrence_type recurrence_t not null,
recurrence_count int,
billing_amount numeric not null,
grace_period_days int not null
);

create table if not exists subscriptions (
id uuid primary key default uuid_generate_v4(),
user_id uuid not null references users(id),
billable_id uuid not null references billables(id),
event_id uuid not null references aftok_events(id)
);

create table if not exists payment_requests (
id uuid primary key default uuid_generate_v4(),
subscription_id uuid not null references subscriptions(id),
event_id uuid not null references aftok_events(id),
request_data bytea not null
);

create table if not exists payments (
id uuid primary key default uuid_generate_v4(),
payment_request_id uuid not null references payment_requests(id),
event_id uuid not null references aftok_events(id),
payment_data bytea not null
);

Revert: |
drop table payments;
drop table payment_requests;
drop table subscriptions;
drop table billables;
drop table aftok_events;
file addition: Payments.hs (----------)

[3.2082]

module Aftok.Snaplet.Payments where

import ClassyPrelude

import Network.Bippy
import Network.Bippy.Types

import Snap.Core
import Snap.Snaplet

requestPaymentHandler :: Handler App App
requestPaymentHandler = do
-- get payout percentages from payouts handler
uid <- requireUserId
pid <- requireProjectId
ptime <- liftIO $ C.getCurrentTime
payouts <- snapEval $ fc (ReadWorkIndex pid)
pure $ payouts (toDepF $ project ^. depf) ptime widx
-- look up the outstanding
undefined
replacement in server/Aftok/Snaplet/Users.hs at line 34

[3.9104]→[3.10475:10651](∅→∅),[3.435]→[3.10475:10651](∅→∅)

let parseUser = User <$> (UserName <$> v .: "username")
<*> (BtcAddr <$> v .: "btcAddr")
<*> (Email <$> v .: "email")

[3.9104]

[3.10651]

let parseUser = User <$> (UserName <$> v .: "username")
<*> (parseBtcAddr <$> v .: "btcAddr")
<*> (Email <$> v .: "email")
replacement in stack.yaml at line 4

[3.1101]→[3.1101:1150](∅→∅)

extra-deps:
- snaplet-postgresql-simple-0.6.0.4

[3.1101]

[3.1150]

- location:
git: git@github.com:aftok/bippy.git
commit: 6284d5fff3954e0e52d559298364035a220867af
extra-dep: true
allow-newer: true
extra-deps:
- aeson-0.11.2.1
- base-orphans-0.5.4
- bytestring-builder-0.10.8.1.0
- call-stack-0.1.0
- haskoin-core-0.4.0
- hspec-2.3.2
- hspec-core-2.3.2
- hspec-discover-2.3.2
- hspec-expectations-0.8.2
- mmorph-1.0.9
- mono-traversable-0.10.2
- murmur3-1.0.1
- pbkdf-1.1.1.1
- postgresql-libpq-0.9.2.0
- postgresql-simple-0.5.2.1
edit in stack.yaml at line 26

[3.1182]

[3.1182]

- secp256k1-0.4.5
- snaplet-postgresql-simple-0.6.0.4
- unix-compat-0.4.3.1
- vector-th-unbox-0.2.1.6
edit in stack.yaml at line 31

[3.1200]→[3.1200:1219](∅→∅)

#allow-newer: true