git.iko.soy/typeable/connexpay
on master help sign in
Log responses
f90fcffNick
connexpay/src/Web/Connexpay/Payments.hs+26−16
compare with master
unifiedsplit
@@ -12,7 +12,8 @@ module Web.Connexpay.Payments ( CreditCard(..)
12 , returnPayment
12 , returnPayment
13 ) where
13 ) where
14
14
15−import Control.Monad (when,void)
15+import Control.Exception (throwIO)
16+import Control.Monad (when)
16import Control.Monad.Except (throwError)
17import Control.Monad.Except (throwError)
17import Control.Monad.Reader (asks)
18import Control.Monad.Reader (asks)
18import Control.Monad.Writer.Strict
19import Control.Monad.Writer.Strict
@@ -62,8 +63,10 @@ padDate :: Text -> Text
62padDate t | Text.length t == 1 = "0" <> t
63padDate t | Text.length t == 1 = "0" <> t
63 | otherwise = t
64 | otherwise = t
64
65
65−sendRequest' :: HttpResponse resp => Proxy resp -> Text -> [Pair] -> ConnexpayM resp
66+sendRequest' :: HttpResponse resp
67+ => Proxy resp -> Text -> (forall scheme. Option scheme) -> [Pair]
68+ -> ConnexpayM resp
66−sendRequest' resp endpoint body =
69+sendRequest' resp endpoint opts body =
67 do mtok <- bearerToken
70 do mtok <- bearerToken
68 tok <- case mtok of
71 tok <- case mtok of
69 Just t -> pure t
72 Just t -> pure t
@@ -71,13 +74,13 @@ sendRequest' resp endpoint body =
71 host <- asks (.url)
74 host <- asks (.url)
72 tls <- asks (.useTLS)
75 tls <- asks (.useTLS)
73 let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)
76 let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)
77+ headers = auth <> opts
74 url s = s host /: "api" /: "v1" /: endpoint
78 url s = s host /: "api" /: "v1" /: endpoint
75 obj <- object <$> addGuid body
79 obj <- object <$> addGuid body
76 let jbody = ReqBodyJson obj
80 let jbody = ReqBodyJson obj
77 r <- if tls
81 r <- if tls
78− then reqCb POST (url https) jbody resp auth (logRequest obj)
82+ then reqCb POST (url https) jbody resp headers (logRequest obj)
79− else reqCb POST (url http) jbody resp auth (logRequest obj)
83+ else reqCb POST (url http) jbody resp headers (logRequest obj)
80− logResponse r
81 pure r
84 pure r
82 where
85 where
83 addGuid b =
86 addGuid b =
@@ -103,11 +106,21 @@ sendRequest' resp endpoint body =
103 $ c
106 $ c
104 replaceCard v = v
107 replaceCard v = v
105
108
106−sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a)
109+sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM a
107−sendRequestJson = sendRequest' jsonResponse
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"
108
119
109sendRequest_ :: Text -> [Pair] -> ConnexpayM ()
120sendRequest_ :: Text -> [Pair] -> ConnexpayM ()
121+sendRequest_ ep body = do
110−sendRequest_ ep = void . sendRequest' ignoreResponse ep
122+ r <- sendRequest' ignoreResponse ep mempty body
123+ logResponse r
111
124
112data AuthResponse = AuthResponse { paymentGuid :: AuthOnlyGuid
125data AuthResponse = AuthResponse { paymentGuid :: AuthOnlyGuid
113 , status :: TransactionStatus
126 , status :: TransactionStatus
@@ -133,8 +146,7 @@ authorisePayment :: CreditCard -- ^ Credit card details (see 'CreditCard')
133 -> Maybe Text -- ^ Merchant description that will appear in a customer's statement.
146 -> Maybe Text -- ^ Merchant description that will appear in a customer's statement.
134 -> ConnexpayM AuthResponse
147 -> ConnexpayM AuthResponse
135authorisePayment cc amt invoice vendor =
148authorisePayment cc amt invoice vendor =
136− do resp <- sendRequestJson "authonlys" body
149+ do rbody <- sendRequestJson "authonlys" body
137− let rbody = responseBody resp
138 -- Special case for Connexpay local transaction
150 -- Special case for Connexpay local transaction
139 -- This status means that the transaction was registered,
151 -- This status means that the transaction was registered,
140 -- but Connexpay stopped its processing and it won't be
152 -- but Connexpay stopped its processing and it won't be
@@ -156,7 +168,8 @@ authorisePayment cc amt invoice vendor =
156 -- should the need arise.
168 -- should the need arise.
157 tell [ "RiskData" .= KeyMap.empty @() ]
169 tell [ "RiskData" .= KeyMap.empty @() ]
158
170
159−data VoidRequest = VoidAuthorized AuthOnlyGuid | VoidCaptured SaleGuid (Maybe (Money USD))
171+data VoidRequest = VoidAuthorized AuthOnlyGuid
172+ | VoidCaptured SaleGuid (Maybe (Money USD))
160
173
161-- | Void payment
174-- | Void payment
162voidPayment :: VoidRequest
175voidPayment :: VoidRequest
@@ -193,10 +206,7 @@ instance FromJSON CaptureResponse where
193-- | Capture payment, previously authorised through 'authorisePayment'.
206-- | Capture payment, previously authorised through 'authorisePayment'.
194capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
207capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
195 -> ConnexpayM CaptureResponse
208 -> ConnexpayM CaptureResponse
196−capturePayment pid =
197− do resp <- sendRequestJson "Captures" body
209+capturePayment pid = sendRequestJson "Captures" body
198− let rbody = responseBody resp
199− pure rbody
200 where body = [ "AuthOnlyGuid" .= show pid
210 where body = [ "AuthOnlyGuid" .= show pid
201 , "ConnexPayTransaction" .= CPTransaction 1 ]
211 , "ConnexPayTransaction" .= CPTransaction 1 ]
202
212
connexpay/src/Web/Connexpay/Types.hs+12−1
@@ -10,10 +10,11 @@ import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError)
10import Control.Monad.IO.Class
10import Control.Monad.IO.Class
11import Control.Monad.Reader
11import Control.Monad.Reader
12import Data.Aeson
12import Data.Aeson
13+import Data.ByteString.Lazy (ByteString)
13import Data.Text (Text)
14import Data.Text (Text)
14import Data.Text qualified as Text
15import Data.Text qualified as Text
15import Data.UUID (UUID)
16import Data.UUID (UUID)
16−import Network.HTTP.Client hiding (responseHeaders)
17+import Network.HTTP.Client hiding (responseBody, responseHeaders)
17import Network.HTTP.Req
18import Network.HTTP.Req
18import Network.HTTP.Types
19import Network.HTTP.Types
19
20
@@ -70,3 +71,13 @@ logResponse r =
70 , "HTTP code: " <> tshow (responseCode r)
71 , "HTTP code: " <> tshow (responseCode r)
71 , "Headers: " <> tshow (responseHeaders r)
72 , "Headers: " <> tshow (responseHeaders r)
72 ]
73 ]
74+
75+logResponseBody :: HttpResponse resp => resp -> ByteString -> ConnexpayM ()
76+logResponseBody r body =
77+ do log_ <- asks (.logAction)
78+ liftIO (log_ msg)
79+ where msg = Text.unlines [ "Connexpay response:"
80+ , "HTTP code: " <> tshow (responseCode r)
81+ , "Headers: " <> tshow (responseHeaders r)
82+ , "Body: " <> tshow body
83+ ]