@@ -1,81 +1,218 @@
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
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
2014
15+import Control.Monad (when,void)
16+import Control.Monad.Except (throwError)
17+import Control.Monad.Reader (asks)
18+import Control.Monad.Writer.Strict
2119import 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
2231
23−import Web.Connexpay.Http
24−import Web.Connexpay.Payments.Types
32+import Web.Connexpay.Data
2533import Web.Connexpay.Types
34+import Web.Connexpay.Utils
2635
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
27128
28129-- | Authorise a credit card payment.
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− }
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))
37160
38161-- | Void payment
39−voidPayment :: Connexpay -> Env -> VoidRequest -> IO (Response () ())
40−voidPayment connexpay env raw = doRequest_ connexpay env "void" RequestBody
41− { raw
42− , logMasker = id
43− }
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
44192
45193-- | Capture payment, previously authorised through 'authorisePayment'.
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− }
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 ]
57202
58203-- | Cancel voided or captured payment.
59204-- In case of an authorised-only payment, voiding is performed.
60205-- Otherwise, a payment goes through a refund process.
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− }
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 ]