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