From f90fcff5fc078f2313b927511632a4eb4491f6af Mon Sep 17 00:00:00 2001 From: Nick Date: Tue, 1 Apr 2025 12:24:58 +0000 Subject: [PATCH 1/5] Log responses --- connexpay/src/Web/Connexpay/Payments.hs | 42 +++++++++++++++---------- connexpay/src/Web/Connexpay/Types.hs | 13 +++++++- 2 files changed, 38 insertions(+), 17 deletions(-) diff --git a/connexpay/src/Web/Connexpay/Payments.hs b/connexpay/src/Web/Connexpay/Payments.hs index 2c9dee6..1f92561 100644 --- a/connexpay/src/Web/Connexpay/Payments.hs +++ b/connexpay/src/Web/Connexpay/Payments.hs @@ -12,7 +12,8 @@ module Web.Connexpay.Payments ( CreditCard(..) , returnPayment ) where -import Control.Monad (when,void) +import Control.Exception (throwIO) +import Control.Monad (when) import Control.Monad.Except (throwError) import Control.Monad.Reader (asks) import Control.Monad.Writer.Strict @@ -62,8 +63,10 @@ padDate :: Text -> Text padDate t | Text.length t == 1 = "0" <> t | otherwise = t -sendRequest' :: HttpResponse resp => Proxy resp -> Text -> [Pair] -> ConnexpayM resp -sendRequest' resp endpoint body = +sendRequest' :: HttpResponse resp + => Proxy resp -> Text -> (forall scheme. Option scheme) -> [Pair] + -> ConnexpayM resp +sendRequest' resp endpoint opts body = do mtok <- bearerToken tok <- case mtok of Just t -> pure t @@ -71,13 +74,13 @@ sendRequest' resp endpoint body = host <- asks (.url) tls <- asks (.useTLS) let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok) + headers = auth <> opts url s = s host /: "api" /: "v1" /: endpoint obj <- object <$> addGuid body let jbody = ReqBodyJson obj r <- if tls - then reqCb POST (url https) jbody resp auth (logRequest obj) - else reqCb POST (url http) jbody resp auth (logRequest obj) - logResponse r + then reqCb POST (url https) jbody resp headers (logRequest obj) + else reqCb POST (url http) jbody resp headers (logRequest obj) pure r where addGuid b = @@ -103,11 +106,21 @@ sendRequest' resp endpoint body = $ c replaceCard v = v -sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a) -sendRequestJson = sendRequest' jsonResponse +sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM a +sendRequestJson endpoint body = do + r <- sendRequest' lbsResponse endpoint accept body + let b = responseBody r + logResponseBody r b + case eitherDecode b of + Right x -> return x + Left e -> liftIO (throwIO (JsonHttpException e)) + where + accept = header "Accept" "application/json" sendRequest_ :: Text -> [Pair] -> ConnexpayM () -sendRequest_ ep = void . sendRequest' ignoreResponse ep +sendRequest_ ep body = do + r <- sendRequest' ignoreResponse ep mempty body + logResponse r data AuthResponse = AuthResponse { paymentGuid :: AuthOnlyGuid , status :: TransactionStatus @@ -133,8 +146,7 @@ authorisePayment :: CreditCard -- ^ Credit card details (see 'CreditCard') -> Maybe Text -- ^ Merchant description that will appear in a customer's statement. -> ConnexpayM AuthResponse authorisePayment cc amt invoice vendor = - do resp <- sendRequestJson "authonlys" body - let rbody = responseBody resp + do rbody <- sendRequestJson "authonlys" body -- Special case for Connexpay local transaction -- This status means that the transaction was registered, -- but Connexpay stopped its processing and it won't be @@ -156,7 +168,8 @@ authorisePayment cc amt invoice vendor = -- should the need arise. tell [ "RiskData" .= KeyMap.empty @() ] -data VoidRequest = VoidAuthorized AuthOnlyGuid | VoidCaptured SaleGuid (Maybe (Money USD)) +data VoidRequest = VoidAuthorized AuthOnlyGuid + | VoidCaptured SaleGuid (Maybe (Money USD)) -- | Void payment voidPayment :: VoidRequest @@ -193,10 +206,7 @@ instance FromJSON CaptureResponse where -- | Capture payment, previously authorised through 'authorisePayment'. capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'. -> ConnexpayM CaptureResponse -capturePayment pid = - do resp <- sendRequestJson "Captures" body - let rbody = responseBody resp - pure rbody +capturePayment pid = sendRequestJson "Captures" body where body = [ "AuthOnlyGuid" .= show pid , "ConnexPayTransaction" .= CPTransaction 1 ] diff --git a/connexpay/src/Web/Connexpay/Types.hs b/connexpay/src/Web/Connexpay/Types.hs index 6564901..078eaba 100644 --- a/connexpay/src/Web/Connexpay/Types.hs +++ b/connexpay/src/Web/Connexpay/Types.hs @@ -10,10 +10,11 @@ import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError) import Control.Monad.IO.Class import Control.Monad.Reader import Data.Aeson +import Data.ByteString.Lazy (ByteString) import Data.Text (Text) import Data.Text qualified as Text import Data.UUID (UUID) -import Network.HTTP.Client hiding (responseHeaders) +import Network.HTTP.Client hiding (responseBody, responseHeaders) import Network.HTTP.Req import Network.HTTP.Types @@ -70,3 +71,13 @@ logResponse r = , "HTTP code: " <> tshow (responseCode r) , "Headers: " <> tshow (responseHeaders r) ] + +logResponseBody :: HttpResponse resp => resp -> ByteString -> ConnexpayM () +logResponseBody r body = + do log_ <- asks (.logAction) + liftIO (log_ msg) + where msg = Text.unlines [ "Connexpay response:" + , "HTTP code: " <> tshow (responseCode r) + , "Headers: " <> tshow (responseHeaders r) + , "Body: " <> tshow body + ] From 5340ff52f7020fff12b38c0fb312a190de4b2b53 Mon Sep 17 00:00:00 2001 From: Nick Date: Tue, 1 Apr 2025 12:34:50 +0000 Subject: [PATCH 2/5] Log response body even if response is ignored. --- connexpay/src/Web/Connexpay/Payments.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/connexpay/src/Web/Connexpay/Payments.hs b/connexpay/src/Web/Connexpay/Payments.hs index 1f92561..af93da3 100644 --- a/connexpay/src/Web/Connexpay/Payments.hs +++ b/connexpay/src/Web/Connexpay/Payments.hs @@ -119,8 +119,9 @@ sendRequestJson endpoint body = do sendRequest_ :: Text -> [Pair] -> ConnexpayM () sendRequest_ ep body = do - r <- sendRequest' ignoreResponse ep mempty body - logResponse r + r <- sendRequest' lbsResponse ep mempty body + let b = responseBody r + logResponseBody r b data AuthResponse = AuthResponse { paymentGuid :: AuthOnlyGuid , status :: TransactionStatus From 318ade4c43df0f717f198c652930306239eecacc Mon Sep 17 00:00:00 2001 From: Nick Date: Tue, 1 Apr 2025 18:02:20 +0000 Subject: [PATCH 3/5] Revert "Log response body even if response is ignored." This reverts commit 5340ff52f7020fff12b38c0fb312a190de4b2b53. --- connexpay/src/Web/Connexpay/Payments.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/connexpay/src/Web/Connexpay/Payments.hs b/connexpay/src/Web/Connexpay/Payments.hs index af93da3..1f92561 100644 --- a/connexpay/src/Web/Connexpay/Payments.hs +++ b/connexpay/src/Web/Connexpay/Payments.hs @@ -119,9 +119,8 @@ sendRequestJson endpoint body = do sendRequest_ :: Text -> [Pair] -> ConnexpayM () sendRequest_ ep body = do - r <- sendRequest' lbsResponse ep mempty body - let b = responseBody r - logResponseBody r b + r <- sendRequest' ignoreResponse ep mempty body + logResponse r data AuthResponse = AuthResponse { paymentGuid :: AuthOnlyGuid , status :: TransactionStatus From b05139642d28a539082647dce3de14c024b49868 Mon Sep 17 00:00:00 2001 From: Nick Date: Tue, 1 Apr 2025 18:02:29 +0000 Subject: [PATCH 4/5] Revert "Log responses" This reverts commit f90fcff5fc078f2313b927511632a4eb4491f6af. --- connexpay/src/Web/Connexpay/Payments.hs | 42 ++++++++++--------------- connexpay/src/Web/Connexpay/Types.hs | 13 +------- 2 files changed, 17 insertions(+), 38 deletions(-) diff --git a/connexpay/src/Web/Connexpay/Payments.hs b/connexpay/src/Web/Connexpay/Payments.hs index 1f92561..2c9dee6 100644 --- a/connexpay/src/Web/Connexpay/Payments.hs +++ b/connexpay/src/Web/Connexpay/Payments.hs @@ -12,8 +12,7 @@ module Web.Connexpay.Payments ( CreditCard(..) , returnPayment ) where -import Control.Exception (throwIO) -import Control.Monad (when) +import Control.Monad (when,void) import Control.Monad.Except (throwError) import Control.Monad.Reader (asks) import Control.Monad.Writer.Strict @@ -63,10 +62,8 @@ padDate :: Text -> Text padDate t | Text.length t == 1 = "0" <> t | otherwise = t -sendRequest' :: HttpResponse resp - => Proxy resp -> Text -> (forall scheme. Option scheme) -> [Pair] - -> ConnexpayM resp -sendRequest' resp endpoint opts body = +sendRequest' :: HttpResponse resp => Proxy resp -> Text -> [Pair] -> ConnexpayM resp +sendRequest' resp endpoint body = do mtok <- bearerToken tok <- case mtok of Just t -> pure t @@ -74,13 +71,13 @@ sendRequest' resp endpoint opts body = host <- asks (.url) tls <- asks (.useTLS) let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok) - headers = auth <> opts url s = s host /: "api" /: "v1" /: endpoint obj <- object <$> addGuid body let jbody = ReqBodyJson obj r <- if tls - then reqCb POST (url https) jbody resp headers (logRequest obj) - else reqCb POST (url http) jbody resp headers (logRequest obj) + then reqCb POST (url https) jbody resp auth (logRequest obj) + else reqCb POST (url http) jbody resp auth (logRequest obj) + logResponse r pure r where addGuid b = @@ -106,21 +103,11 @@ sendRequest' resp endpoint opts body = $ c replaceCard v = v -sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM a -sendRequestJson endpoint body = do - r <- sendRequest' lbsResponse endpoint accept body - let b = responseBody r - logResponseBody r b - case eitherDecode b of - Right x -> return x - Left e -> liftIO (throwIO (JsonHttpException e)) - where - accept = header "Accept" "application/json" +sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a) +sendRequestJson = sendRequest' jsonResponse sendRequest_ :: Text -> [Pair] -> ConnexpayM () -sendRequest_ ep body = do - r <- sendRequest' ignoreResponse ep mempty body - logResponse r +sendRequest_ ep = void . sendRequest' ignoreResponse ep data AuthResponse = AuthResponse { paymentGuid :: AuthOnlyGuid , status :: TransactionStatus @@ -146,7 +133,8 @@ authorisePayment :: CreditCard -- ^ Credit card details (see 'CreditCard') -> Maybe Text -- ^ Merchant description that will appear in a customer's statement. -> ConnexpayM AuthResponse authorisePayment cc amt invoice vendor = - do rbody <- sendRequestJson "authonlys" body + do resp <- sendRequestJson "authonlys" body + let rbody = responseBody resp -- Special case for Connexpay local transaction -- This status means that the transaction was registered, -- but Connexpay stopped its processing and it won't be @@ -168,8 +156,7 @@ authorisePayment cc amt invoice vendor = -- should the need arise. tell [ "RiskData" .= KeyMap.empty @() ] -data VoidRequest = VoidAuthorized AuthOnlyGuid - | VoidCaptured SaleGuid (Maybe (Money USD)) +data VoidRequest = VoidAuthorized AuthOnlyGuid | VoidCaptured SaleGuid (Maybe (Money USD)) -- | Void payment voidPayment :: VoidRequest @@ -206,7 +193,10 @@ instance FromJSON CaptureResponse where -- | Capture payment, previously authorised through 'authorisePayment'. capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'. -> ConnexpayM CaptureResponse -capturePayment pid = sendRequestJson "Captures" body +capturePayment pid = + do resp <- sendRequestJson "Captures" body + let rbody = responseBody resp + pure rbody where body = [ "AuthOnlyGuid" .= show pid , "ConnexPayTransaction" .= CPTransaction 1 ] diff --git a/connexpay/src/Web/Connexpay/Types.hs b/connexpay/src/Web/Connexpay/Types.hs index 078eaba..6564901 100644 --- a/connexpay/src/Web/Connexpay/Types.hs +++ b/connexpay/src/Web/Connexpay/Types.hs @@ -10,11 +10,10 @@ import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError) import Control.Monad.IO.Class import Control.Monad.Reader import Data.Aeson -import Data.ByteString.Lazy (ByteString) import Data.Text (Text) import Data.Text qualified as Text import Data.UUID (UUID) -import Network.HTTP.Client hiding (responseBody, responseHeaders) +import Network.HTTP.Client hiding (responseHeaders) import Network.HTTP.Req import Network.HTTP.Types @@ -71,13 +70,3 @@ logResponse r = , "HTTP code: " <> tshow (responseCode r) , "Headers: " <> tshow (responseHeaders r) ] - -logResponseBody :: HttpResponse resp => resp -> ByteString -> ConnexpayM () -logResponseBody r body = - do log_ <- asks (.logAction) - liftIO (log_ msg) - where msg = Text.unlines [ "Connexpay response:" - , "HTTP code: " <> tshow (responseCode r) - , "Headers: " <> tshow (responseHeaders r) - , "Body: " <> tshow body - ] From 91f3a86560c5126daadc0fb019b6d256f6a27d38 Mon Sep 17 00:00:00 2001 From: Nick Date: Tue, 1 Apr 2025 18:10:36 +0000 Subject: [PATCH 5/5] Log responses via a callback inside req. --- connexpay/src/Web/Connexpay/Payments.hs | 1 - connexpay/src/Web/Connexpay/Types.hs | 24 +++++++++++++++--------- connexpay/src/Web/Connexpay/Utils.hs | 4 ++-- stack.yaml | 3 ++- 4 files changed, 19 insertions(+), 13 deletions(-) diff --git a/connexpay/src/Web/Connexpay/Payments.hs b/connexpay/src/Web/Connexpay/Payments.hs index 2c9dee6..ade9b85 100644 --- a/connexpay/src/Web/Connexpay/Payments.hs +++ b/connexpay/src/Web/Connexpay/Payments.hs @@ -77,7 +77,6 @@ sendRequest' resp endpoint body = r <- if tls then reqCb POST (url https) jbody resp auth (logRequest obj) else reqCb POST (url http) jbody resp auth (logRequest obj) - logResponse r pure r where addGuid b = diff --git a/connexpay/src/Web/Connexpay/Types.hs b/connexpay/src/Web/Connexpay/Types.hs index 6564901..9226278 100644 --- a/connexpay/src/Web/Connexpay/Types.hs +++ b/connexpay/src/Web/Connexpay/Types.hs @@ -10,10 +10,11 @@ import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError) import Control.Monad.IO.Class import Control.Monad.Reader import Data.Aeson +import Data.ByteString (ByteString) import Data.Text (Text) import Data.Text qualified as Text import Data.UUID (UUID) -import Network.HTTP.Client hiding (responseHeaders) +import Network.HTTP.Client as Client import Network.HTTP.Req import Network.HTTP.Types @@ -45,8 +46,14 @@ instance MonadHttp ConnexpayM where , Just f <- guessFailure (statusCode $ responseStatus resp) err.message = throwError (PaymentFailure f) handleHttpException (VanillaHttpException (HttpExceptionRequest _ c)) = throwError (ConnectionError $ HttpFailure c) - getHttpConfig = do mgr <- asks (.manager) - pure (defaultHttpConfig { httpConfigAltManager = Just mgr }) + getHttpConfig = + do mgr <- asks (.manager) + log_ <- asks (.logAction) + let cfg = + defaultHttpConfig + { httpConfigAltManager = Just mgr + , httpConfigLogResponse = logResponse log_ } + pure cfg runConnexpay :: Connexpay -> ConnexpayM a -> IO (Either ConnexpayError a) @@ -62,11 +69,10 @@ bearerToken :: ConnexpayM (Maybe BearerToken) bearerToken = do v <- asks (.bearerToken) liftIO (readMVar v) -logResponse :: HttpResponse r => r -> ConnexpayM () -logResponse r = - do log_ <- asks (.logAction) - liftIO (log_ msg) +logResponse :: (Text -> IO ()) -> Request -> Response a -> ByteString -> IO () +logResponse log_ _req resp body = log_ msg where msg = Text.unlines [ "Connexpay response:" - , "HTTP code: " <> tshow (responseCode r) - , "Headers: " <> tshow (responseHeaders r) + , "HTTP code: " <> tshow (statusCode (responseStatus resp)) + , "Headers: " <> tshow (Client.responseHeaders resp) + , "Body: " <> tshow body ] diff --git a/connexpay/src/Web/Connexpay/Utils.hs b/connexpay/src/Web/Connexpay/Utils.hs index 7f3ab77..c625719 100644 --- a/connexpay/src/Web/Connexpay/Utils.hs +++ b/connexpay/src/Web/Connexpay/Utils.hs @@ -17,8 +17,8 @@ whenJust Nothing _ = pure () tshow :: Show a => a -> Text tshow = Text.pack . show -responseHeaders :: HttpResponse response => response -> [Header] -responseHeaders = Client.responseHeaders . toVanillaResponse +--responseHeaders :: HttpResponse response => response -> [Header] +--responseHeaders = Client.responseHeaders . toVanillaResponse responseCode :: HttpResponse response => response -> Int responseCode = statusCode . Client.responseStatus . toVanillaResponse diff --git a/stack.yaml b/stack.yaml index f541a13..b4ff741 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,7 +7,8 @@ packages: extra-deps: - git: https://github.com/typeable/bucks.git commit: 9e378b675fe7fb88d5ddb3af068d82eb441f343c - + - git: https://github.com/typeable/req.git + commit: 8829ac5197f7a4b3f04b7fdfc3ea66cfe70ab0a5 nix: packages: [zlib] local-bin-path: bin