Add payment response handler.

[?]

Feb 26, 2017, 12:25 AM

BSIUHCGFDFDFGWYMHZB7OVU3Z3IHPEUXRISIOPGZI2RUXZFDS2EQC

Dependencies

[2] 4FDQGIXN Make payment request retrieval key an opaque 32-bit hash.
[3] O227CEAV Adds storage of original event JSON for some DBOp constructors.
[4] ASF3UPJL Add auction creation and bid handlers
[5] AL37SVTC Implement payments service endpoints.
[6] IZEVQF62 Work in progress replacing sqlite with postgres.
[7] QMRKFEPG Refactor QDB to use a free monad algebra instead.
[8] O722AOKE Add route to allow crediting of events to users/projects.
[9] JFOEOFGA stylish-haskell formatting.
[10] WAIX6AGN Add event serialization for PaymentRequest & Payment
[11] DFOBMSAO Initial work on payments API
[12] 3QVT6MA6 Add database support for event amend operations.
[13] Q5X5RYQL stylish-haskell reformatting
[14] HALRDT2F Added initial auction create route.
[15] MJ6R42RC Utility methods for reading key & cert data.
[16] NEDDHXUK Reformat via stylish-haskell
[17] RN7EI6IN Update database layer to use CreditTo
[18] Y3LIJ5US Add handler for CreatePaymentRequest
[19] HMDM3B55 Implement core of payments/billing infrastructure.
[20] 73NDXDEZ Begin implementation of billing event persistence.
[21] QADKFHAR Adds CreatePayment handler implementation.
[22] SEWTRB6S Implement payment request creation functions.
[*] 64C6AWH6 Rename Ananke -> Quixotic, project reboot.
[*] ADMKQQGC Initial empty Snap project.

Change contents

replacement in lib/Aftok/Database/PostgreSQL.hs at line 9

[3.1043]→[2.19:163](∅→∅)

import qualified Crypto.Hash.BLAKE2.BLAKE2b as B2
import Crypto.Random.Types (MonadRandom, getRandomBytes)

[3.1043]

[3.511]

import Crypto.Random.Types (MonadRandom,
getRandomBytes)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 26

[3.1829]→[2.164:252](∅→∅)

import Network.Haskoin.Crypto (addrToBase58, encodeBase58Check)

[3.1829]

[3.1011]

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

[3.1466]→[3.2321:2528](∅→∅),[3.2321]→[3.2321:2528](∅→∅)

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

[3.1466]

[3.2528]

PaymentRequest <$> fmap B.SubscriptionId field
<*> ((either fail pure . runGet decodeMessage) =<< field)
<*> fmap PaymentKey field
<*> fmap toThyme field
<*> fmap toThyme field
replacement in lib/Aftok/Database/PostgreSQL.hs at line 215

[3.1413]→[3.200:263](∅→∅),[3.200]→[3.200:263](∅→∅)

Just $ storeEventJSON uid "create_billable" (billableJSON b)

[3.1413]

[3.263]

Just $ storeEventJSON (Just uid) "create_billable" (billableJSON b)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 218

[3.434]→[3.434:517](∅→∅)

Just $ storeEventJSON uid "create_subscription" (createSubscriptionJSON uid bid)

[3.434]

[3.384]

Just $ storeEventJSON (Just uid) "create_subscription" (createSubscriptionJSON uid bid)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 220

[3.385]→[3.1457:1501](∅→∅),[3.1501]→[3.170:248](∅→∅),[3.170]→[3.170:248](∅→∅)

storeEvent (CreatePaymentRequest uid req) =
Just $ storeEventJSON uid "create_payment_request" (paymentRequestJSON req)

[3.385]

[3.248]

storeEvent (CreatePaymentRequest req) =
Just $ storeEventJSON Nothing "create_payment_request" (paymentRequestJSON req)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 223

[3.249]→[3.1502:1539](∅→∅),[3.1539]→[3.287:350](∅→∅),[3.287]→[3.287:350](∅→∅)

storeEvent (CreatePayment uid req) =
Just $ storeEventJSON uid "create_payment" (paymentJSON req)

[3.249]

[3.350]

storeEvent (CreatePayment req) =
Just $ storeEventJSON Nothing "create_payment" (paymentJSON req)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 230

[3.531]→[3.531:594](∅→∅)

storeEventJSON :: UserId -> EventType -> Value -> QDBM EventId

[3.531]

[3.594]

storeEventJSON :: Maybe UserId -> EventType -> Value -> QDBM EventId
replacement in lib/Aftok/Database/PostgreSQL.hs at line 237

[3.806]→[3.806:854](∅→∅)

(fromThyme timestamp, uid ^. _UserId, t, v)

[3.806]

[3.425]

(fromThyme timestamp, preview (_Just . _UserId) uid, t, v)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 485

[3.6109]→[3.6109:6157](∅→∅)

pgEval dbop @ (CreatePaymentRequest _ req) = do

[3.6109]

[3.863]

pgEval dbop @ (CreatePaymentRequest req) = do
edit in lib/Aftok/Database/PostgreSQL.hs at line 487

[3.896]→[2.344:524](∅→∅)

keyBytes <- getRandomBytes 64
let prBytes = req ^. (paymentRequest . to (runPut . encodeMessage))
urlKey = decodeUtf8 . encodeBase58Check $ B2.hash 32 keyBytes prBytes
replacement in lib/Aftok/Database/PostgreSQL.hs at line 493

[3.1566]→[2.657:684](∅→∅)

, prBytes
, urlKey

[3.1566]

[3.3477]

, req ^. (paymentRequest . to (runPut . encodeMessage))
, req ^. (paymentKey . _PaymentKey)
replacement in lib/Aftok/Database/PostgreSQL.hs at line 500

[2.730]→[3.3604:3716](∅→∅),[3.1589]→[3.3604:3716](∅→∅),[3.3604]→[3.3604:3716](∅→∅)

headMay <$> pquery paymentRequestParser
"SELECT subscription_id, request_data, request_time, billing_date \

[2.730]

[3.3716]

headMay <$> pquery ((,) <$> idParser PaymentRequestId <*> paymentRequestParser)
"SELECT id, subscription_id, request_data, url_key, request_time, billing_date \
replacement in lib/Aftok/Database/PostgreSQL.hs at line 503

[3.3743]→[2.731:753](∅→∅)

\WHERE url_key = ?"

[3.3743]

[2.753]

\WHERE url_key = ? \
\AND id NOT IN (SELECT payment_request_id FROM payments)"
replacement in lib/Aftok/Database/PostgreSQL.hs at line 509

[3.3905]→[3.3905:3979](∅→∅)

"SELECT id, subscription_id, request_data, request_time, billing_date \

[3.3905]

[3.3979]

"SELECT id, subscription_id, request_data, url_key, request_time, billing_date \
replacement in lib/Aftok/Database/PostgreSQL.hs at line 522

[2.920]→[3.1048:1131](∅→∅),[3.1048]→[3.1048:1131](∅→∅)

\ r.subscription_id, r.request_data, r.request_time, r.billing_date, \

[2.920]

[3.1131]

\ r.subscription_id, r.request_data, r.url_key, r.request_time, r.billing_date, \
replacement in lib/Aftok/Database/PostgreSQL.hs at line 533

[3.1642]→[3.4073:4112](∅→∅),[3.4073]→[3.4073:4112](∅→∅)

pgEval dbop @ (CreatePayment _ p) = do

[3.1642]

[3.48]

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

[3.4200]→[3.4955:5032](∅→∅)

CreatePaymentRequest :: UserId -> PaymentRequest -> DBOp PaymentRequestId

[3.4200]

[3.5107]

CreatePaymentRequest :: PaymentRequest -> DBOp PaymentRequestId
replacement in lib/Aftok/Database.hs at line 62

[3.1929]→[2.922:991](∅→∅)

FindPaymentRequest :: PaymentKey -> DBOp (Maybe PaymentRequest)

[3.1929]

[3.5194]

FindPaymentRequest :: PaymentKey -> DBOp (Maybe (PaymentRequestId, PaymentRequest))
replacement in lib/Aftok/Database.hs at line 64

[3.5195]→[3.5195:5251](∅→∅)

CreatePayment :: UserId -> Payment -> DBOp PaymentId

[3.5195]

[3.5251]

CreatePayment :: Payment -> DBOp PaymentId
replacement in lib/Aftok/Database.hs at line 205

[3.1595]→[2.992:1068](∅→∅)

findPaymentRequest :: (MonadDB m) => PaymentKey -> m (Maybe PaymentRequest)

[3.1595]

[2.1068]

findPaymentRequest :: (MonadDB m) => PaymentKey -> m (Maybe (PaymentRequestId, PaymentRequest))
replacement in lib/Aftok/Payments/Types.hs at line 11

[3.10647]→[3.4417:4485](∅→∅)

import Control.Lens (makeLenses, makePrisms, view)

[3.10647]

[3.10703]

import Control.Lens (makeLenses, makePrisms, view)
replacement in lib/Aftok/Payments/Types.hs at line 13

[3.6713]→[3.10704:10746](∅→∅),[3.10704]→[3.10704:10746](∅→∅),[3.10746]→[3.2309:2351](∅→∅)

import Data.Thyme.Clock as C
import Data.Thyme.Time as T

[3.10704]

[3.10746]

import Data.Thyme.Clock as C
import Data.Thyme.Time as T
replacement in lib/Aftok/Payments/Types.hs at line 17

[3.6795]→[3.10774:10816](∅→∅),[3.10774]→[3.10774:10816](∅→∅),[3.10816]→[3.2352:2433](∅→∅)

import qualified Network.Bippy.Proto as P
import Network.Bippy.Types (expiryTime, getExpires, getPaymentDetails)

[3.10774]

[2.1181]

import qualified Network.Bippy.Proto as P
import Network.Bippy.Types (expiryTime, getExpires,
getPaymentDetails)
replacement in lib/Aftok/Payments/Types.hs at line 22

[3.10817]→[3.4486:4564](∅→∅)

import Aftok.Billables (Billable, Subscription, SubscriptionId)

[3.10817]

[3.10857]

import Aftok.Billables (Billable, Subscription, SubscriptionId)
edit in lib/Aftok/Payments/Types.hs at line 36

[3.11150]

[3.6796]

, _paymentKey :: PaymentKey
replacement in lib/Aftok/Payments.hs at line 18

[3.3045]→[3.3045:3100](∅→∅)

import Crypto.Random.Types (MonadRandom)

[3.3045]

[3.5839]

import Crypto.Random.Types (MonadRandom, getRandomBytes)
edit in lib/Aftok/Payments.hs at line 28

[3.3432]

[3.3432]

import Network.Haskoin.Crypto (encodeBase58Check)
replacement in lib/Aftok/Payments.hs at line 49

[3.7803]→[3.4795:5100](∅→∅)

{ 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

[3.7803]

[3.8102]

{ -- | generator for user memo
memoGen :: Subscription' UserId Billable -> T.Day -> C.UTCTime -> m (Maybe Text)
-- | generator for payment response URL
, uriGen :: PaymentKey -> m (Maybe URI)
-- | generator for merchant payload
, payloadGen :: Subscription' UserId Billable -> T.Day -> C.UTCTime -> m (Maybe ByteString)
replacement in lib/Aftok/Payments.hs at line 79

[3.13414]→[3.4138:4223](∅→∅)

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

[3.13414]

[3.9182]

join <$> traverse (createSubscriptionPaymentRequests ops now) subscriptions
edit in lib/Aftok/Payments.hs at line 89

[3.9384]→[3.9384:9396](∅→∅)

-> UserId
replacement in lib/Aftok/Payments.hs at line 91

[3.9458]→[3.9458:9523](∅→∅)

createSubscriptionPaymentRequests ops now custId (sid, sub) = do

[3.9458]

[3.9523]

createSubscriptionPaymentRequests ops now (sid, sub) = do
replacement in lib/Aftok/Payments.hs at line 97

[3.9870]→[3.9870:9949](∅→∅)

traverse (createPaymentRequest ops now custId sid billableSub) billableDates

[3.9870]

[3.9949]

traverse (createPaymentRequest ops now sid billableSub) billableDates
edit in lib/Aftok/Payments.hs at line 107

[3.10138]→[3.10138:10150](∅→∅)

-> UserId
replacement in lib/Aftok/Payments.hs at line 111

[3.10233]→[3.10233:10287](∅→∅)

createPaymentRequest ops now custId sid sub bday = do

[3.10233]

[3.13414]

createPaymentRequest ops now sid sub bday = do
replacement in lib/Aftok/Payments.hs at line 113

[3.13427]→[3.10288:10377](∅→∅)

memo <- memoGen ops sub
uri <- uriGen ops sub
payload <- payloadGen ops sub

[3.13427]

[3.10377]

-- TODO: maybe
pkey <- PaymentKey . decodeUtf8 . encodeBase58Check <$> getRandomBytes 32
memo <- memoGen ops sub bday now
uri <- uriGen ops pkey
payload <- payloadGen ops sub bday now
replacement in lib/Aftok/Payments.hs at line 121

[3.10604]→[3.10604:10677](∅→∅)

liftdb $ CreatePaymentRequest custId (PaymentRequest sid req now bday)

[3.10604]

[3.4339]

liftdb $ CreatePaymentRequest (PaymentRequest sid req pkey now bday)
replacement in server/Aftok/Snaplet/Payments.hs at line 1

[3.9762]→[3.9763:9799](∅→∅)

module Aftok.Snaplet.Payments where

[3.9762]

[3.9799]

module Aftok.Snaplet.Payments
( listPayableRequestsHandler
, getPaymentRequestHandler
, paymentResponseHandler
) where
replacement in server/Aftok/Snaplet/Payments.hs at line 9

[3.5783]→[2.1518:1562](∅→∅),[2.1562]→[3.5835:5919](∅→∅),[3.5835]→[3.5835:5919](∅→∅)

import Control.Lens (view)
import Data.Thyme.Clock as C
import Network.Bippy.Proto as P

[3.5783]

[3.9831]

import Control.Lens (view, _1, _2)
import Data.ProtocolBuffers (decodeMessage)
import Data.Serialize.Get (runGetLazy)
import Data.Thyme.Clock as C
import qualified Network.Bippy.Proto as P
replacement in server/Aftok/Snaplet/Payments.hs at line 15

[3.9832]→[3.5920:5962](∅→∅)

import Snap.Snaplet as S

[3.9832]

[3.5962]

import Snap.Core (readRequestBody)
import Snap.Snaplet as S
edit in server/Aftok/Snaplet/Payments.hs at line 19

[3.5996]

[3.5996]

import Aftok.Database
edit in server/Aftok/Snaplet/Payments.hs at line 21

[3.6028]→[2.1563:1595](∅→∅)

import Aftok.Database
replacement in server/Aftok/Snaplet/Payments.hs at line 33

[3.6408]→[3.6408:6438](∅→∅),[3.6438]→[2.1596:1750](∅→∅)

getPaymentRequestHandler = do
pkBytes <- requireParam "paymentRequestKey"
pkey <- maybe
(snapError 400 $ "parameter paymentRequestKey is formatted incorrectly.") pure

[3.6408]

[2.1750]

getPaymentRequestHandler =
view (_2 . paymentRequest) <$> getPaymentRequestHandler'

paymentResponseHandler :: S.Handler App App PaymentId
paymentResponseHandler = do
requestBody <- readRequestBody 4096
preq <- getPaymentRequestHandler'
pmnt <- either
(\msg -> snapError 400 $ "Could not decode payment response: " <> tshow msg)
pure
(runGetLazy decodeMessage requestBody)
now <- liftIO $ C.getCurrentTime
snapEval . liftdb . CreatePayment $ Payment (view _1 preq) pmnt now

getPaymentRequestHandler' :: S.Handler App App (PaymentRequestId, PaymentRequest)
getPaymentRequestHandler' = do
pkBytes <- requireParam "paymentRequestKey"
pkey <- maybe
(snapError 400 $ "parameter paymentRequestKey is formatted incorrectly.") pure
replacement in server/Aftok/Snaplet/Payments.hs at line 55

[2.1934]→[2.1934:1985](∅→∅),[3.1418]→[3.17952:17953](∅→∅),[2.1985]→[3.17952:17953](∅→∅),[3.6832]→[3.17952:17953](∅→∅),[3.10307]→[3.17952:17953](∅→∅),[3.17953]→[3.5390:5391](∅→∅),[3.5391]→[3.10307:10308](∅→∅),[3.17956]→[3.10307:10308](∅→∅),[3.10307]→[3.10307:10308](∅→∅),[3.10308]→[3.17957:17958](∅→∅)

(pure . view paymentRequest)
prMay

[2.1934]

[3.5392]

pure prMay
edit in server/Aftok/Snaplet/Payments.hs at line 59

[3.6835]→[3.6835:6836](∅→∅)
replacement in server/Main.hs at line 62

[3.8276]→[3.8276:8383](∅→∅)

paymentRequestRoute = writeLBS . runPutLazy . encodeMessage =<< method GET getPaymentRequestHandler

[3.8276]

[3.8383]

paymentRoute = (writeLBS . runPutLazy . encodeMessage =<< method GET getPaymentRequestHandler)
<|> (void $ method POST paymentResponseHandler)
replacement in server/Main.hs at line 88

[3.8473]→[2.2378:2440](∅→∅)

, ("pay/:paymentRequestKey", paymentRequestRoute)

[3.8473]

[3.4299]

, ("pay/:paymentRequestKey", paymentRoute)