@@ -12,7 +12,8 @@ module Web.Connexpay.Payments ( CreditCard(..)
1212 , returnPayment
1313 ) where
1414
15−import Control.Monad (when,void)
15+import Control.Exception (throwIO)
16+import Control.Monad (when)
1617import Control.Monad.Except (throwError)
1718import Control.Monad.Reader (asks)
1819import Control.Monad.Writer.Strict
@@ -62,8 +63,10 @@ padDate :: Text -> Text
6263padDate t | Text.length t == 1 = "0" <> t
6364 | otherwise = t
6465
65−sendRequest' :: HttpResponse resp => Proxy resp -> Text -> [Pair] -> ConnexpayM resp
66−sendRequest' resp endpoint body =
66+sendRequest' :: HttpResponse resp
67+ => Proxy resp -> Text -> (forall scheme. Option scheme) -> [Pair]
68+ -> ConnexpayM resp
69+sendRequest' resp endpoint opts body =
6770 do mtok <- bearerToken
6871 tok <- case mtok of
6972 Just t -> pure t
@@ -71,13 +74,13 @@ sendRequest' resp endpoint body =
7174 host <- asks (.url)
7275 tls <- asks (.useTLS)
7376 let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)
77+ headers = auth <> opts
7478 url s = s host /: "api" /: "v1" /: endpoint
7579 obj <- object <$> addGuid body
7680 let jbody = ReqBodyJson obj
7781 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
82+ then reqCb POST (url https) jbody resp headers (logRequest obj)
83+ else reqCb POST (url http) jbody resp headers (logRequest obj)
8184 pure r
8285 where
8386 addGuid b =
@@ -103,11 +106,21 @@ sendRequest' resp endpoint body =
103106 $ c
104107 replaceCard v = v
105108
106−sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a)
107−sendRequestJson = sendRequest' jsonResponse
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"
108119
109120sendRequest_ :: Text -> [Pair] -> ConnexpayM ()
110−sendRequest_ ep = void . sendRequest' ignoreResponse ep
121+sendRequest_ ep body = do
122+ r <- sendRequest' ignoreResponse ep mempty body
123+ logResponse r
111124
112125data AuthResponse = AuthResponse { paymentGuid :: AuthOnlyGuid
113126 , status :: TransactionStatus
@@ -133,8 +146,7 @@ authorisePayment :: CreditCard -- ^ Credit card details (see 'CreditCard')
133146 -> Maybe Text -- ^ Merchant description that will appear in a customer's statement.
134147 -> ConnexpayM AuthResponse
135148authorisePayment cc amt invoice vendor =
136− do resp <- sendRequestJson "authonlys" body
137− let rbody = responseBody resp
149+ do rbody <- sendRequestJson "authonlys" body
138150 -- Special case for Connexpay local transaction
139151 -- This status means that the transaction was registered,
140152 -- but Connexpay stopped its processing and it won't be
@@ -156,7 +168,8 @@ authorisePayment cc amt invoice vendor =
156168 -- should the need arise.
157169 tell [ "RiskData" .= KeyMap.empty @() ]
158170
159−data VoidRequest = VoidAuthorized AuthOnlyGuid | VoidCaptured SaleGuid (Maybe (Money USD))
171+data VoidRequest = VoidAuthorized AuthOnlyGuid
172+ | VoidCaptured SaleGuid (Maybe (Money USD))
160173
161174-- | Void payment
162175voidPayment :: VoidRequest
@@ -193,10 +206,7 @@ instance FromJSON CaptureResponse where
193206-- | Capture payment, previously authorised through 'authorisePayment'.
194207capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
195208 -> ConnexpayM CaptureResponse
196−capturePayment pid =
197− do resp <- sendRequestJson "Captures" body
198− let rbody = responseBody resp
199− pure rbody
209+capturePayment pid = sendRequestJson "Captures" body
200210 where body = [ "AuthOnlyGuid" .= show pid
201211 , "ConnexPayTransaction" .= CPTransaction 1 ]
202212