@@ -1,197 +1,81 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE UndecidableInstances #-}
4−module Web.Connexpay.Payments ( CreditCard(..)
1+module Web.Connexpay.Payments
5− , AuthResponse(..)
9+ , AuthResponse(..)
10+ , TransactionStatus(..)
6− , authorisePayment
11+ , authorisePayment
7− , voidPayment
13+ , voidPayment
8− , CaptureResponse(..)
14+ , CaptureResponse(..)
9− , capturePayment
16+ , capturePayment
10− , cancelPayment
17+ , cancelPayment
13−import Control.Monad (when,void)
14−import Control.Monad.Except (throwError)
15−import Control.Monad.Reader (asks)
16−import Control.Monad.Writer.Strict
17import Data.Aeson
21import Data.Aeson
18−import Data.Aeson.KeyMap qualified as KeyMap
19−import Data.Aeson.Types (Pair, typeMismatch)
20−import Data.ByteString.Lazy qualified as ByteString
21−import Data.Int (Int32)
24−import Data.Text (Text)
25−import Data.Text qualified as Text
26−import Data.Text.Encoding qualified as Text
27−import GHC.TypeError as TypeError
28−import Network.HTTP.Req
30−import Web.Connexpay.Data
23+import Web.Connexpay.Http
24+import Web.Connexpay.Payments.Types
31import Web.Connexpay.Types
25import Web.Connexpay.Types
32−import Web.Connexpay.Utils
35−-- No 'Show' instance should be made for this type
36−-- in order to avoid sensitive data leaks.
37−data CreditCard = CreditCard { number :: Text -- ^ Credit card number, as 'Text'.
38− , cardholder :: Maybe Text -- ^ Cardholder name, optional.
39− , expiration :: (Word, Word) -- ^ Expiration date (month,year).
40− , cvv :: Maybe Text -- ^ CVC/CVV code.
43−type ShowError = TypeError.Text "CreditCard must not be shown in order to avoid leaking sensitive data"
45−instance TypeError ShowError => Show CreditCard where
46− show = error "UNREACHABLE"
48−instance ToJSON CreditCard where
51− $ do tell ["CardNumber" .= cc.number]
52− whenJust cc.cardholder $ \name ->
53− tell ["CardHolderName" .= name]
54− whenJust cc.cvv $ \cvv ->
56− let expDate = padDate (tshow (snd cc.expiration)) <> padDate (tshow (fst cc.expiration))
57− tell ["ExpirationDate" .= expDate]
59−padDate :: Text -> Text
60−padDate t | Text.length t == 1 = "0" <> t
63−sendRequest' :: HttpResponse resp => Proxy resp -> Text -> [Pair] -> ConnexpayM resp
64−sendRequest' resp endpoint body =
65− do tok <- bearerToken
67− tls <- asks (.useTLS)
68− let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)
69− url s = s host /: "api" /: "v1" /: endpoint
70− obj <- object <$> addGuid body
71− let jbody = ReqBodyJson obj
73− then reqCb POST (url https) jbody resp auth (logRequest obj)
74− else reqCb POST (url http) jbody resp auth (logRequest obj)
79− do guid <- asks (.deviceGuid)
80− return (b <> [ "DeviceGuid" .= show guid ])
82− do log_ <- asks (.logAction)
83− -- Remove card info from logs
86− | Just c <- KeyMap.lookup "Card" obj -> Object (KeyMap.insert "Card" (replaceCard c) obj)
88− msg = Text.unlines [ "Connexpay request:"
90− , Text.decodeUtf8 (ByteString.toStrict $ encode v')
92− _ <- liftIO (log_ msg)
94− replaceCard (Object c) =
96− $ KeyMap.insert "CardNumber" (String "<REDACTED>")
97− $ KeyMap.insert "Cvv2" (String "<REDACTED>")
101−sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a)
102−sendRequestJson = sendRequest' jsonResponse
104−sendRequest_ :: Text -> [Pair] -> ConnexpayM ()
105−sendRequest_ ep = void . sendRequest' ignoreResponse ep
107−data AuthResponse = AuthResponse { paymentGuid :: SaleGuid
108− , status :: TransactionStatus
109− , processorStatusCode :: Maybe Text
110− , processorMessage :: Maybe Text
113−instance FromJSON AuthResponse where
114− parseJSON (Object o) = AuthResponse <$> o .: "guid"
116− <*> o .:? "processorStatusCode"
117− <*> o .:? "processorResponseMessage"
118− parseJSON v = typeMismatch "AuthReponse" v
120-- | Authorise a credit card payment.
28-- | Authorise a credit card payment.
121−authorisePayment :: CreditCard -- ^ Credit card details (see 'CreditCard')
29+authorisePayment
122− -> Money USD -- ^ Amount to charge, USD
30+ :: Connexpay -> Env -> AuthRequest -> IO (Response AuthError AuthorizeResult)
123− -> Maybe Text -- ^ Invoice description
124− -> Maybe Text -- ^ Merchant description that will appear in a customer's statement.
125− -> ConnexpayM AuthResponse
126−authorisePayment cc amt invoice vendor =
31+authorisePayment connexpay env raw =
127− do resp <- sendRequestJson "authonlys" body
32+ bimapResponse (guessErrorType guessAuthError) postProcessAuthResponse <$>
128− let rbody = responseBody resp
33+ doRequest connexpay env "authonlys" RequestBody
129− -- Special case for Connexpay local transaction
34+ { raw
130− -- This status means that the transaction was registered,
35+ , logMasker = maskAuthRequest
131− -- but Connexpay stopped its processing and it won't be
36+ }
132− -- moved any further.
133− -- Also, when I asked Ken from Connexpay about this,
134− -- he told me he had never seen this status before.
135− when (rbody.status == TransactionCreatedLocal) $
136− throwError (PaymentFailure LocalTransaction)
138− where body = execWriter $
139− do tell [ "Card" .= cc ]
140− tell [ "Amount" .= getAmount amt ]
141− whenJust invoice $ \i ->
142− tell [ "OrderNumber" .= i ]
143− whenJust vendor $ \v ->
144− tell [ "StatementDescription" .= v ]
145− -- We are supposed to pass RiskData, but it still
146− -- can be an empty object. Consider population this
147− -- should the need arise.
148− tell [ "RiskData" .= KeyMap.empty @() ]
150-- | Void payment
38-- | Void payment
151−voidPayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
39+voidPayment :: Connexpay -> Env -> VoidRequest -> IO (Response () ())
152− -> Maybe (Money USD) -- ^ Optionally, you may only void a partial sum, with the rest being subsequently charged.
40+voidPayment connexpay env raw = doRequest_ connexpay env "void" RequestBody
153− -> ConnexpayM ()
41+ { raw
154−voidPayment pid amt = sendRequest_ "void" body
42+ , logMasker = id
155− where body = execWriter $
43+ }
156− do tell [ "AuthOnlyGuid" .= show pid ]
157− whenJust amt $ \m ->
158− tell [ "Amount" .= getAmount m ]
160−-- | Internal data type for Capture requests.
161−data CPTransaction = CPTransaction { expectedPayments :: Int32 }
163−instance ToJSON CPTransaction where
164− toJSON t = object [ "ExpectedPayments" .= t.expectedPayments ]
166−-- | Response for the payment capture request
167−data CaptureResponse = CaptureResponse { captureGuid :: CaptureGuid
168− , saleGuid :: SaleGuid
169− , saleStatus :: TransactionStatus
172−instance FromJSON CaptureResponse where
173− parseJSON (Object o) =
174− do cguid <- o .: "guid"
176− saleGuid <- sale .: "guid"
177− status <- sale .: "status"
178− pure (CaptureResponse cguid saleGuid status)
179− parseJSON v = typeMismatch "CaptureResponse" v
181-- | Capture payment, previously authorised through 'authorisePayment'.
45-- | Capture payment, previously authorised through 'authorisePayment'.
46+capturePayment :: Connexpay
182−capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
48+ -> AuthOnlyGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
183− -> ConnexpayM CaptureResponse
49+ -> IO (Response () CaptureResponse)
184−capturePayment pid =
50+capturePayment connexpay env pid = doRequest connexpay env "Captures" RequestBody
185− do resp <- sendRequestJson "Captures" body
51+ { raw = object
186− let rbody = responseBody resp
188− where body = [ "AuthOnlyGuid" .= show pid
52+ [ "AuthOnlyGuid" .= pid
189− , "ConnexPayTransaction" .= CPTransaction 1 ]
53+ , "ConnexPayTransaction" .= CPTransaction 1
191-- | Cancel voided or captured payment.
58-- | Cancel voided or captured payment.
192-- In case of an authorised-only payment, voiding is performed.
59-- In case of an authorised-only payment, voiding is performed.
193-- Otherwise, a payment goes through a refund process.
60-- Otherwise, a payment goes through a refund process.
61+cancelPayment :: Connexpay
194−cancelPayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
63+ -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
195− -> ConnexpayM ()
64+ -> IO (Response () ())
196−cancelPayment pid = sendRequest_ "cancel" body
65+cancelPayment connexpay env pid = doRequest_ connexpay env "cancel" RequestBody
197− where body = [ "SaleGuid" .= show pid ]
66+ { raw = object [ "SaleGuid" .= pid ]
70+returnPayment :: Connexpay
72+ -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
74+ -> IO (Response () ())
75+returnPayment connexpay env pid amt = doRequest_ connexpay env "returns" RequestBody