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