Implement payment request creation functions.

[?]

Feb 20, 2017, 6:16 PM

SEWTRB6S5PO5MQBLCPVBD7XT2BDYNZUE2RO6Z2XENZRIOCN6OZJAC

Dependencies

[2] HMDM3B55 Implement core of payments/billing infrastructure.
[3] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[4] WAIX6AGN Add event serialization for PaymentRequest & Payment
[5] Q5X5RYQL stylish-haskell reformatting
[6] 4IQVQL4T Added client for payouts endpoint.
[7] 5XFJNUAZ Start of addition of project infrastructure.
[8] GCVQD44V Create amends endpoint, switch to UUID primary keys
[9] PBD7LZYQ Postgres & auth are beginning to function.
[10] NAS4BFL4 Trivial stylish-haskell reformat.
[11] NLZ3JXLO Fix formatting with stylish-haskell.
[12] TNR3TEHK Switch to Postgres + snaplet arch compiles.
[13] 2G3GNDDU Event logging is now functioning in postgres.
[14] WFZDMVUX Rename ADB -> QDB
[15] 73NDXDEZ Begin implementation of billing event persistence.
[16] 7HPY3QPF Fix linting errors. (yay hlint!)
[17] KEP5WUFJ Convert project to stack-based build.
[18] Z7KS5XHH Very WIP. Wow.
[19] 4U7F3CPI THE GREAT RENAMING OF THINGS!
[20] W35DDBFY Factor common JSON conversions up into client lib module.
[21] LD4GLVSF More database stuff.
[22] 2XQD6KKK Add invitation logic and clean up DBProg error handling.
[23] IZEVQF62 Work in progress replacing sqlite with postgres.
[24] DFOBMSAO Initial work on payments API
[25] Z3MK2PJ5 Add GET handler for retrieving auction data.
[26] NEDDHXUK Reformat via stylish-haskell
[27] 5OI44E4E Add authentication to auction search.
[28] Y3LIJ5US Add handler for CreatePaymentRequest
[29] QADKFHAR Adds CreatePayment handler implementation.
[30] O227CEAV Adds storage of original event JSON for some DBOp constructors.
[31] A6HKMINB Attempting to improve JSON handling.
[32] XTBSG4C7 Adding serveJSON combinator to eliminate some boilerplate from handlers.
[33] FD7SV5I6 Fix handling of event_t columns.
[34] O5FVTOM6 Undo JSON silliness, enable a couple more routes.
[35] HALRDT2F Added initial auction create route.
[36] EKY7U7SK Finish conversion to stack.
[37] QMRKFEPG Refactor QDB to use a free monad algebra instead.
[38] M4KM76DG Merge branch 'stackify'
[39] ZP62WC47 Begin conversion to build with stack.
[40] NTPC7KJE Trivial changes, feature scratchpad.
[*] BWN72T44 Don't accept work timestamp from an external source.
[*] RN7EI6IN Update database layer to use CreditTo

Change contents

edit in aftok.cabal at line 34

[3.37]→[3.195:228](∅→∅)

Aftok.Time
edit in aftok.cabal at line 72

[2.523]

[2.523]

, transformers
file deletion: Time.hs (----------)

[3.679]→[3.6557:6588](∅→∅),[3.6588]→[3.6473:6473](∅→∅)

{-# LANGUAGE TemplateHaskell #-}
module Aftok.Time where

import ClassyPrelude

newtype Days = Days Int
makePrisms ''Days

import Control.Lens (makePrisms)
replacement in lib/Aftok/Billables.hs at line 10

[3.857]→[3.3:59](∅→∅)

import Control.Lens (makeLenses, makePrisms)

[3.857]

[2.1017]

import Control.Lens (makeLenses, makePrisms, preview, view, _Just)
import Data.List (unfoldr)
import Data.Thyme.Time as T
edit in lib/Aftok/Billables.hs at line 18

[3.116]→[3.101:144](∅→∅)

import Aftok.Time (Days (..))
replacement in lib/Aftok/Billables.hs at line 25

[3.1077]→[3.1077:1109](∅→∅)

| Monthly Int
| SemiMonthly

[3.1077]

[3.1109]

| Monthly T.Months
-- | SemiMonthly
replacement in lib/Aftok/Billables.hs at line 34

[3.344]→[3.344:387](∅→∅)

recurrenceName SemiMonthly = "semimonthly"

[3.344]

[3.387]

--recurrenceName SemiMonthly = "semimonthly"
replacement in lib/Aftok/Billables.hs at line 41

[3.578]→[3.578:616](∅→∅)

recurrenceCount SemiMonthly = Nothing

[3.578]

[3.616]

--recurrenceCount SemiMonthly = Nothing
replacement in lib/Aftok/Billables.hs at line 68

[2.1289]→[2.1289:1342](∅→∅)

, _requestExpiryPeriod :: Maybe C.NominalDiffTime

[2.1289]

[2.1342]

, _requestExpiryPeriod :: Maybe C.NominalDiffTime
replacement in lib/Aftok/Billables.hs at line 77

[2.1424]→[2.1424:1461](∅→∅)

data Subscription' b = Subscription

[2.1424]

[2.1461]

data Subscription' b = Subscription
edit in lib/Aftok/Billables.hs at line 86

[2.1660]

nextRecurrence :: Recurrence -> T.Day -> Maybe T.Day
nextRecurrence r = case r of
Annually -> Just . T.addGregorianYearsClip 1
Monthly m -> Just . T.addGregorianMonthsClip m
Weekly w -> Just . T.addDays (w * 7)
OneTime -> const Nothing

{-
- A stream of dates upon which the specified subscription
- should be billed, beginning with the first day of the
- subscription.
-}
billingSchedule :: Subscription' Billable -> [T.Day]
billingSchedule s =
let rec = view (billable . recurrence) s
subEndDay = preview (endTime . _Just . C._utctDay) s

next :: Maybe T.Day -> Maybe (T.Day, Maybe T.Day)
next d = do
d' <- d
if (all (d' <) subEndDay) then Just (d', nextRecurrence rec d') else Nothing

in unfoldr next (Just $ view (startTime . C._utctDay) s)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 11

[3.1197]→[3.1197:1256](∅→∅),[3.1256]→[3.582:652](∅→∅)

import Data.List as L
import Data.ProtocolBuffers (encodeMessage)

[3.1197]

[3.109]

import qualified Data.List as L
import Data.ProtocolBuffers (encodeMessage, decodeMessage)
import Data.Serialize.Get (runGet)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 34

[3.124]→[3.173:205](∅→∅),[3.162]→[3.173:205](∅→∅),[3.1008]→[3.173:205](∅→∅),[2.1802]→[3.173:205](∅→∅),[3.1678]→[3.173:205](∅→∅)

import Aftok.Payments

[2.1802]

[3.1208]

import Aftok.Payments.Types
edit in lib/Aftok/Database/PostgreSQL.hs at line 36

[3.1267]→[3.1009:1082](∅→∅)

import Aftok.Time (Days (..), _Days)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 48

[3.1216]→[2.1803:1862](∅→∅),[2.1862]→[3.1373:1374](∅→∅),[3.1373]→[3.1373:1374](∅→∅),[3.1374]→[2.1863:1932](∅→∅)

uidParser :: RowParser UserId
uidParser = UserId <$> field

pidParser :: RowParser P.ProjectId
pidParser = P.ProjectId <$> field

[3.1216]

[3.1461]

idParser :: (UUID -> a) -> RowParser a
idParser f = f <$> field
edit in lib/Aftok/Database/PostgreSQL.hs at line 51

[3.1462]→[2.1933:2034](∅→∅),[2.2034]→[3.2103:2104](∅→∅),[3.2103]→[3.2103:2104](∅→∅)

subscriptionIdParser :: RowParser B.SubscriptionId
subscriptionIdParser = B.SubscriptionId <$> field
replacement in lib/Aftok/Database/PostgreSQL.hs at line 84

[3.2201]→[2.2418:2606](∅→∅)

parser "credit_to_user" = CreditToUser <$> (nullField *> uidParser <* nullField)
parser "credit_to_project" = CreditToProject <$> (nullField *> nullField *> pidParser)

[3.2201]

[3.2409]

parser "credit_to_user" = CreditToUser <$> (nullField *> idParser UserId <* nullField)
parser "credit_to_project" = CreditToProject <$> (nullField *> nullField *> idParser P.ProjectId)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 101

[3.1988]→[2.2665:2707](∅→∅)

(,,) <$> pidParser
<*> uidParser

[3.1988]

[3.95]

(,,) <$> idParser P.ProjectId
<*> idParser UserId
replacement in lib/Aftok/Database/PostgreSQL.hs at line 107

[3.2039]→[2.2708:2760](∅→∅)

A.Auction <$> pidParser
<*> uidParser

[3.2039]

[2.2760]

A.Auction <$> idParser P.ProjectId
<*> idParser UserId
replacement in lib/Aftok/Database/PostgreSQL.hs at line 116

[3.2052]→[2.2865:2887](∅→∅)

A.Bid <$> uidParser

[3.2052]

[2.2887]

A.Bid <$> idParser UserId
edit in lib/Aftok/Database/PostgreSQL.hs at line 126

[3.1010]→[3.2934:2935](∅→∅),[3.2239]→[3.2934:2935](∅→∅),[3.2934]→[3.2934:2935](∅→∅),[3.2935]→[3.384:421](∅→∅),[3.421]→[3.2161:2177](∅→∅),[3.2177]→[2.2997:3017](∅→∅),[3.2207]→[3.1094:1115](∅→∅),[2.3017]→[3.1094:1115](∅→∅),[3.1094]→[3.1094:1115](∅→∅)

qdbUserParser :: RowParser KeyedUser
qdbUserParser =
(,) <$> uidParser
<*> userParser
replacement in lib/Aftok/Database/PostgreSQL.hs at line 131

[2.3044]→[2.3044:3070](∅→∅)

<*> uidParser

[2.3044]

[3.3169]

<*> idParser UserId
replacement in lib/Aftok/Database/PostgreSQL.hs at line 136

[3.2298]→[2.3071:3129](∅→∅)

P.Invitation <$> pidParser
<*> uidParser

[3.2298]

[2.3129]

P.Invitation <$> idParser P.ProjectId
<*> idParser UserId
edit in lib/Aftok/Database/PostgreSQL.hs at line 141

[3.3457]→[3.2530:2531](∅→∅),[3.2530]→[3.2530:2531](∅→∅),[3.2531]→[3.461:504](∅→∅),[3.314]→[3.461:504](∅→∅),[3.504]→[3.2299:2318](∅→∅),[3.2318]→[2.3195:3215](∅→∅),[3.2348]→[3.1337:1361](∅→∅),[2.3215]→[3.1337:1361](∅→∅),[3.1337]→[3.1337:1361](∅→∅)

qdbProjectParser :: RowParser KeyedProject
qdbProjectParser =
(,) <$> pidParser
<*> projectParser
replacement in lib/Aftok/Database/PostgreSQL.hs at line 144

[3.3516]→[2.3256:3310](∅→∅)

B.Billable <$> pidParser
<*> uidParser

[3.3516]

[2.3310]

B.Billable <$> idParser P.ProjectId
<*> idParser UserId
replacement in lib/Aftok/Database/PostgreSQL.hs at line 150

[2.3417]→[2.3417:3451](∅→∅)

<*> (Days <$> field)

[2.3417]

[2.3451]

<*> field
replacement in lib/Aftok/Database/PostgreSQL.hs at line 158

[2.3727]→[2.3727:3786](∅→∅)

prec "semimonthly" = nullField *> pure B.SemiMonthly

[2.3727]

[2.3786]

--prec "semimonthly" = nullField *> pure B.SemiMonthly
replacement in lib/Aftok/Database/PostgreSQL.hs at line 161

[2.3887]→[2.3887:3920](∅→∅)

prec _ = empty

[2.3887]

[2.3920]

prec s = fail $ "Unrecognized recurrence type: " ++ show s
edit in lib/Aftok/Database/PostgreSQL.hs at line 169

[2.4146]

[3.293]

paymentRequestParser :: RowParser PaymentRequest
paymentRequestParser =
PaymentRequest <$> (B.SubscriptionId <$> field)
<*> (field >>= (either fail pure . runGet decodeMessage))
<*> (toThyme <$> field)
<*> (toThyme <$> field)

paymentParser :: RowParser Payment
paymentParser =
Payment <$> (PaymentRequestId <$> field)
<*> (field >>= (either fail pure . runGet decodeMessage))
<*> (toThyme <$> field)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 350

[3.668]→[2.4789:4815](∅→∅),[2.4815]→[3.9039:9145](∅→∅),[3.9039]→[3.9039:9145](∅→∅)

pgEval (ReadBids aucId) =
pquery bidParser
"SELECT user_id, bid_seconds, bid_amount, bid_time FROM bids WHERE auction_id = ?"

[3.668]

[3.9145]

pgEval (FindBids aucId) =
pquery ((,) <$> idParser A.BidId <*> bidParser)
"SELECT id, user_id, bid_seconds, bid_amount, bid_time FROM bids WHERE auction_id = ?"
replacement in lib/Aftok/Database/PostgreSQL.hs at line 371

[2.4918]→[3.9708:9743](∅→∅),[3.9708]→[3.9708:9743](∅→∅)

headMay <$> pquery qdbUserParser

[2.4918]

[3.9743]

headMay <$> pquery ((,) <$> idParser UserId <*> userParser)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 412

[2.5200]→[3.11387:11413](∅→∅),[3.11387]→[3.11387:11413](∅→∅)

pquery qdbProjectParser

[2.5200]

[3.11413]

pquery ((,) <$> idParser P.ProjectId <*> projectParser)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 437

[2.5529]→[2.5529:5564](∅→∅)

, b ^. (B.gracePeriod . _Days)

[2.5529]

[3.12451]

, b ^. (B.gracePeriod)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 440

[3.3719]→[2.5565:5593](∅→∅)

pgEval (ReadBillable bid) =

[3.3719]

[3.12491]

pgEval (FindBillable bid) =
edit in lib/Aftok/Database/PostgreSQL.hs at line 455

[2.5781]

[2.5781]

pgEval (FindSubscription sid) =
headMay <$> pquery subscriptionParser
"SELECT id, billable_id, start_date, end_date \
\FROM subscriptions s \
\WHERE s.id = ?"
(Only (sid ^. B._SubscriptionId))
replacement in lib/Aftok/Database/PostgreSQL.hs at line 464

[2.5820]→[2.5820:5883](∅→∅)

pquery ((,) <$> subscriptionIdParser <*> subscriptionParser)

[2.5820]

[2.5883]

pquery ((,) <$> idParser B.SubscriptionId <*> subscriptionParser)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 477

[3.959]→[3.959:1044](∅→∅)

\(subscription_id, event_id, request_data) \
\VALUES (?, ?, ?) RETURNING id"

[3.959]

[2.6158]

\(subscription_id, event_id, request_data, request_time, billing_date) \
\VALUES (?, ?, ?, ?, ?) RETURNING id"
edit in lib/Aftok/Database/PostgreSQL.hs at line 482

[3.1180]

[3.1180]

, req ^. (paymentRequestTime . to fromThyme)
, req ^. (billingDate . to fromThyme)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 486

[3.1568]→[2.6207:6248](∅→∅)

pgEval dbop @ (CreatePayment _ req) = do

[3.1568]

[3.48]

pgEval (FindPaymentRequest rid) =
headMay <$> pquery paymentRequestParser
"SELECT subscription_id, request_data, request_time, billing_date \
\FROM payment_requests \
\WHERE id = ?"
(Only (rid ^. _PaymentRequestId))

pgEval (FindPaymentRequests sid) =
pquery ((,) <$> idParser PaymentRequestId <*> paymentRequestParser)
"SELECT id, subscription_id, request_data, request_time, billing_date \
\FROM payment_requests \
\WHERE subscription_id = ?"
(Only (sid ^. B._SubscriptionId))

pgEval dbop @ (CreatePayment _ p) = do
replacement in lib/Aftok/Database/PostgreSQL.hs at line 504

[3.129]→[3.129:260](∅→∅)

\(payment_request_id, event_id, payment_data) \
\VALUES (?, ?, ?) RETURNING id"
( req ^. (request . _PaymentRequestId)

[3.129]

[3.260]

\(payment_request_id, event_id, payment_data, payment_date) \
\VALUES (?, ?, ?, ?) RETURNING id"
( p ^. (request . _PaymentRequestId)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 508

[3.286]→[3.286:339](∅→∅)

, req ^. (payment . to (runPut . encodeMessage))

[3.286]

[3.339]

, p ^. (payment . to (runPut . encodeMessage))
, p ^. (paymentDate . to fromThyme)
edit in lib/Aftok/Database/PostgreSQL.hs at line 511

[3.345]

[3.1044]

pgEval (FindPayments rid) =
pquery ((,) <$> idParser PaymentId <*> paymentParser)
"SELECT id, payment_request_id, payment_data, payment_date \
\FROM payments \
\WHERE payment_request_id = ?"
(Only (rid ^. _PaymentRequestId))
edit in lib/Aftok/Database.hs at line 11

[2.6460]

[3.173]

import Control.Monad.Trans.Maybe (MaybeT(..))
edit in lib/Aftok/Database.hs at line 24

[3.5920]→[3.5920:5956](∅→∅)

type KeyedUser = (UserId, User)
edit in lib/Aftok/Database.hs at line 25

[3.6007]→[3.6007:6049](∅→∅)

type KeyedProject = (ProjectId, Project)
replacement in lib/Aftok/Database.hs at line 31

[3.6248]→[3.6248:6305](∅→∅)

FindUserByName :: UserName -> DBOp (Maybe KeyedUser)

[3.6248]

[3.6305]

FindUserByName :: UserName -> DBOp (Maybe (UserId, User))
replacement in lib/Aftok/Database.hs at line 35

[3.6410]→[3.6410:6462](∅→∅)

FindUserProjects :: UserId -> DBOp [KeyedProject]

[3.6410]

[3.6462]

FindUserProjects :: UserId -> DBOp [(ProjectId, Project)]
replacement in lib/Aftok/Database.hs at line 50

[3.7028]→[3.7028:7074](∅→∅)

ReadBids :: AuctionId -> DBOp [Bid]

[3.7028]

[3.4052]

FindBids :: AuctionId -> DBOp [(BidId, Bid)]
replacement in lib/Aftok/Database.hs at line 53

[3.1063]→[3.13324:13382](∅→∅),[3.13324]→[3.13324:13382](∅→∅)

ReadBillable :: BillableId -> DBOp (Maybe Billable)

[3.1063]

[3.13382]

FindBillable :: BillableId -> DBOp (Maybe Billable)
edit in lib/Aftok/Database.hs at line 56

[2.6570]

[2.6570]

FindSubscription :: SubscriptionId -> DBOp (Maybe Subscription)
replacement in lib/Aftok/Database.hs at line 59

[3.4200]→[3.1064:1202](∅→∅)

CreatePaymentRequest :: UserId -> PaymentRequest -> DBOp PaymentRequestId
CreatePayment :: UserId -> Payment -> DBOp PaymentId

[3.4200]

[3.7074]

CreatePaymentRequest :: UserId -> PaymentRequest -> DBOp PaymentRequestId
FindPaymentRequest :: PaymentRequestId -> DBOp (Maybe PaymentRequest)
FindPaymentRequests :: SubscriptionId -> DBOp [(PaymentRequestId, PaymentRequest)]

CreatePayment :: UserId -> Payment -> DBOp PaymentId
FindPayments :: PaymentRequestId -> DBOp [(PaymentId, Payment)]
replacement in lib/Aftok/Database.hs at line 102

[3.5045]→[2.7219:7284](∅→∅)

findUserByName :: (MonadDB m) => UserName -> m (Maybe KeyedUser)

[3.5045]

[2.7284]

findUserByName :: (MonadDB m) => UserName -> m (Maybe (UserId, User))
replacement in lib/Aftok/Database.hs at line 118

[3.565]→[2.7489:7551](∅→∅)

findUserProjects :: (MonadDB m) => UserId -> m [KeyedProject]

[3.565]

[2.7551]

findUserProjects :: (MonadDB m) => UserId -> m [(ProjectId, Project)]
replacement in lib/Aftok/Database.hs at line 189

[3.4547]→[2.9037:9138](∅→∅)

readBillable :: (MonadDB m) => BillableId -> m (Maybe Billable)
readBillable = liftdb . ReadBillable

[3.4547]

[3.4654]

findBillable :: (MonadDB m) => BillableId -> MaybeT m Billable
findBillable = MaybeT . liftdb . FindBillable

findSubscriptions :: (MonadDB m) => UserId -> ProjectId -> m [(SubscriptionId, Subscription)]
findSubscriptions uid pid = liftdb $ FindSubscriptions uid pid

findSubscriptionBillable :: (MonadDB m) => SubscriptionId -> MaybeT m (Subscription' Billable)
findSubscriptionBillable sid = do
sub <- MaybeT . liftdb $ FindSubscription sid
traverse findBillable sub
replacement in lib/Aftok/Database.hs at line 200

[3.4655]→[2.9139:9535](∅→∅)

findSubscriptions :: (MonadDB m)
=> UserId
-> ProjectId
-> m [(SubscriptionId, Subscription' Billable)]
findSubscriptions uid pid = do
subscriptions <- liftdb $ FindSubscriptions uid pid
let sub'' s = sequenceA <$> traverse readBillable s
sub' (sid, s) = fmap (fmap (sid,)) (sub'' s)
catMaybes <$> traverse sub' subscriptions

[3.4655]

[3.1594]

findPaymentRequests :: (MonadDB m) => SubscriptionId -> m [(PaymentRequestId, PaymentRequest)]
findPaymentRequests = liftdb . FindPaymentRequests
replacement in lib/Aftok/Database.hs at line 203

[3.1595]→[2.9536:9595](∅→∅),[3.515]→[3.4861:4910](∅→∅),[2.9595]→[3.4861:4910](∅→∅),[3.13896]→[3.4861:4910](∅→∅),[3.4861]→[3.4861:4910](∅→∅)

readPaymentHistory :: (MonadDB m) => UserId -> m [Payment]
readPaymentHistory = error "Not yet implemented"

[3.1595]

[3.4910]

findPayment :: (MonadDB m) => PaymentRequestId -> m (Maybe Payment)
findPayment prid = (fmap snd . headMay) <$> liftdb (FindPayments prid)
edit in lib/Aftok/Json.hs at line 24

[42.58]

[43.3094]

import Data.Thyme.Calendar (showGregorian)
edit in lib/Aftok/Json.hs at line 30

[3.115]→[3.1294:1326](∅→∅),[3.1404]→[3.1294:1326](∅→∅),[3.1294]→[3.1294:1326](∅→∅)

import Aftok.Database
edit in lib/Aftok/Json.hs at line 33

[3.171]→[2.10086:10114](∅→∅)

import Aftok.Time
replacement in lib/Aftok/Json.hs at line 102

[3.486]→[3.9335:9375](∅→∅)

qdbProjectJSON :: KeyedProject -> Value

[3.486]

[3.6629]

qdbProjectJSON :: (ProjectId, Project) -> Value
replacement in lib/Aftok/Json.hs at line 181

[2.10168]→[2.10168:10224](∅→∅)

, "gracePeriod" .= (b ^. (B.gracePeriod . _Days))

[2.10168]

[2.10224]

, "gracePeriod" .= (b ^. B.gracePeriod)
replacement in lib/Aftok/Json.hs at line 188

[3.2030]→[3.2030:2095](∅→∅)

recurrenceJSON' B.SemiMonthly = object [ "semimonthly" .= Null ]

[3.2030]

[3.2095]

--recurrenceJSON' B.SemiMonthly = object [ "semimonthly" .= Null ]
replacement in lib/Aftok/Json.hs at line 202

[3.907]→[3.907:967](∅→∅)

, "payment_request_date" .= (r ^. paymentRequestDate)

[3.907]

[3.967]

, "payment_request_time" .= (r ^. paymentRequestTime)
, "billing_date" .= (r ^. (billingDate . to showGregorian))
edit in lib/Aftok/Payments/Types.hs at line 2

[2.10579]

[2.10579]

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
edit in lib/Aftok/Payments/Types.hs at line 12

[2.10704]

[2.10704]

import Data.Thyme.Time as T
edit in lib/Aftok/Payments/Types.hs at line 16

[2.10774]

[2.10774]

import Network.Bippy.Types (expiryTime, getPaymentDetails, getExpires)
replacement in lib/Aftok/Payments/Types.hs at line 30

[2.11150]→[2.11150:11191](∅→∅)

, _paymentRequestDate :: C.UTCTime
}

[2.11150]

[2.11191]

, _paymentRequestTime :: C.UTCTime
, _billingDate :: T.Day
} deriving (Functor, Foldable, Traversable)
replacement in lib/Aftok/Payments/Types.hs at line 41

[2.11383]→[2.11383:11387](∅→∅)

}

[2.11383]

[2.11387]

} deriving (Functor, Foldable, Traversable)
replacement in lib/Aftok/Payments/Types.hs at line 46

[2.11452]→[2.11452:11453](∅→∅)

[2.11452]

{- Check whether the specified payment request has expired (whether wallet software
- will still consider the payment request valid)
-}
isExpired :: C.UTCTime -> P.PaymentRequest -> Bool
isExpired now req =
let check = any ((now >) . T.toThyme . expiryTime)
-- using error here is reasonable since it would indicate
-- a serialization problem
in either error (check . getExpires) $ getPaymentDetails req
replacement in lib/Aftok/Payments.hs at line 11

[3.5782]→[2.11615:11677](∅→∅)

import Control.Lens (makeLenses, view, (%~), (^.))

[3.5782]

[2.11677]

import Control.Error.Util (maybeT)
import Control.Lens (makeClassy, makeClassyPrisms, view, (%~), (^.), review)
replacement in lib/Aftok/Payments.hs at line 14

[2.11713]→[2.11713:11829](∅→∅)

import Control.Monad.Except (MonadError)
import Crypto.PubKey.RSA.Types (Error(..), PrivateKey)

[2.11713]

[2.11829]

import Control.Monad.Except (MonadError, throwError)
import qualified Crypto.PubKey.RSA.Types as RSA (Error(..), PrivateKey)
edit in lib/Aftok/Payments.hs at line 20

[2.11965]

[3.2276]

import Data.Thyme.Time as T
edit in lib/Aftok/Payments.hs at line 22

[3.2318]→[2.11966:12016](∅→∅)

import Data.Thyme.Time.Core (fromThyme)
replacement in lib/Aftok/Payments.hs at line 39

[2.12522]→[2.12522:12552](∅→∅)

, _signingKey :: PrivateKey

[2.12522]

[2.12552]

, _signingKey :: RSA.PrivateKey
replacement in lib/Aftok/Payments.hs at line 42

[2.12583]→[2.12583:12610](∅→∅)

makeLenses ''BillingConfig

[2.12583]

[2.12610]

makeClassy ''BillingConfig

data BillingOps (m :: * -> *) = BillingOps
{ memoGen :: Subscription' Billable -> m (Maybe Text) -- ^ generator user memo
, uriGen :: Subscription' Billable -> m (Maybe URI) -- ^ generator for payment response URL
, payloadGen :: Subscription' Billable -> m (Maybe ByteString) -- ^ generator for merchant payload
}

data PaymentRequestStatus
= Paid Payment -- ^ the request was paid with the specified payment
| Unpaid PaymentRequest -- ^ the request has not been paid, but has not yet expired
| Expired PaymentRequest -- ^ the request was not paid prior to the expiration date
edit in lib/Aftok/Payments.hs at line 55

[2.12611]

[2.12611]

data PaymentError
= Overdue SubscriptionId
| SigningError RSA.Error
makeClassyPrisms ''PaymentError
replacement in lib/Aftok/Payments.hs at line 61

[2.12612]→[2.12612:13259](∅→∅)

createPaymentRequests :: (MonadRandom m, MonadReader BillingConfig m, MonadError Error m, MonadDB m) =>
C.UTCTime -- timestamp for payment request creation
-> (Subscription' Billable -> m (Maybe Text)) -- generator user memo
-> (Subscription' Billable -> m (Maybe URI)) -- generator for payment response URL
-> (Subscription' Billable -> m (Maybe ByteString)) -- generator for merchant payload
-> UserId -- user responsible for payment
-> ProjectId -- project whose worklog is to be paid out to

[2.12612]

[2.13259]

createPaymentRequests :: ( MonadRandom m
, MonadReader r m, HasBillingConfig r
, MonadError e m, AsPaymentError e
, MonadDB m
)
=> BillingOps m -- ^ generators for payment request components
-> C.UTCTime -- ^ timestamp for payment request creation
-> UserId -- ^ customer responsible for payment
-> ProjectId -- ^ project whose worklog is to be paid
replacement in lib/Aftok/Payments.hs at line 71

[2.13305]→[2.13305:13366](∅→∅)

createPaymentRequests t memogen urigen plgen custId pid = do

[2.13305]

[2.13366]

createPaymentRequests ops now custId pid = do
edit in lib/Aftok/Payments.hs at line 73

[2.13414]

[2.13414]

join <$> traverse (createSubscriptionPaymentRequests ops now custId) subscriptions

createSubscriptionPaymentRequests ::
( MonadRandom m
, MonadReader r m, HasBillingConfig r
, MonadError e m, AsPaymentError e
, MonadDB m
)
=> BillingOps m
-> C.UTCTime
-> UserId
-> (SubscriptionId, Subscription)
-> m [PaymentRequestId]
createSubscriptionPaymentRequests ops now custId (sid, sub) = do
billableSub <- maybeT (raiseSubjectNotFound . FindBillable $ sub ^. billable) pure $
traverse findBillable sub
paymentRequests <- findPaymentRequests sid
billableDates <- findUnbilledDates now (view billable billableSub) paymentRequests $
takeWhile (< view _utctDay now) $ billingSchedule billableSub
traverse (createPaymentRequest ops now custId sid billableSub) billableDates

createPaymentRequest ::
( MonadRandom m
, MonadReader r m, HasBillingConfig r
, MonadError e m, AsPaymentError e
, MonadDB m
)
=> BillingOps m
-> C.UTCTime
-> UserId
-> SubscriptionId
-> Subscription' Billable
-> T.Day
-> m PaymentRequestId
createPaymentRequest ops now custId sid sub bday = do
replacement in lib/Aftok/Payments.hs at line 109

[2.13427]→[2.13427:13603](∅→∅)

let createPaymentDetails' s = do
memo <- memogen s
uri <- urigen s
payload <- plgen s
createPaymentDetails t memo uri payload (s ^. billable)

[2.13427]

[3.610]

memo <- memoGen ops sub
uri <- uriGen ops sub
payload <- payloadGen ops sub
details <- createPaymentDetails bday now memo uri payload (sub ^. billable)
reqErr <- B.createPaymentRequest (cfg ^. signingKey) (cfg ^. pkiData) details
req <- either (throwError . review _SigningError) pure reqErr
liftdb $ CreatePaymentRequest custId (PaymentRequest sid req now bday)

{-
- FIXME: The current implementation expects the billing day to be a suitable
- key for comparison to payment requests. This is almost certainly inadequate.
-}
findUnbilledDates :: (MonadDB m, MonadError e m, AsPaymentError e)
=> C.UTCTime -- ^ the date against which payment request expiration should be checked
-> Billable
-> [(PaymentRequestId, PaymentRequest)] -- ^ the list of existing payment requests
-> [T.Day] -- ^ the list of expected billing days
-> m [T.Day] -- ^ the list of billing days for which no payment request exists
findUnbilledDates now b (px @ (p : ps)) (dx @ (d : ds)) =
case compare (view (_2 . billingDate) p) d of
EQ -> getRequestStatus now p >>= \s -> case s of
Expired r -> if view _utctDay now > addDays (view gracePeriod b) (view billingDate r)
then throwError (review _Overdue (r ^. subscription))
else fmap (d :) $ findUnbilledDates now b px dx -- d will be rebilled
_ -> findUnbilledDates now b ps ds -- if paid or unpaid, nothing to do
GT -> fmap (d :) $ findUnbilledDates now b px ds
LT -> findUnbilledDates now b ps dx
findUnbilledDates _ _ _ ds = pure ds
replacement in lib/Aftok/Payments.hs at line 138

[3.611]→[2.13604:13890](∅→∅)

createPaymentRequest (sid, s) = do
details <- createPaymentDetails' s
req <- B.createPaymentRequest (cfg ^. signingKey) (cfg ^. pkiData) details
liftdb $ CreatePaymentRequest custId (PaymentRequest sid req t)
traverse createPaymentRequest subscriptions

[3.611]

[2.13890]

{- Check whether the specified payment request has a payment associated with
- it, and return a PaymentRequestStatus value indicating the result.
-}
getRequestStatus :: (MonadDB m)
=> C.UTCTime -- ^ the date against which request expiration should be checked
-> (PaymentRequestId, PaymentRequest) -- ^ the request for which to find a payment
-> m PaymentRequestStatus
getRequestStatus now (reqid, req) =
let ifUnpaid = (if isExpired now (view paymentRequest req) then Expired else Unpaid) req
in maybe ifUnpaid Paid <$> findPayment reqid
replacement in lib/Aftok/Payments.hs at line 150

[2.13891]→[2.13891:14275](∅→∅)

createPaymentDetails :: (MonadRandom m, MonadReader BillingConfig m, MonadDB m) =>
C.UTCTime -- timestamp for payment request creation
-> Maybe Text -- user memo
-> Maybe URI -- payment response URL
-> Maybe ByteString -- merchant payload
-> Billable

[2.13891]

[2.14275]

{- Create the PaymentDetails section of the payment request.
-}
createPaymentDetails :: (MonadRandom m, MonadReader r m, HasBillingConfig r, MonadDB m)
=> T.Day -- ^ payout date (billing date)
-> C.UTCTime -- ^ timestamp of payment request creation
-> Maybe Text -- ^ user memo
-> Maybe URI -- ^ payment response URL
-> Maybe ByteString -- ^ merchant payload
-> Billable -- ^ billing information
replacement in lib/Aftok/Payments.hs at line 160

[2.14318]→[2.14318:14551](∅→∅)

createPaymentDetails t memo uri payload b = do
payouts <- getProjectPayouts t (b ^. project)
outputs <- createPayoutsOutputs t (b ^. amount) payouts
let expiry = (BT.Expiry . fromThyme . (t .+^)) <$> (b ^. requestExpiryPeriod)

[2.14318]

[2.14551]

createPaymentDetails payoutDate billingTime memo uri payload b = do
payouts <- getProjectPayouts payoutTime (b ^. project)
outputs <- createPayoutsOutputs payoutTime (b ^. amount) payouts
let expiry = (BT.Expiry . T.fromThyme . (billingTime .+^)) <$> (b ^. requestExpiryPeriod)
replacement in lib/Aftok/Payments.hs at line 165

[2.14564]→[2.14564:14659](∅→∅)

pure $ B.createPaymentDetails (cfg ^. network) outputs (fromThyme t) expiry memo uri payload

[2.14564]

[2.14659]

pure $ B.createPaymentDetails
(cfg ^. network)
outputs
(T.fromThyme billingTime)
expiry memo uri payload
where
payoutTime = T.mkUTCTime payoutDate (fromInteger 0)
replacement in server/Aftok/Snaplet/Projects.hs at line 46

[3.3443]→[2.18063:18118](∅→∅)

projectListHandler :: S.Handler App App [KeyedProject]

[3.3443]

[3.1433]

projectListHandler :: S.Handler App App [(ProjectId, Project)]
replacement in stack.yaml at line 6

[3.10594]→[2.23287:23340](∅→∅)

commit: ddfc1bf0911351d0be51f33ea9e4166a24d2b19a

[3.10594]

[3.10647]

commit: 97fda0368ae660239d1b9398d44530cd5b05eec3