@@ -1,81 +1,211 @@
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 tok <- bearerToken
68+ host <- asks (.url)
69+ tls <- asks (.useTLS)
70+ let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)
71+ url s = s host /: "api" /: "v1" /: endpoint
72+ obj <- object <$> addGuid body
73+ let jbody = ReqBodyJson obj
74+ r <- if tls
75+ then reqCb POST (url https) jbody resp auth (logRequest obj)
76+ else reqCb POST (url http) jbody resp auth (logRequest obj)
77+ logResponse r
78+ pure r
79+ where
80+ addGuid b =
81+ do guid <- asks (.deviceGuid)
82+ return (b <> [ "DeviceGuid" .= show guid ])
83+ logRequest v r =
84+ do log_ <- asks (.logAction)
85+ -- Remove card info from logs
86+ let v' = case v of
87+ Object obj
88+ | Just c <- KeyMap.lookup "Card" obj -> Object (KeyMap.insert "Card" (replaceCard c) obj)
89+ other -> other
90+ msg = Text.unlines [ "Connexpay request:"
91+ , tshow r
92+ , Text.decodeUtf8 (ByteString.toStrict $ encode v')
93+ ]
94+ _ <- liftIO (log_ msg)
95+ return r
96+ replaceCard (Object c) =
97+ Object
98+ $ KeyMap.insert "CardNumber" (String "<REDACTED>")
99+ $ KeyMap.insert "Cvv2" (String "<REDACTED>")
100+ $ c
101+ replaceCard v = v
102+
103+sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a)
104+sendRequestJson = sendRequest' jsonResponse
105+
106+sendRequest_ :: Text -> [Pair] -> ConnexpayM ()
107+sendRequest_ ep = void . sendRequest' ignoreResponse ep
108+
109+data AuthResponse = AuthResponse { paymentGuid :: AuthOnlyGuid
110+ , status :: TransactionStatus
111+ , processorStatusCode :: Maybe Text
112+ , processorMessage :: Maybe Text
113+ } deriving (Show)
114+
115+instance FromJSON AuthResponse where
116+ parseJSON (Object o) = AuthResponse <$> o .: "guid"
117+ <*> o .: "status"
118+ <*> o .:? "processorStatusCode"
119+ <*> o .:? "processorResponseMessage"
120+ parseJSON v = typeMismatch "AuthReponse" v
27121
28122-- | 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− }
123+authorisePayment :: CreditCard -- ^ Credit card details (see 'CreditCard')
124+ -> Money USD -- ^ Amount to charge, USD
125+ -> Maybe Text -- ^ Invoice description
126+ -> Maybe Text -- ^ Merchant description that will appear in a customer's statement.
127+ -> ConnexpayM AuthResponse
128+authorisePayment cc amt invoice vendor =
129+ do resp <- sendRequestJson "authonlys" body
130+ let rbody = responseBody resp
131+ -- Special case for Connexpay local transaction
132+ -- This status means that the transaction was registered,
133+ -- but Connexpay stopped its processing and it won't be
134+ -- moved any further.
135+ -- Also, when I asked Ken from Connexpay about this,
136+ -- he told me he had never seen this status before.
137+ when (rbody.status == TransactionCreatedLocal) $
138+ throwError (PaymentFailure LocalTransaction)
139+ pure rbody
140+ where body = execWriter $
141+ do tell [ "Card" .= cc ]
142+ tell [ "Amount" .= getAmount amt ]
143+ whenJust invoice $ \i ->
144+ tell [ "OrderNumber" .= i ]
145+ whenJust vendor $ \v ->
146+ tell [ "StatementDescription" .= v ]
147+ -- We are supposed to pass RiskData, but it still
148+ -- can be an empty object. Consider population this
149+ -- should the need arise.
150+ tell [ "RiskData" .= KeyMap.empty @() ]
151+
152+data VoidRequest = VoidAuthorized AuthOnlyGuid | VoidCaptured SaleGuid (Maybe (Money USD))
37153
38154-- | 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− }
155+voidPayment :: VoidRequest
156+ -> ConnexpayM ()
157+voidPayment (VoidAuthorized pid) = sendRequest_ "void" body
158+ where body = [ "AuthOnlyGuid" .= show pid ]
159+voidPayment (VoidCaptured pid amt) = sendRequest_ "void" body
160+ where body = execWriter $
161+ do tell [ "SaleGuid" .= show pid ]
162+ whenJust amt $ \m ->
163+ tell [ "Amount" .= getAmount m ]
164+
165+-- | Internal data type for Capture requests.
166+data CPTransaction = CPTransaction { expectedPayments :: Int32 }
167+
168+instance ToJSON CPTransaction where
169+ toJSON t = object [ "ExpectedPayments" .= t.expectedPayments ]
170+
171+-- | Response for the payment capture request
172+data CaptureResponse = CaptureResponse { captureGuid :: CaptureGuid
173+ , saleGuid :: SaleGuid
174+ , saleStatus :: TransactionStatus
175+ } deriving (Show)
176+
177+instance FromJSON CaptureResponse where
178+ parseJSON (Object o) =
179+ do cguid <- o .: "guid"
180+ sale <- o .: "sale"
181+ saleGuid <- sale .: "guid"
182+ status <- sale .: "status"
183+ pure (CaptureResponse cguid saleGuid status)
184+ parseJSON v = typeMismatch "CaptureResponse" v
44185
45186-- | 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− }
187+capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
188+ -> ConnexpayM CaptureResponse
189+capturePayment pid =
190+ do resp <- sendRequestJson "Captures" body
191+ let rbody = responseBody resp
192+ pure rbody
193+ where body = [ "AuthOnlyGuid" .= show pid
194+ , "ConnexPayTransaction" .= CPTransaction 1 ]
57195
58196-- | Cancel voided or captured payment.
59197-- In case of an authorised-only payment, voiding is performed.
60198-- 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− }
199+cancelPayment :: SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
200+ -> ConnexpayM ()
201+cancelPayment pid = sendRequest_ "cancel" body
202+ where body = [ "SaleGuid" .= show pid ]
203+
204+returnPayment :: SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
205+ -> Maybe (Money USD)
206+ -> ConnexpayM ()
207+returnPayment pid amt = sendRequest_ "returns" body
208+ where body = execWriter $
209+ do tell [ "SaleGuid" .= show pid ]
210+ whenJust amt $ \m ->
211+ tell [ "Amount" .= getAmount m ]