@@ -1,229 +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− , VoidRequest(..)
12+ , VoidRequest(..)
8− , voidPayment
13+ , voidPayment
9− , CaptureResponse(..)
14+ , CaptureResponse(..)
10− , capturePayment
16+ , capturePayment
11− , cancelPayment
17+ , cancelPayment
12− , returnPayment
18+ , returnPayment
15−import Control.Exception (throwIO)
16−import Control.Monad (when)
17−import Control.Monad.Except (throwError)
18−import Control.Monad.Reader (asks)
19−import Control.Monad.Writer.Strict
20import Data.Aeson
21import Data.Aeson
21−import Data.Aeson.KeyMap qualified as KeyMap
22−import Data.Aeson.Types (Pair, typeMismatch)
23−import Data.ByteString.Lazy qualified as ByteString
24−import Data.Int (Int32)
27−import Data.Text (Text)
28−import Data.Text qualified as Text
29−import Data.Text.Encoding qualified as Text
30−import GHC.TypeError as TypeError
31−import Network.HTTP.Req
33−import Web.Connexpay.Data
23+import Web.Connexpay.Http
24+import Web.Connexpay.Payments.Types
34import Web.Connexpay.Types
25import Web.Connexpay.Types
35−import Web.Connexpay.Utils
38−-- No 'Show' instance should be made for this type
39−-- in order to avoid sensitive data leaks.
40−data CreditCard = CreditCard { number :: Text -- ^ Credit card number, as 'Text'.
41− , cardholder :: Maybe Text -- ^ Cardholder name, optional.
42− , expiration :: (Word, Word) -- ^ Expiration date (month,year).
43− , cvv :: Maybe Text -- ^ CVC/CVV code.
46−type ShowError = TypeError.Text "CreditCard must not be shown in order to avoid leaking sensitive data"
48−instance TypeError ShowError => Show CreditCard where
49− show = error "UNREACHABLE"
51−instance ToJSON CreditCard where
54− $ do tell ["CardNumber" .= cc.number]
55− whenJust cc.cardholder $ \name ->
56− tell ["CardHolderName" .= name]
57− whenJust cc.cvv $ \cvv ->
59− let expDate = padDate (tshow (snd cc.expiration)) <> padDate (tshow (fst cc.expiration))
60− tell ["ExpirationDate" .= expDate]
62−padDate :: Text -> Text
63−padDate t | Text.length t == 1 = "0" <> t
66−sendRequest' :: HttpResponse resp
67− => Proxy resp -> Text -> (forall scheme. Option scheme) -> [Pair]
69−sendRequest' resp endpoint opts body =
70− do mtok <- bearerToken
73− Nothing -> throwError (ConnectionError $ TokenError "No authentication token available. Check connection parameters?")
75− tls <- asks (.useTLS)
76− let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)
77− headers = auth <> opts
78− url s = s host /: "api" /: "v1" /: endpoint
79− obj <- object <$> addGuid body
80− let jbody = ReqBodyJson obj
82− then reqCb POST (url https) jbody resp headers (logRequest obj)
83− else reqCb POST (url http) jbody resp headers (logRequest obj)
87− do guid <- asks (.deviceGuid)
88− return (b <> [ "DeviceGuid" .= show guid ])
90− do log_ <- asks (.logAction)
91− -- Remove card info from logs
94− | Just c <- KeyMap.lookup "Card" obj -> Object (KeyMap.insert "Card" (replaceCard c) obj)
96− msg = Text.unlines [ "Connexpay request:"
98− , Text.decodeUtf8 (ByteString.toStrict $ encode v')
100− _ <- liftIO (log_ msg)
102− replaceCard (Object c) =
104− $ KeyMap.insert "CardNumber" (String "<REDACTED>")
105− $ KeyMap.insert "Cvv2" (String "<REDACTED>")
109−sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM a
110−sendRequestJson endpoint body = do
111− r <- sendRequest' lbsResponse endpoint accept body
112− let b = responseBody r
114− case eitherDecode b of
116− Left e -> liftIO (throwIO (JsonHttpException e))
118− accept = header "Accept" "application/json"
120−sendRequest_ :: Text -> [Pair] -> ConnexpayM ()
121−sendRequest_ ep body = do
122− r <- sendRequest' lbsResponse ep mempty body
123− let b = responseBody r
126−data AuthResponse = AuthResponse { paymentGuid :: AuthOnlyGuid
127− , status :: TransactionStatus
128− , processorStatusCode :: Maybe Text
129− , processorMessage :: Maybe Text
130− , addressVerificationCode :: Maybe Text
131− , cvvVerificationCode :: Maybe Text
134−instance FromJSON AuthResponse where
135− parseJSON (Object o) = AuthResponse <$> o .: "guid"
137− <*> o .:? "processorStatusCode"
138− <*> o .:? "processorResponseMessage"
139− <*> o .:? "addressVerificationCode"
140− <*> o .:? "cvvVerificationCode"
141− parseJSON v = typeMismatch "AuthReponse" v
143-- | Authorise a credit card payment.
28-- | Authorise a credit card payment.
144−authorisePayment :: CreditCard -- ^ Credit card details (see 'CreditCard')
29+authorisePayment
145− -> Money USD -- ^ Amount to charge, USD
30+ :: Connexpay -> Env -> AuthRequest -> IO (Response AuthError AuthorizeResult)
146− -> Maybe Text -- ^ Invoice description
147− -> Maybe Text -- ^ Merchant description that will appear in a customer's statement.
148− -> ConnexpayM AuthResponse
149−authorisePayment cc amt invoice vendor =
31+authorisePayment connexpay env raw =
150− do rbody <- sendRequestJson "authonlys" body
32+ bimapResponse (guessErrorType guessAuthError) postProcessAuthResponse <$>
151− -- Special case for Connexpay local transaction
33+ doRequest connexpay env "authonlys" RequestBody
152− -- This status means that the transaction was registered,
34+ { raw
153− -- but Connexpay stopped its processing and it won't be
35+ , logMasker = maskAuthRequest
154− -- moved any further.
36+ }
155− -- Also, when I asked Ken from Connexpay about this,
156− -- he told me he had never seen this status before.
157− when (rbody.status == TransactionCreatedLocal) $
158− throwError (PaymentFailure LocalTransaction)
160− where body = execWriter $
161− do tell [ "Card" .= cc ]
162− tell [ "Amount" .= getAmount amt ]
163− whenJust invoice $ \i ->
164− tell [ "OrderNumber" .= i ]
165− whenJust vendor $ \v ->
166− tell [ "StatementDescription" .= v ]
167− -- We are supposed to pass RiskData, but it still
168− -- can be an empty object. Consider population this
169− -- should the need arise.
170− tell [ "RiskData" .= KeyMap.empty @() ]
172−data VoidRequest = VoidAuthorized AuthOnlyGuid
173− | VoidCaptured SaleGuid (Maybe (Money USD))
175-- | Void payment
38-- | Void payment
176−voidPayment :: VoidRequest
39+voidPayment :: Connexpay -> Env -> VoidRequest -> IO (Response () ())
177− -> ConnexpayM ()
40+voidPayment connexpay env raw = doRequest_ connexpay env "void" RequestBody
178−voidPayment (VoidAuthorized pid) = sendRequest_ "void" body
41+ { raw
179− where body = [ "AuthOnlyGuid" .= show pid ]
42+ , logMasker = id
180−voidPayment (VoidCaptured pid amt) = sendRequest_ "void" body
43+ }
181− where body = execWriter $
182− do tell [ "SaleGuid" .= show pid ]
183− whenJust amt $ \m ->
184− tell [ "Amount" .= getAmount m ]
186−-- | Internal data type for Capture requests.
187−data CPTransaction = CPTransaction { expectedPayments :: Int32 }
189−instance ToJSON CPTransaction where
190− toJSON t = object [ "ExpectedPayments" .= t.expectedPayments ]
192−-- | Response for the payment capture request
193−data CaptureResponse = CaptureResponse { captureGuid :: CaptureGuid
194− , saleGuid :: SaleGuid
195− , saleStatus :: TransactionStatus
198−instance FromJSON CaptureResponse where
199− parseJSON (Object o) =
200− do cguid <- o .: "guid"
202− saleGuid <- sale .: "guid"
203− status <- sale .: "status"
204− pure (CaptureResponse cguid saleGuid status)
205− parseJSON v = typeMismatch "CaptureResponse" v
207-- | Capture payment, previously authorised through 'authorisePayment'.
45-- | Capture payment, previously authorised through 'authorisePayment'.
46+capturePayment :: Connexpay
208−capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
48+ -> AuthOnlyGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
209− -> ConnexpayM CaptureResponse
49+ -> IO (Response () CaptureResponse)
210−capturePayment pid = sendRequestJson "Captures" body
50+capturePayment connexpay env pid = doRequest connexpay env "Captures" RequestBody
211− where body = [ "AuthOnlyGuid" .= show pid
52+ [ "AuthOnlyGuid" .= pid
212− , "ConnexPayTransaction" .= CPTransaction 1 ]
53+ , "ConnexPayTransaction" .= CPTransaction 1
214-- | Cancel voided or captured payment.
58-- | Cancel voided or captured payment.
215-- In case of an authorised-only payment, voiding is performed.
59-- In case of an authorised-only payment, voiding is performed.
216-- Otherwise, a payment goes through a refund process.
60-- Otherwise, a payment goes through a refund process.
61+cancelPayment :: Connexpay
217−cancelPayment :: SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
63+ -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
218− -> ConnexpayM ()
64+ -> IO (Response () ())
219−cancelPayment pid = sendRequest_ "cancel" body
65+cancelPayment connexpay env pid = doRequest_ connexpay env "cancel" RequestBody
220− where body = [ "SaleGuid" .= show pid ]
66+ { raw = object [ "SaleGuid" .= pid ]
70+returnPayment :: Connexpay
222−returnPayment :: SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
72+ -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
223− -> Maybe (Money USD)
73+ -> USD
224− -> ConnexpayM ()
74+ -> IO (Response () ())
225−returnPayment pid amt = sendRequest_ "returns" body
75+returnPayment connexpay env pid amt = doRequest_ connexpay env "returns" RequestBody
226− where body = execWriter $
76+ { raw = object
227− do tell [ "SaleGuid" .= show pid ]
77+ [ "SaleGuid" .= pid
228− whenJust amt $ \m ->
229− tell [ "Amount" .= getAmount m ]
78+ , "Amount" .= amt