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