@@ -1,240 +1,81 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−{-# LANGUAGE UndecidableInstances #-}
1+module Web.Connexpay.Payments
2+ ( AuthRequest(..)
3+ , USD(..)
4+ , CreditCard(..)
5+ , ExpirationDate(..)
6+ , Customer(..)
7+ , RiskData(..)
8+ , AuthorizeResult(..)
9+ , AuthResponse(..)
10+ , TransactionStatus(..)
11+ , authorisePayment
12+ , VoidRequest(..)
13+ , voidPayment
14+ , CaptureResponse(..)
15+ , Sale(..)
16+ , capturePayment
17+ , cancelPayment
18+ , returnPayment
19+ ) where
520
6−module Web.Connexpay.Payments ( CreditCard(..)
7− , AuthRequest(..)
8− , Customer(..)
9− , AuthResponse(..)
10− , authorisePayment
11− , VoidRequest(..)
12− , voidPayment
13− , CaptureResponse(..)
14− , capturePayment
15− , cancelPayment
16− , returnPayment
17− ) where
18−
19−import Control.Monad (when,void)
20−import Control.Monad.Except (throwError)
21−import Control.Monad.Reader (asks)
22−import Control.Monad.Writer.Strict
2321import Data.Aeson
24−import Data.Aeson.KeyMap qualified as KeyMap
25−import Data.Aeson.TH
26−import Data.Aeson.Types (Pair, typeMismatch)
27−import Data.ByteString.Lazy qualified as ByteString
28−import Data.Int (Int32)
29−import Data.Money
30−import Data.Proxy
31−import Data.Text (Text)
32−import Data.Text qualified as Text
33−import Data.Text.Encoding qualified as Text
34−import GHC.TypeError as TypeError
35−import Network.HTTP.Req
3622
37−import Web.Connexpay.Data
23+import Web.Connexpay.Http
24+import Web.Connexpay.Payments.Types
3825import Web.Connexpay.Types
39−import Web.Connexpay.Utils
40−
41−
42−data Customer = Customer { address1 :: Text
43− , address2 :: Maybe Text
44− , zip :: Maybe Text
45− }
46−
47−deriveToJSON defaultOptions
48− { fieldLabelModifier = capitalize
49− , omitNothingFields = True
50− } ''Customer
51−
52−-- | Credit card info
53−-- No 'Show' instance should be made for this type
54−-- in order to avoid sensitive data leaks.
55−data CreditCard = CreditCard { number :: Text -- ^ Credit card number, as 'Text'.
56− , cardholder :: Maybe Text -- ^ Cardholder name, optional.
57− , expiration :: (Word, Word) -- ^ Expiration date (month,year).
58− , cvv :: Maybe Text -- ^ CVC/CVV code.
59− , customer :: Maybe Customer -- ^ Required to get AVS
60− }
61−type ShowError = TypeError.Text "CreditCard must not be shown in order to avoid leaking sensitive data"
62−
63−instance TypeError ShowError => Show CreditCard where
64− show = error "UNREACHABLE"
65−
66−instance ToJSON CreditCard where
67− toJSON cc = object
68− $ execWriter
69− $ do tell ["CardNumber" .= cc.number]
70− whenJust cc.cardholder $ \name ->
71− tell ["CardHolderName" .= name]
72− whenJust cc.cvv $ \cvv ->
73− tell ["Cvv2" .= cvv]
74− let expDate = padDate (tshow (snd cc.expiration)) <> padDate (tshow (fst cc.expiration))
75− tell ["ExpirationDate" .= expDate]
76− whenJust cc.customer $ \customer ->
77− tell [ "Customer" .= customer ]
78−
79−padDate :: Text -> Text
80−padDate t | Text.length t == 1 = "0" <> t
81− | otherwise = t
82−
83−sendRequest' :: HttpResponse resp => Proxy resp -> Text -> [Pair] -> ConnexpayM resp
84−sendRequest' resp endpoint body =
85− do mtok <- bearerToken
86− tok <- case mtok of
87− Just t -> pure t
88− Nothing -> throwError (ConnectionError $ TokenError "No authentication token available. Check connection parameters?")
89− host <- asks (.url)
90− tls <- asks (.useTLS)
91− let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)
92− url s = s host /: "api" /: "v1" /: endpoint
93− obj <- object <$> addGuid body
94− let jbody = ReqBodyJson obj
95− r <- if tls
96− then reqCb POST (url https) jbody resp auth (logRequest obj)
97− else reqCb POST (url http) jbody resp auth (logRequest obj)
98− pure r
99− where
100− addGuid b =
101− do guid <- asks (.deviceGuid)
102− return (b <> [ "DeviceGuid" .= show guid ])
103− logRequest v r =
104− do log_ <- asks (.logAction)
105− -- Remove card info from logs
106− let v' = case v of
107− Object obj
108− | Just c <- KeyMap.lookup "Card" obj -> Object (KeyMap.insert "Card" (replaceCard c) obj)
109− other -> other
110− msg = Text.unlines [ "Connexpay request:"
111− , tshow r
112− , Text.decodeUtf8 (ByteString.toStrict $ encode v')
113− ]
114− _ <- liftIO (log_ msg)
115− return r
116− replaceCard (Object c) =
117− Object
118− $ KeyMap.insert "CardNumber" (String "<REDACTED>")
119− $ KeyMap.insert "Cvv2" (String "<REDACTED>")
120− $ c
121− replaceCard v = v
122−
123−sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a)
124−sendRequestJson = sendRequest' jsonResponse
12526
126−sendRequest_ :: Text -> [Pair] -> ConnexpayM ()
127−sendRequest_ ep = void . sendRequest' ignoreResponse ep
128−
129−data AuthResponse = AuthResponse { paymentGuid :: AuthOnlyGuid
130− , status :: TransactionStatus
131− , processorStatusCode :: Maybe Text
132− , processorMessage :: Maybe Text
133− , addressVerificationCode :: Maybe Text
134− , cvvVerificationCode :: Maybe Text
135− } deriving (Show)
136−
137−instance FromJSON AuthResponse where
138− parseJSON (Object o) = AuthResponse <$> o .: "guid"
139− <*> o .: "status"
140− <*> o .:? "processorStatusCode"
141− <*> o .:? "processorResponseMessage"
142− <*> o .:? "addressVerificationCode"
143− <*> o .:? "cvvVerificationCode"
144− parseJSON v = typeMismatch "AuthReponse" v
145−
146−data AuthRequest = AuthRequest { creditCard :: CreditCard
147− , amount :: Money USD
148− , invoice :: Maybe Text
149− , vendor :: Maybe Text
150− -- ^ Merchant description that will appear in a
151− -- customer's statement.
152− }
15327
15428-- | Authorise a credit card payment.
155−authorisePayment :: AuthRequest
156− -> ConnexpayM AuthResponse
157−authorisePayment request =
158− do resp <- sendRequestJson "authonlys" body
159− let rbody = responseBody resp
160− -- Special case for Connexpay local transaction
161− -- This status means that the transaction was registered,
162− -- but Connexpay stopped its processing and it won't be
163− -- moved any further.
164− -- Also, when I asked Ken from Connexpay about this,
165− -- he told me he had never seen this status before.
166− when (rbody.status == TransactionCreatedLocal) $
167− throwError (PaymentFailure LocalTransaction Nothing)
168− pure rbody
169− where body = execWriter $
170− do tell [ "Card" .= request.creditCard ]
171− tell [ "Amount" .= getAmount request.amount ]
172− whenJust request.invoice $ \i ->
173− tell [ "OrderNumber" .= i ]
174− whenJust request.vendor $ \v ->
175− tell [ "StatementDescription" .= v ]
176− -- We are supposed to pass RiskData, but it still
177− -- can be an empty object. Consider population this
178− -- should the need arise.
179− tell [ "RiskData" .= KeyMap.empty @() ]
180−
181−data VoidRequest = VoidAuthorized AuthOnlyGuid | VoidCaptured SaleGuid (Maybe (Money USD))
29+authorisePayment
30+ :: Connexpay -> Env -> AuthRequest -> IO (Response AuthError AuthorizeResult)
31+authorisePayment connexpay env raw =
32+ bimapResponse (guessErrorType guessAuthError) postProcessAuthResponse <$>
33+ doRequest connexpay env "authonlys" RequestBody
34+ { raw
35+ , logMasker = maskAuthRequest
36+ }
18237
18338-- | Void payment
184−voidPayment :: VoidRequest
185− -> ConnexpayM ()
186−voidPayment (VoidAuthorized pid) = sendRequest_ "void" body
187− where body = [ "AuthOnlyGuid" .= show pid ]
188−voidPayment (VoidCaptured pid amt) = sendRequest_ "void" body
189− where body = execWriter $
190− do tell [ "SaleGuid" .= show pid ]
191− whenJust amt $ \m ->
192− tell [ "Amount" .= getAmount m ]
193−
194−-- | Internal data type for Capture requests.
195−data CPTransaction = CPTransaction { expectedPayments :: Int32 }
196−
197−instance ToJSON CPTransaction where
198− toJSON t = object [ "ExpectedPayments" .= t.expectedPayments ]
199−
200−-- | Response for the payment capture request
201−data CaptureResponse = CaptureResponse { captureGuid :: CaptureGuid
202− , saleGuid :: SaleGuid
203− , saleStatus :: TransactionStatus
204− } deriving (Show)
205−
206−instance FromJSON CaptureResponse where
207− parseJSON (Object o) =
208− do cguid <- o .: "guid"
209− sale <- o .: "sale"
210− saleGuid <- sale .: "guid"
211− status <- sale .: "status"
212− pure (CaptureResponse cguid saleGuid status)
213− parseJSON v = typeMismatch "CaptureResponse" v
39+voidPayment :: Connexpay -> Env -> VoidRequest -> IO (Response () ())
40+voidPayment connexpay env raw = doRequest_ connexpay env "void" RequestBody
41+ { raw
42+ , logMasker = id
43+ }
21444
21545-- | Capture payment, previously authorised through 'authorisePayment'.
216−capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
217− -> ConnexpayM CaptureResponse
218−capturePayment pid =
219− do resp <- sendRequestJson "Captures" body
220− let rbody = responseBody resp
221− pure rbody
222− where body = [ "AuthOnlyGuid" .= show pid
223− , "ConnexPayTransaction" .= CPTransaction 1 ]
46+capturePayment :: Connexpay
47+ -> Env
48+ -> AuthOnlyGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
49+ -> IO (Response () CaptureResponse)
50+capturePayment connexpay env pid = doRequest connexpay env "Captures" RequestBody
51+ { raw = object
52+ [ "AuthOnlyGuid" .= pid
53+ , "ConnexPayTransaction" .= CPTransaction 1
54+ ]
55+ , logMasker = id
56+ }
22457
22558-- | Cancel voided or captured payment.
22659-- In case of an authorised-only payment, voiding is performed.
22760-- Otherwise, a payment goes through a refund process.
228−cancelPayment :: SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
229− -> ConnexpayM ()
230−cancelPayment pid = sendRequest_ "cancel" body
231− where body = [ "SaleGuid" .= show pid ]
232−
233−returnPayment :: SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
234− -> Maybe (Money USD)
235− -> ConnexpayM ()
236−returnPayment pid amt = sendRequest_ "returns" body
237− where body = execWriter $
238− do tell [ "SaleGuid" .= show pid ]
239− whenJust amt $ \m ->
240− tell [ "Amount" .= getAmount m ]
61+cancelPayment :: Connexpay
62+ -> Env
63+ -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
64+ -> IO (Response () ())
65+cancelPayment connexpay env pid = doRequest_ connexpay env "cancel" RequestBody
66+ { raw = object [ "SaleGuid" .= pid ]
67+ , logMasker = id
68+ }
69+
70+returnPayment :: Connexpay
71+ -> Env
72+ -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
73+ -> USD
74+ -> IO (Response () ())
75+returnPayment connexpay env pid amt = doRequest_ connexpay env "returns" RequestBody
76+ { raw = object
77+ [ "SaleGuid" .= pid
78+ , "Amount" .= amt
79+ ]
80+ , logMasker = id
81+ }