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