This is not yet fully ready, as the payment request endpoint should not require user login, but should instead use a secure identifier for easy handling by wallet software. However, this is now suitable for initial testing.
AL37SVTCKRSG4HG2PCYK5Z7QSIZZH5JHH4Q2VLMXFAXSAQRFFG4QC
JFOEOFGA4CQR2LW43IVQGDZSPVJAD4KDN2DZMZXGM2QDIUD7AVCAC
DFOBMSAODB3NKW37B272ZXA2ML5HMIH3N3C4GT2DPEQS7ZFK4SNAC
64C6AWH66FDKU6UE6Z6JPX2J2GBM2JOPTH2GL6LHKAIUBGNGDZ5AC
2XQD6KKKD6QVHFHAEMVE3XXY7X2T7BLTLL7XIILZAXNJJH2YONUQC
IZEVQF627FA7VV25KJAWYWGGC35LZUUBBQRPN5ZAINTQLPEDRTEAC
HMDM3B557TO5RYP2IGFFC2C2VN6HYZTDQ47CJY2O37BW55DSMFZAC
SEWTRB6S5PO5MQBLCPVBD7XT2BDYNZUE2RO6Z2XENZRIOCN6OZJAC
73NDXDEZRMK672GHSTC3CI6YHXFZ2GGJI5IKQGHKFDZKTNSQXLLQC
O227CEAV7BTKSE3SSC7XHC5IWEBXZL2AOOKJMBMOOFNTLINBLQMAC
Y3LIJ5USPMYBG7HKCIQBE7MWVGLQJPJSQD3KPZCTKXP22GOB535QC
QMRKFEPGFBCEWAIXPEIG5ILKAJ2JH5L3TOITHR4HNJXK5FN3KXBQC
Q5X5RYQLP5K7REYD6VLHOKC4W36ZELJYA45V6YFKTD5S6MPN3NDQC
NAS4BFL43SIUAAC663R6VFBHQ2DKI45K6Y6ZKVQI7S5547HBAN7QC
NLZ3JXLOOIL37O3RRQWXHNPNSNEOOLPD6MCB754BEBECQB3KGR2AC
W35DDBFYF6Z4ZPCFEO5RPAONZLYCSNTXUSTS6FIUUVZHCI6Q7GHAC
WAIX6AGNDVJOKTWZ7OP7QOYSJHAJSX5EOWXZHOAO2IG6ALWUCJ6QC
Z3MK2PJ5U222DXRS22WCDHVPZ7HVAR3HOCUNXIGX6VMEPBQDF6PQC
GCVQD44VRPQVKPZEPIC4AOIXLJIG2ZMV3QI2Y7KALUT6NVUBSGSAC
HALRDT2F22DAQ54M334YSKD2XJCAXDXEZPDKGMOWKH7XELBAS6MAC
NEDDHXUK3GNFMOFO3KLU7NRIHCTYNWBT3D6HTKZAOXFDE6HMDZ6AC
I2KHGVD44KT4MQJXGCTVSQKMBO6TVCY72F26TLXGWRL6PHGF6RNQC
PBD7LZYQHXAA3KLH2ZUX5GW4UFML6BQ32KXZF4KZ6OYFASUYFJ5QC
MJ6R42RCK2ASXAJ6QXDPMAW56RBOJ4F4HI2LFIV3KXFIKWYMQK3QC
BROSTG5KP3NUNLSYPVQID254TE47E5RKQAKLPIY7PGWETE6JNMTAC
ADMKQQGCGVSHHIMVQ4XFRDCG544SBJCYALSKZV45CQQBZ4ACUH2AC
O722AOKEWXWJPRHGJREU6QPW7HEFPPRETZIAADZ2RMAXHARCNEKAC
ASF3UPJLCX7KIUCNJD5KAXSPDXCUEJHLL4HBRTRUBPCW73IXOCWQC
pgEval (FindUnpaidRequests sid) =
let rowp :: RowParser (PaymentRequestId, PaymentRequest, B.Subscription, B.Billable)
rowp = (,,,) <$> idParser PaymentRequestId
<*> paymentRequestParser
<*> subscriptionParser
<*> billableParser
in pquery rowp
"SELECT id, \
\ r.subscription_id, r.request_data, r.request_time, r.billing_date, \
\ s.user_id, s.billable_id, s.start_date, s.end_date, \
\ b.project_id, e.created_by, b.name, b.description, b.recurrence_type, \
\ b.recurrence_count, b.billing_amount, b.grace_period_days \
\FROM payment_requests r \
\JOIN subscriptions s on s.id = r.subscription_id \
\JOIN billables b on b.id = s.billable_id \
\WHERE subscription_id = ? \
\AND r.id NOT IN (SELECT payment_request_id FROM payments)"
(Only (sid ^. B._SubscriptionId))
CreateSubscription :: UserId -> Subscription -> DBOp SubscriptionId
FindSubscription :: SubscriptionId -> DBOp (Maybe Subscription)
FindSubscriptions :: UserId -> ProjectId -> DBOp [(SubscriptionId, Subscription)]
CreateSubscription :: UserId -> BillableId -> DBOp SubscriptionId
FindSubscription :: SubscriptionId -> DBOp (Maybe Subscription)
FindSubscriptions :: UserId -> ProjectId -> DBOp [(SubscriptionId, Subscription)]
billableJSON b = v1 $
obj [ "projectId" .= (b ^. (B.project . _ProjectId . to tshow))
, "name" .= (b ^. B.name)
, "description" .= (b ^. B.description)
, "recurrence" .= recurrenceJSON' (b ^. B.recurrence)
, "amount" .= (b ^. (B.amount . satoshi))
, "gracePeriod" .= (b ^. B.gracePeriod)
, "requestExpiryPeriod" .= (C.toSeconds' <$> (b ^. B.requestExpiryPeriod))
]
billableJSON = v1 . obj . billableKV
billableKV :: (KeyValue kv) => B.Billable -> [kv]
billableKV b =
[ "projectId" .= (b ^. (B.project . _ProjectId . to tshow))
, "name" .= (b ^. B.name)
, "description" .= (b ^. B.description)
, "recurrence" .= recurrenceJSON' (b ^. B.recurrence)
, "amount" .= (b ^. (B.amount . satoshi))
, "gracePeriod" .= (b ^. B.gracePeriod)
, "requestExpiryPeriod" .= (C.toSeconds' <$> (b ^. B.requestExpiryPeriod))
]
createSubscriptionJSON :: UserId -> B.Subscription -> Value
createSubscriptionJSON uid sub = v1 $
obj [ "user_id" .= tshow (uid ^. _UserId)
, "billable_id" .= tshow (sub ^. (B.billable . B._BillableId))
createSubscriptionJSON :: UserId -> B.BillableId -> Value
createSubscriptionJSON uid bid = v1 $
obj [ "user_id" .= idJSON _UserId uid
, "billable_id" .= idJSON B._BillableId bid
paymentRequestJSON r = v1 $
obj [ "subscription_id" .= (r ^. (subscription . B._SubscriptionId . to tshow))
, "payment_request_protobuf_64" .= (r ^. (paymentRequest . to (decodeUtf8 . B64.encode . runPut . encodeMessage)))
, "payment_request_time" .= (r ^. paymentRequestTime)
, "billing_date" .= (r ^. (billingDate . to showGregorian))
]
paymentRequestJSON = v1 . obj . paymentRequestKV
paymentRequestKV :: (KeyValue kv) => PaymentRequest -> [kv]
paymentRequestKV r =
[ "subscription_id" .= (r ^. (subscription . B._SubscriptionId . to tshow))
, "payment_request_protobuf_64" .= (r ^. (paymentRequest . to (decodeUtf8 . B64.encode . runPut . encodeMessage)))
, "payment_request_time" .= (r ^. paymentRequestTime)
, "billing_date" .= (r ^. (billingDate . to showGregorian))
]
billDetailsJSON :: [BillDetail] -> Value
billDetailsJSON r = v1 $
obj ["payment_requests" .= fmap billDetailJSON r ]
{ 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
{ memoGen :: Subscription' UserId Billable -> m (Maybe Text) -- ^ generator user memo
, uriGen :: Subscription' UserId Billable -> m (Maybe URI) -- ^ generator for payment response URL
, payloadGen :: Subscription' UserId Billable -> m (Maybe ByteString) -- ^ generator for merchant payload
findPayableRequests :: (MonadDB m) => UserId -> SubscriptionId -> C.UTCTime -> m [BillDetail]
findPayableRequests uid sid now = do
requests <- liftdb findOp
join <$> (traverse checkAccess $ filter (not . isExpired now . view _2) requests)
where
findOp = FindUnpaidRequests sid
checkAccess d =
if view (_3 . customer) d == uid
then pure [d]
else raiseOpForbidden uid (UserNotSubscriber sid) findOp
requireProjectId :: MonadSnap m => m ProjectId
requireProjectId = do
maybePid <- parseParam "projectId" pidParser
maybe (snapError 400 "Value of parameter \"projectId\" cannot be parsed as a valid UUID")
pure
maybePid
where
pidParser = do
bs <- takeByteString
pure $ ProjectId <$> fromASCIIBytes bs
requireAuctionId :: MonadSnap m => m AuctionId
requireAuctionId = do
maybeAid <- parseParam "auctionId" aidParser
maybe (snapError 400 "Value of parameter \"auctionId\" cannot be parsed as a valid UUID")
pure
maybeAid
where
aidParser = do
bs <- takeByteString
pure $ AuctionId <$> fromASCIIBytes bs
import Aftok.QConfig
listPayableRequestsHandler :: S.Handler App App [BillDetail]
listPayableRequestsHandler = do
uid <- requireUserId
sid <- requireId "subscriptionId" SubscriptionId
now <- liftIO $ C.getCurrentTime
snapEval $ findPayableRequests uid sid now
requestPaymentHandler :: QConfig -> Handler App App
requestPaymentHandler cfg = do
-- get payout percentages from payouts handler
getPaymentRequestHandler :: S.Handler App App P.PaymentRequest
getPaymentRequestHandler = do
pid <- requireProjectId
ptime <- liftIO $ C.getCurrentTime
createPaymentRequests ptime memogen urigen plgen uid pid
-- look up outstanding subscriptions the user has for this project
-- determine which subscriptions need to be paid
-- create a payment request for each subscription
sid <- requireId "subscriptionId" SubscriptionId
rid <- requireId "paymentRequestId" PaymentRequestId
now <- liftIO $ C.getCurrentTime
requests <- snapEval $ findPayableRequests uid sid now
let prMay = fmap (view (_2 . paymentRequest)) . headMay $ filter ((==) rid . view _1) requests
maybe (snapError 404 $ "Outstanding payment request not found for id " <> tshow rid) pure prMay
requireId :: MonadSnap m
=> Text -- ^ name of the parameter
-> (UUID -> a) -- ^ constructor for the identifier
-> m a
requireId name f = do
maybeId <- parseParam name idParser
maybe (snapError 400 $ "Value of parameter \"" <> name <> "\" is not a valid UUID") pure maybeId
where
idParser = do
bs <- takeByteString
pure $ f <$> fromASCIIBytes bs
requireAuctionId :: MonadSnap m => m AuctionId
requireAuctionId = requireId "auctionId" AuctionId