From f922e26ce22ff2af4b38b67dfd2854130c48c5b7 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Thu, 17 Apr 2025 20:47:38 +0300 Subject: [PATCH 01/11] Replace 'req' with 'http-client' --- .github/workflows/haskell-ci.yml | 9 +- cabal.haskell-ci | 1 + cabal.project | 10 - cabal.project.freeze | 33 +- connexpay-optparse/connexpay-optparse.cabal | 24 +- connexpay-optparse/src/Web/Connexpay/Cli.hs | 27 +- connexpay/connexpay.cabal | 22 +- connexpay/src/Web/Connexpay.hs | 16 - connexpay/src/Web/Connexpay/Auth.hs | 80 +++-- connexpay/src/Web/Connexpay/Data.hs | 95 ------ connexpay/src/Web/Connexpay/Http.hs | 112 +++++++ connexpay/src/Web/Connexpay/Init.hs | 95 +++--- connexpay/src/Web/Connexpay/Payments.hs | 289 ++++-------------- connexpay/src/Web/Connexpay/Payments/Types.hs | 210 +++++++++++++ connexpay/src/Web/Connexpay/Types.hs | 159 +++++----- connexpay/src/Web/Connexpay/Utils.hs | 22 +- connexpay/tool/Main.hs | 91 +++--- stack.yaml | 6 +- 18 files changed, 678 insertions(+), 623 deletions(-) delete mode 100644 connexpay/src/Web/Connexpay.hs delete mode 100644 connexpay/src/Web/Connexpay/Data.hs create mode 100644 connexpay/src/Web/Connexpay/Http.hs create mode 100644 connexpay/src/Web/Connexpay/Payments/Types.hs diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 31a5785..a799c02 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -170,10 +170,11 @@ jobs: location: https://github.com/typeable/bucks.git tag: 9e378b675fe7fb88d5ddb3af068d82eb441f343c - source-repository-package - type: git - location: https://github.com/typeable/req.git - tag: 8829ac5197f7a4b3f04b7fdfc3ea66cfe70ab0a5 + package connexpay + ghc-options: -Werror + + package connexpay-optparse + ghc-options: -Werror EOF $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(connexpay|connexpay-optparse)$/; }' >> cabal.project.local cat cabal.project diff --git a/cabal.haskell-ci b/cabal.haskell-ci index e1f1b77..bc078ab 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -1 +1,2 @@ branches: master +local-ghc-options: -Werror diff --git a/cabal.project b/cabal.project index 24e8a93..f5a7376 100644 --- a/cabal.project +++ b/cabal.project @@ -3,13 +3,3 @@ with-compiler: ghc-9.6.6 packages: connexpay/ connexpay-optparse/ - -source-repository-package - type: git - location: https://github.com/typeable/bucks.git - tag: 9e378b675fe7fb88d5ddb3af068d82eb441f343c - -source-repository-package - type: git - location: https://github.com/typeable/req.git - tag: 8829ac5197f7a4b3f04b7fdfc3ea66cfe70ab0a5 diff --git a/cabal.project.freeze b/cabal.project.freeze index 40b872a..6dba1a6 100644 --- a/cabal.project.freeze +++ b/cabal.project.freeze @@ -4,9 +4,6 @@ constraints: any.Cabal ==3.10.3.0, any.OneTuple ==0.4.2, any.QuickCheck ==2.14.3, QuickCheck -old-random +templatehaskell, - any.RSA ==2.4.1, - any.SHA ==1.6.4.4, - SHA -exe, any.StateVar ==1.2.2, any.aeson ==2.1.2.1, aeson -cffi +ordered-keymap, @@ -25,7 +22,6 @@ constraints: any.Cabal ==3.10.3.0, any.attoparsec ==0.14.4, attoparsec -developer, any.attoparsec-iso8601 ==1.1.1.0, - any.authenticate-oauth ==1.7, any.base ==4.18.2.1, any.base-compat ==0.13.1, any.base-compat-batteries ==0.13.1, @@ -38,8 +34,6 @@ constraints: any.Cabal ==3.10.3.0, any.bitvec ==1.1.5.0, bitvec +simd, any.blaze-builder ==0.4.2.3, - any.bucks ==0.1, - bucks -aeson -openapi -rel8, any.byteorder ==1.0.4, any.bytestring ==0.11.5.3, any.case-insensitive ==1.2.1.0, @@ -53,9 +47,6 @@ constraints: any.Cabal ==3.10.3.0, any.contravariant ==1.5.5, contravariant +semigroups +statevar +tagged, any.cookie ==0.4.6, - any.crypto-api ==0.13.3, - crypto-api -all_cpolys, - any.crypto-pubkey-types ==0.4.3, any.cryptohash-md5 ==0.11.101.0, any.cryptohash-sha1 ==0.11.101.0, any.crypton ==0.34, @@ -65,11 +56,7 @@ constraints: any.Cabal ==3.10.3.0, any.crypton-x509-store ==1.6.9, any.crypton-x509-system ==1.6.7, any.crypton-x509-validation ==1.6.12, - any.data-default ==0.7.1.1, any.data-default-class ==0.1.2.0, - any.data-default-instances-containers ==0.0.1, - any.data-default-instances-dlist ==0.0.1, - any.data-default-instances-old-locale ==0.0.1, any.data-fix ==0.3.4, any.deepseq ==1.4.8.1, any.directory ==1.3.8.5, @@ -85,7 +72,6 @@ constraints: any.Cabal ==3.10.3.0, any.ghc-bignum ==1.3, any.ghc-boot-th ==9.6.6, any.ghc-prim ==0.10.0, - any.groups ==0.5.3, any.hashable ==1.4.4.0, hashable +integer-gmp -random-initial-seed, any.hourglass ==0.2.12, @@ -107,18 +93,11 @@ constraints: any.Cabal ==3.10.3.0, any.libyaml ==0.1.4, libyaml -no-unicode -system-libyaml, any.libyaml-clib ==0.2.5, - any.megaparsec ==9.5.0, - megaparsec -dev, any.memory ==0.18.0, memory +support_bytestring +support_deepseq, any.mime-types ==0.1.2.0, - any.modern-uri ==0.3.6.1, - modern-uri -dev, - any.monad-control ==1.0.3.1, any.mono-traversable ==1.0.20.0, any.mtl ==2.3.1, - any.mtl-compat ==0.2.2, - mtl-compat -two-point-one -two-point-two, any.network ==3.1.4.0, network -devel, any.network-info ==0.2.1, @@ -129,8 +108,6 @@ constraints: any.Cabal ==3.10.3.0, optparse-applicative +process, any.os-string ==2.0.6, any.parsec ==3.1.16.1, - any.parser-combinators ==1.3.0, - parser-combinators -dev, any.pem ==0.2.4, any.pretty ==1.1.3.6, any.prettyprinter ==1.7.1, @@ -138,16 +115,10 @@ constraints: any.Cabal ==3.10.3.0, any.prettyprinter-ansi-terminal ==1.1.3, any.primitive ==0.8.0.0, any.process ==1.6.19.0, - any.profunctors ==5.6.2, any.random ==1.2.1.2, - any.reflection ==2.1.8, - reflection -slow +template-haskell, - any.req ==3.13.4, - req -dev, any.resourcet ==1.3.0, - any.retry ==0.9.3.1, - retry -lib-werror, any.rts ==1.0.2, + any.safe-exceptions ==0.1.7.4, any.scientific ==0.3.7.0, scientific -bytestring-builder -integer-simple, any.semialign ==1.3.1, @@ -177,8 +148,6 @@ constraints: any.Cabal ==3.10.3.0, any.tls ==1.8.0, tls +compat -hans +network, any.transformers ==0.6.1.0, - any.transformers-base ==0.4.6, - transformers-base +orphaninstances, any.transformers-compat ==0.7.2, transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, any.unix ==2.8.4.0, diff --git a/connexpay-optparse/connexpay-optparse.cabal b/connexpay-optparse/connexpay-optparse.cabal index 0ec728c..b686739 100644 --- a/connexpay-optparse/connexpay-optparse.cabal +++ b/connexpay-optparse/connexpay-optparse.cabal @@ -14,15 +14,29 @@ build-type: Simple tested-with: GHC ==9.8.4 || ==9.6.6 -common warnings - ghc-options: -Wall +common common + default-extensions: + BlockArguments + DeriveAnyClass + DerivingVia + DuplicateRecordFields + LambdaCase + MultiWayIf + NoFieldSelectors + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + RecordWildCards + default-language: GHC2021 + ghc-options: + -Wall -Wmissing-deriving-strategies -Wprepositive-qualified-module + -Wunused-packages -Wredundant-constraints library - import: warnings + import: common exposed-modules: Web.Connexpay.Cli build-depends: base >=4.14 && < 5.0 + , connexpay , optparse-applicative - , text - , uuid hs-source-dirs: src default-language: Haskell2010 diff --git a/connexpay-optparse/src/Web/Connexpay/Cli.hs b/connexpay-optparse/src/Web/Connexpay/Cli.hs index 4e25cc9..f1aa024 100644 --- a/connexpay-optparse/src/Web/Connexpay/Cli.hs +++ b/connexpay-optparse/src/Web/Connexpay/Cli.hs @@ -1,18 +1,19 @@ +{-# LANGUAGE ApplicativeDo #-} + module Web.Connexpay.Cli where -import Data.UUID -import Data.Text (Text) import Options.Applicative +import Web.Connexpay.Types -data ConnexpayCli = ConnexpayCli { login :: Text - , password :: Text - , deviceGuid :: UUID - , endpoint :: Text - } deriving Show -connexpayOpts :: Parser ConnexpayCli -connexpayOpts = - ConnexpayCli <$> option str (long "connexpay-login" <> metavar "LOGIN") - <*> option str (long "connexpay-password" <> metavar "PASSWORD") - <*> option auto (long "connexpay-devguid" <> metavar "GUID") - <*> option str (long "connexpay-endpoint" <> metavar "URL") +connexpayOpts :: Parser Config +connexpayOpts = do + host <- option str (long "connexpay-endpoint" <> metavar "URL") + login <- option str (long "connexpay-login" <> metavar "LOGIN") + password <- option str (long "connexpay-password" <> metavar "PASSWORD") + deviceGuid <- option auto (long "connexpay-devguid" <> metavar "GUID") + useHttp <- switch (long "use-http" <> help "Use plain HTTP instead. Insecure!") + pure Config + { useTLS = not useHttp + , .. + } diff --git a/connexpay/connexpay.cabal b/connexpay/connexpay.cabal index d0028dc..efa47a2 100644 --- a/connexpay/connexpay.cabal +++ b/connexpay/connexpay.cabal @@ -34,23 +34,23 @@ common common library import: common - exposed-modules: Web.Connexpay - Web.Connexpay.Auth - Web.Connexpay.Data - Web.Connexpay.Init - Web.Connexpay.Payments - Web.Connexpay.Types - Web.Connexpay.Utils + exposed-modules: + Web.Connexpay.Init + Web.Connexpay.Payments + Web.Connexpay.Types + other-modules: + Web.Connexpay.Auth + Web.Connexpay.Http + Web.Connexpay.Payments.Types + Web.Connexpay.Utils build-depends: base >=4.14 && < 5.0 , aeson , async - , bucks , bytestring , http-api-data , http-client , http-types - , mtl - , req + , safe-exceptions , text , uuid hs-source-dirs: src @@ -59,13 +59,11 @@ executable connexpay-tool import: common build-depends: base >= 4.17 , aeson - , bucks , connexpay , http-client , http-client-tls , optparse-applicative , text - , uuid , yaml hs-source-dirs: tool main-is: Main.hs diff --git a/connexpay/src/Web/Connexpay.hs b/connexpay/src/Web/Connexpay.hs deleted file mode 100644 index 96b3b60..0000000 --- a/connexpay/src/Web/Connexpay.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Web.Connexpay ( module Payments - , initConnexpay - , Connexpay(..) - , ConnexpayM - , PaymentFailure(..) - , ConnectionError(..) - , ConnexpayError(..) - , TransactionStatus(..) - , describeFailure - , runConnexpay - ) where - -import Web.Connexpay.Data -import Web.Connexpay.Init -import Web.Connexpay.Payments as Payments -import Web.Connexpay.Types diff --git a/connexpay/src/Web/Connexpay/Auth.hs b/connexpay/src/Web/Connexpay/Auth.hs index 0d026ec..bb07a05 100644 --- a/connexpay/src/Web/Connexpay/Auth.hs +++ b/connexpay/src/Web/Connexpay/Auth.hs @@ -1,22 +1,31 @@ {-# LANGUAGE OverloadedLists #-} -module Web.Connexpay.Auth (authenticate) where - -import Web.Connexpay.Types +module Web.Connexpay.Auth + ( AuthReply(..) + , TokenReply(..) + , authenticate + ) where import Control.Monad -import Control.Monad.Reader import Data.Aeson import Data.Aeson.Types import Data.ByteString (ByteString) import Data.ByteString qualified as ByteString +import Data.ByteString.Lazy qualified as Lazy +import Data.ByteString.Lazy qualified as Lazy.ByteString import Data.Text (Text) import Data.Text qualified as Text -import Network.HTTP.Req +import Data.Text.Encoding qualified as Text +import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Types import Numeric.Natural import Web.FormUrlEncoded import Web.HttpApiData +import Web.Connexpay.Http +import Web.Connexpay.Types + + data AuthForm = AuthForm { login :: Text , password :: Text } @@ -27,12 +36,18 @@ instance ToForm AuthForm where , ("password", toQueryParam auth.password) ] -mkAuthForm :: Text -> Text -> ByteString -mkAuthForm login passwd = ByteString.toStrict (urlEncodeAsForm form) - where form = AuthForm login passwd +mkAuthForm :: Config -> ByteString +mkAuthForm cfg = ByteString.toStrict (urlEncodeAsForm form) + where form = AuthForm cfg.login cfg.password + +data AuthReply + = Authorized TokenReply + | Unauthorized (HTTP.Response Lazy.ByteString) + | AuthParseError String + deriving stock (Show) data TokenReply = TokenReply { token :: BearerToken - , expires_in :: Natural + , expiresIn :: Natural } deriving stock (Show) instance FromJSON TokenReply where @@ -43,16 +58,37 @@ instance FromJSON TokenReply where <*> v .: "expires_in" parseJSON v = typeMismatch "TokenReply" v -authenticate :: ConnexpayM (BearerToken, Natural) -authenticate = do login <- asks (.login) - password <- asks (.password) - host <- asks (.url) - tls <- asks (.useTLS) - let body = ReqBodyBs (mkAuthForm login password) - url s = s host /: "api" /: "v1" /: "token" - resp <- - if tls - then req POST (url https) body jsonResponse mempty - else req POST (url http) body jsonResponse mempty - let TokenReply tok ts = responseBody resp - pure (tok, ts) +authenticate :: Config -> Env -> IO AuthReply +authenticate config env = do + let + req = HTTP.defaultRequest + { HTTP.method = "POST" + , HTTP.host = Text.encodeUtf8 config.host + , HTTP.port = if config.useTLS then 443 else 80 + , HTTP.secure = config.useTLS + , HTTP.path = "api/v1/token" + , HTTP.requestHeaders = + [ ("Accept", "application/json") + , ("Accept-Encoding", "gzip") + ] + , HTTP.requestBody = HTTP.RequestBodyBS $ mkAuthForm config + } + env.logAction $ httpLog req $ "request" .= show @HTTP.Request req + resp <- HTTP.httpLbs req env.manager + let + res + | statusIsSuccessful resp.responseStatus + = either AuthParseError Authorized $ eitherDecode resp.responseBody + | otherwise + = Unauthorized resp + env.logAction $ httpLog req case res of + -- Don't log body! As it contains sensitive info + Authorized _ -> "result".= ("success" :: Text) + Unauthorized _ -> "result" .= ("unauthorized" :: Text) <> "body:" .= + (Text.decodeUtf8Lenient $ Lazy.ByteString.toStrict resp.responseBody) + AuthParseError err -> mconcat + [ "result" .= ("parse_error: " <> err) + , "body" .= + (Text.decodeUtf8Lenient $ Lazy.ByteString.toStrict resp.responseBody) + ] + pure res diff --git a/connexpay/src/Web/Connexpay/Data.hs b/connexpay/src/Web/Connexpay/Data.hs deleted file mode 100644 index 6901a56..0000000 --- a/connexpay/src/Web/Connexpay/Data.hs +++ /dev/null @@ -1,95 +0,0 @@ -module Web.Connexpay.Data ( TransactionStatus(..) - , PaymentFailure(..) - , ConnectionError(..) - , ConnexpayError(..) - , describeFailure - , guessFailure - , ErrorMessage(..) - ) where - -import Control.Exception -import Data.Aeson -import Data.Aeson.Types -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Network.HTTP.Client - --- | Transaction status in Connexpay --- The list is taken from https://docs.connexpay.com/reference/search-sales -data TransactionStatus = TransactionApproved -- ^ Obvious - | TransactionDeclined -- ^ Also obvious - | TransactionCreatedLocal -- ^ Seems to only exist in a test environment, indicates success. - | TransactionCreatedProcNotReached -- ^ Communication error between Connexpay and Card Processor - | TransactionCreatedProcError -- ^ Processor errored out - | TransactionApprovedWarning -- ^ Wut 0__o FIXME: figure out what this is - | TransactionOther Text -- ^ In case they return something unexpected - deriving stock (Eq, Ord, Show) - -statuses :: [(Text, TransactionStatus)] -statuses = [ ( "Transaction - Approved", TransactionApproved ) - , ( "Transaction - Declined", TransactionDeclined ) - , ( "Transaction - CreatedLocal", TransactionCreatedLocal ) - , ( "Transaction - Created - Error: Processor not reached", TransactionCreatedProcNotReached ) - , ( "Transaction - Processor Error", TransactionCreatedProcError ) - , ( "Transaction - Approved - Warning", TransactionApprovedWarning ) - ] - -instance FromJSON TransactionStatus where - parseJSON (String s) = pure (fromMaybe (TransactionOther s) (lookup s statuses)) - parseJSON v = typeMismatch "TransactionStatus" v - --- | Payment failure types. --- This type describes failures that related to either credit card being invalid, --- client account having insufficient funds, and other non-technical conditions. --- FIXME: this list is not exhaustive. Add more values whenever we encounter them. -data PaymentFailure = CVVFailed -- ^ CVV verification failure - | CardInvalid -- ^ Credit card details are invalid - | InvalidAmount -- ^ Money amount is invalid - | GeneralDecline -- ^ They just decline - | LocalTransaction -- ^ Special case for transactions that were registered but did't go through somehow. - | OtherProcessingError Text -- ^ Some other processing error with 422 code - deriving stock (Eq, Show) - -describeFailure :: PaymentFailure -> Text -describeFailure CVVFailed = "CVV authorisation failure" -describeFailure CardInvalid = "Invalid credit card details" -describeFailure InvalidAmount = "Invalid amount of money requested" -describeFailure GeneralDecline = "General card decine" -describeFailure LocalTransaction = "Transaction registered but not processed. Consult with payment processor." -describeFailure (OtherProcessingError txt) = "Transaction declined due to other error: " <> txt - --- | Guess failure type from HTTP code and supplied error string. -guessFailure :: Int -> Text -> Maybe PaymentFailure -guessFailure 422 "Error code D2020. CVV2 verification failed." = Just CVVFailed -guessFailure 422 "Error code D2005. Invalid Card." = Just CardInvalid -guessFailure 422 "Amount field don't allow a value greater than $999,999.99" = Just InvalidAmount -guessFailure 422 "Error code D2999. General CardAuth Decline." = Just GeneralDecline -guessFailure 422 txt = Just (OtherProcessingError txt) -guessFailure _ _ = Nothing - --- | Error response from Connexpay -data ErrorMessage = ErrorMessage { message :: Text - , errorId :: Text } - -instance FromJSON ErrorMessage where - parseJSON (Object o) = ErrorMessage <$> o .: "message" - <*> o .: "errorId" - parseJSON v = typeMismatch "ErrorMessage" v - -data ConnectionError = ParseError String - | InvalidUrl String String - | HttpFailure HttpExceptionContent - | TokenError String - deriving stock Show - --- | Error type for Connexpay. --- There are two possible cases here: --- * Connection failure means the payment may or may not have gotten through. --- This would be typically thrown as an exception in an application. --- * Payment failure means Connexpay returned an error and the payment wasn't authorised. --- No exception here, this must be handled as usual. -data ConnexpayError = ConnectionError ConnectionError - | PaymentFailure PaymentFailure (Maybe Text) - deriving stock (Show) - -instance Exception ConnexpayError diff --git a/connexpay/src/Web/Connexpay/Http.hs b/connexpay/src/Web/Connexpay/Http.hs new file mode 100644 index 0000000..cd11fba --- /dev/null +++ b/connexpay/src/Web/Connexpay/Http.hs @@ -0,0 +1,112 @@ +module Web.Connexpay.Http + ( RequestBody(..) + , LogMasker + , doRequest + , doRequest_ + , fromResponse + , httpLog + ) where + +import Control.Concurrent +import Control.Exception.Safe +import Data.Aeson +import Data.Aeson.Text +import Data.ByteString.Lazy qualified as Lazy (ByteString) +import Data.ByteString.Lazy qualified as Lazy.ByteString +import Data.Text (Text) +import Data.Text.Encoding qualified as Text +import Data.Text.Lazy qualified as Lazy.Text +import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Types + +import Web.Connexpay.Types + + +data RequestBody a = RequestBody + { raw :: a + -- ^ To be sent to Connexpay + , logMasker :: LogMasker a + } + +type LogMasker a = a -> a + +doRequest + :: (ToJSON req, FromJSON resp) + => Connexpay + -> Env + -> Text + -> RequestBody req + -> IO (Response () resp) + -- ^ Left on non-200 repsonses +doRequest connexpay env endpoint body = readMVar connexpay.bearerToken >>= \case + Nothing -> pure MissingOrExpiredToken + Just (BearerToken token) -> do + let + req = HTTP.applyBearerAuth (Text.encodeUtf8 token) HTTP.defaultRequest + { HTTP.method = "POST" + , HTTP.host = Text.encodeUtf8 connexpay.config.host + , HTTP.port = if connexpay.config.useTLS then 443 else 80 + , HTTP.secure = connexpay.config.useTLS + , HTTP.path = "api/v1/" <> Text.encodeUtf8 endpoint + , HTTP.requestHeaders = + [ ("Content-Type", "application/json; charset=utf-8") + , ("Accept", "application/json") + , ("Accept-Encoding", "gzip") + ] + , HTTP.requestBody = HTTP.RequestBodyLBS $ encode + case toJSON body.raw of + Object o -> Object $ o <> "DeviceGuid" .= connexpay.config.deviceGuid + v -> v + } + env.logAction $ httpLog req $ mconcat + [ "request" .= show @HTTP.Request req + , "body" .= body.logMasker body.raw + ] + resp <- HTTP.httpLbs req env.manager + env.logAction $ httpLog req $ mconcat + [ "response_code" .= statusCode resp.responseStatus + , "body" .= Text.decodeUtf8Lenient (Lazy.ByteString.toStrict resp.responseBody) + ] + either throwM pure $ fromResponse resp + +doRequest_ + :: (ToJSON req) + => Connexpay + -> Env + -> Text + -> RequestBody req + -> IO (Response () ()) +doRequest_ connexpay env endpoint body = fmap @(Response ()) (const @_ @Value ()) + <$> doRequest connexpay env endpoint body + +-- | We should aim to never see this in practice. +data FromResponseException + = UnexpectedResponse (HTTP.Response Lazy.ByteString) + -- ^ Unexpected response status code (neither 2XX, nor 422) + | ResponseSuccessParseError (HTTP.Response Lazy.ByteString) String + -- ^ Failed to parse /success/ response. + -- Thus, operation is likely successful, but we can't analyze the response. + | ResponseErrorParseError (HTTP.Response Lazy.ByteString) String + -- ^ Failed to parse /error/ (422) response. + deriving stock (Show) + deriving anyclass (Exception) + +fromResponse + :: (FromJSON a) + => HTTP.Response Lazy.ByteString + -> Either FromResponseException (Response () a) +fromResponse resp + | statusIsSuccessful resp.responseStatus + = either (Left . ResponseSuccessParseError resp) (Right . ResponseSuccess) $ + eitherDecode resp.responseBody + | resp.responseStatus == unauthorized401 + = pure MissingOrExpiredToken + | resp.responseStatus == unprocessableEntity422 + = either (Left . ResponseErrorParseError resp) (Right . ResponseError) $ + eitherDecode resp.responseBody + | otherwise + = Left $ UnexpectedResponse resp + +httpLog :: HTTP.Request -> Object -> Text +httpLog req payload = Lazy.Text.toStrict $ encodeToLazyText @Object $ + "connexpay" .= (payload <> "path" .= Text.decodeUtf8Lenient req.path) diff --git a/connexpay/src/Web/Connexpay/Init.hs b/connexpay/src/Web/Connexpay/Init.hs index cf5f855..01503a8 100644 --- a/connexpay/src/Web/Connexpay/Init.hs +++ b/connexpay/src/Web/Connexpay/Init.hs @@ -1,69 +1,48 @@ module Web.Connexpay.Init (initConnexpay) where -import Web.Connexpay.Auth -import Web.Connexpay.Data -import Web.Connexpay.Types -import Web.Connexpay.Utils - import Control.Concurrent import Control.Concurrent.Async -import Control.Monad (void) -import Control.Monad.Except (catchError) -import Control.Monad.IO.Class -import Control.Monad.Reader (asks) +import Control.Exception.Safe +import Control.Monad +import Data.Aeson +import Data.Aeson.Text import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Lazy qualified as Lazy.Text import Network.HTTP.Client (Manager) import Numeric.Natural --- | Initialise Connexpay state. Log in, authenticate, and obtain bearer token. -initConnexpay :: (Text -> IO ()) -- ^ Logging function - -> Manager -- ^ HTTP client manager - -> DeviceGuid -- ^ Device GUID. You must obtain this from ConnexPay - -> Text -- ^ Connexpay host to connect with - -> Bool -- ^ Whether to use TLS. If unsure, say True. - -> Text -- ^ Login name. - -> Text -- ^ Password. - -> IO (Either ConnexpayError Connexpay) -initConnexpay logf mgr devguid url tls login password = - do v <- newMVar Nothing - let env = Connexpay { logAction = logf - , manager = mgr - , bearerToken = v - , refreshAsync = Nothing - , deviceGuid = devguid - , url = url - , useTLS = tls - , login = login - , password = password - } - runConnexpay env $ do - ts <- initialAuth v logf - a <- liftIO (async (runConnexpay_ env $ updateToken ts)) - pure (env { refreshAsync = Just a }) +import Web.Connexpay.Auth +import Web.Connexpay.Types -initialAuth :: MVar (Maybe BearerToken) -> (Text -> IO ()) -> ConnexpayM Natural -initialAuth v logf = - do (tok, ts) <- authenticate - liftIO $ do logf "Connexpay authentication success" - void (swapMVar v (Just tok)) - return ts - `catchError` \err -> do - liftIO (logf ("Initial connexpay authentication failed: " <> tshow err)) - -- if initial authentication failed, wait 1 second? - -- there isn't much else to do, really. - return 1 +-- | Initialise Connexpay state. Log in, authenticate, and obtain bearer token. +initConnexpay + :: Logger + -> Manager + -> Config + -> IO Connexpay +initConnexpay logAction manager config = do + bearerToken <- newMVar Nothing + let env = Env{..} + refreshAsync <- async $ forever $ + updateToken config env bearerToken 0 `catchAny` \err -> do + doLog env $ + "Connexpay token update exception: " <> Text.pack (displayException err) + threadDelay 5_000_000 + pure Connexpay{..} + +updateToken :: Config -> Env -> MVar (Maybe BearerToken) -> Natural -> IO () +updateToken config env tokVar w = + threadDelay (fromIntegral w * 1_000_000) >> upd + where + upd = authenticate config env >>= \case + Authorized tok -> do + _ <- swapMVar tokVar (Just tok.token) + updateToken config env tokVar (tok.expiresIn - 5) + _ -> do + updateToken config env tokVar 5 -updateToken :: Natural -> ConnexpayM () -updateToken w = liftIO (threadDelay w') >> upd - where w' = fromIntegral w * 1000000 - upd = do (tok, ts) <- authenticate - logf <- asks (.logAction) - tokVar <- asks (.bearerToken) - liftIO (void $ swapMVar tokVar (Just tok)) - liftIO (logf "Connexpay token update success") - updateToken (ts - 5) - `catchError` \err -> do - logf <- asks (.logAction) - liftIO (logf ("Connexpay token update failure: " <> tshow err)) - updateToken 5 +doLog :: Env -> Text -> IO () +doLog env msg = env.logAction $ Lazy.Text.toStrict $ encodeToLazyText @Object $ + "connexpay" .= ("auth" .= msg :: Object) diff --git a/connexpay/src/Web/Connexpay/Payments.hs b/connexpay/src/Web/Connexpay/Payments.hs index cbd9f49..393e1c9 100644 --- a/connexpay/src/Web/Connexpay/Payments.hs +++ b/connexpay/src/Web/Connexpay/Payments.hs @@ -1,239 +1,80 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} +module Web.Connexpay.Payments + ( AuthRequest(..) + , USD(..) + , CreditCard(..) + , ExpirationDate(..) + , Customer(..) + , RiskData(..) + , AuthResponse(..) + , TransactionStatus(..) + , authorisePayment + , VoidRequest(..) + , voidPayment + , CaptureResponse(..) + , Sale(..) + , capturePayment + , cancelPayment + , returnPayment + ) where -module Web.Connexpay.Payments ( CreditCard(..) - , AuthRequest(..) - , Customer(..) - , AuthResponse(..) - , authorisePayment - , VoidRequest(..) - , voidPayment - , CaptureResponse(..) - , capturePayment - , cancelPayment - , returnPayment - ) where - -import Control.Monad (when,void) -import Control.Monad.Except (throwError) -import Control.Monad.Reader (asks) -import Control.Monad.Writer.Strict import Data.Aeson -import Data.Aeson.KeyMap qualified as KeyMap -import Data.Aeson.TH -import Data.Aeson.Types (Pair, typeMismatch) -import Data.ByteString.Lazy qualified as ByteString -import Data.Int (Int32) -import Data.Money -import Data.Proxy -import Data.Text (Text) -import Data.Text qualified as Text -import Data.Text.Encoding qualified as Text -import GHC.TypeError as TypeError -import Network.HTTP.Req +import Data.Maybe -import Web.Connexpay.Data +import Web.Connexpay.Http +import Web.Connexpay.Payments.Types import Web.Connexpay.Types -import Web.Connexpay.Utils - - -data Customer = Customer { address1 :: Text - , address2 :: Maybe Text - , zip :: Maybe Text - } - -deriveToJSON defaultOptions - { fieldLabelModifier = capitalize - , omitNothingFields = True - } ''Customer - --- | Credit card info --- No 'Show' instance should be made for this type --- in order to avoid sensitive data leaks. -data CreditCard = CreditCard { number :: Text -- ^ Credit card number, as 'Text'. - , cardholder :: Maybe Text -- ^ Cardholder name, optional. - , expiration :: (Word, Word) -- ^ Expiration date (month,year). - , cvv :: Maybe Text -- ^ CVC/CVV code. - , customer :: Maybe Customer -- ^ Required to get AVS - } -type ShowError = TypeError.Text "CreditCard must not be shown in order to avoid leaking sensitive data" - -instance TypeError ShowError => Show CreditCard where - show = error "UNREACHABLE" - -instance ToJSON CreditCard where - toJSON cc = object - $ execWriter - $ do tell ["CardNumber" .= cc.number] - whenJust cc.cardholder $ \name -> - tell ["CardHolderName" .= name] - whenJust cc.cvv $ \cvv -> - tell ["Cvv2" .= cvv] - let expDate = padDate (tshow (snd cc.expiration)) <> padDate (tshow (fst cc.expiration)) - tell ["ExpirationDate" .= expDate] - whenJust cc.customer $ \customer -> - tell [ "Customer" .= customer ] - -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 = - do mtok <- bearerToken - tok <- case mtok of - Just t -> pure t - Nothing -> throwError (ConnectionError $ TokenError "No authentication token available. Check connection parameters?") - host <- asks (.url) - tls <- asks (.useTLS) - let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok) - 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) - pure r - where - addGuid b = - do guid <- asks (.deviceGuid) - return (b <> [ "DeviceGuid" .= show guid ]) - logRequest v r = - do log_ <- asks (.logAction) - -- Remove card info from logs - let v' = case v of - Object obj - | Just c <- KeyMap.lookup "Card" obj -> Object (KeyMap.insert "Card" (replaceCard c) obj) - other -> other - msg = Text.unlines [ "Connexpay request:" - , tshow r - , Text.decodeUtf8 (ByteString.toStrict $ encode v') - ] - _ <- liftIO (log_ msg) - return r - replaceCard (Object c) = - Object - $ KeyMap.insert "CardNumber" (String "") - $ KeyMap.insert "Cvv2" (String "") - $ c - replaceCard v = v - -sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a) -sendRequestJson = sendRequest' jsonResponse -sendRequest_ :: Text -> [Pair] -> ConnexpayM () -sendRequest_ ep = void . sendRequest' ignoreResponse ep - -data AuthResponse = AuthResponse { paymentGuid :: AuthOnlyGuid - , status :: TransactionStatus - , processorStatusCode :: Maybe Text - , processorMessage :: Maybe Text - , addressVerificationCode :: Maybe Text - , cvvVerificationCode :: Maybe Text - } deriving stock (Show) - -instance FromJSON AuthResponse where - parseJSON (Object o) = AuthResponse <$> o .: "guid" - <*> o .: "status" - <*> o .:? "processorStatusCode" - <*> o .:? "processorResponseMessage" - <*> o .:? "addressVerificationCode" - <*> o .:? "cvvVerificationCode" - parseJSON v = typeMismatch "AuthReponse" v - -data AuthRequest = AuthRequest { creditCard :: CreditCard - , amount :: Money USD - , invoice :: Maybe Text - , vendor :: Maybe Text - -- ^ Merchant description that will appear in a - -- customer's statement. - } -- | Authorise a credit card payment. -authorisePayment :: AuthRequest - -> ConnexpayM AuthResponse -authorisePayment request = - 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 - -- moved any further. - -- Also, when I asked Ken from Connexpay about this, - -- he told me he had never seen this status before. - when (rbody.status == TransactionCreatedLocal) $ - throwError (PaymentFailure LocalTransaction Nothing) - pure rbody - where body = execWriter $ - do tell [ "Card" .= request.creditCard ] - tell [ "Amount" .= getAmount request.amount ] - whenJust request.invoice $ \i -> - tell [ "OrderNumber" .= i ] - whenJust request.vendor $ \v -> - tell [ "StatementDescription" .= v ] - -- We are supposed to pass RiskData, but it still - -- can be an empty object. Consider population this - -- should the need arise. - tell [ "RiskData" .= KeyMap.empty @() ] - -data VoidRequest = VoidAuthorized AuthOnlyGuid | VoidCaptured SaleGuid (Maybe (Money USD)) +authorisePayment + :: Connexpay -> Env -> AuthRequest -> IO (Response AuthError AuthResponse) +authorisePayment connexpay env raw = guessResponseErrorType guessAuthError <$> + doRequest connexpay env "authonlys" RequestBody + { raw + , logMasker = maskAuthRequest + } -- | Void payment -voidPayment :: VoidRequest - -> ConnexpayM () -voidPayment (VoidAuthorized pid) = sendRequest_ "void" body - where body = [ "AuthOnlyGuid" .= show pid ] -voidPayment (VoidCaptured pid amt) = sendRequest_ "void" body - where body = execWriter $ - do tell [ "SaleGuid" .= show pid ] - whenJust amt $ \m -> - tell [ "Amount" .= getAmount m ] - --- | Internal data type for Capture requests. -data CPTransaction = CPTransaction { expectedPayments :: Int32 } - -instance ToJSON CPTransaction where - toJSON t = object [ "ExpectedPayments" .= t.expectedPayments ] - --- | Response for the payment capture request -data CaptureResponse = CaptureResponse { captureGuid :: CaptureGuid - , saleGuid :: SaleGuid - , saleStatus :: TransactionStatus - } deriving stock (Show) - -instance FromJSON CaptureResponse where - parseJSON (Object o) = - do cguid <- o .: "guid" - sale <- o .: "sale" - saleGuid <- sale .: "guid" - status <- sale .: "status" - pure (CaptureResponse cguid saleGuid status) - parseJSON v = typeMismatch "CaptureResponse" v +voidPayment :: Connexpay -> Env -> VoidRequest -> IO (Response () ()) +voidPayment connexpay env raw = doRequest_ connexpay env "void" RequestBody + { raw + , logMasker = id + } -- | 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 - where body = [ "AuthOnlyGuid" .= show pid - , "ConnexPayTransaction" .= CPTransaction 1 ] +capturePayment :: Connexpay + -> Env + -> AuthOnlyGuid -- ^ Sales GUID, obtained from 'authorisePayment'. + -> IO (Response () CaptureResponse) +capturePayment connexpay env pid = doRequest connexpay env "Captures" RequestBody + { raw = object + [ "AuthOnlyGuid" .= show @AuthOnlyGuid pid + , "ConnexPayTransaction" .= CPTransaction 1 + ] + , logMasker = id + } -- | Cancel voided or captured payment. -- In case of an authorised-only payment, voiding is performed. -- Otherwise, a payment goes through a refund process. -cancelPayment :: SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'. - -> ConnexpayM () -cancelPayment pid = sendRequest_ "cancel" body - where body = [ "SaleGuid" .= show pid ] - -returnPayment :: SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'. - -> Maybe (Money USD) - -> ConnexpayM () -returnPayment pid amt = sendRequest_ "returns" body - where body = execWriter $ - do tell [ "SaleGuid" .= show pid ] - whenJust amt $ \m -> - tell [ "Amount" .= getAmount m ] +cancelPayment :: Connexpay + -> Env + -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'. + -> IO (Response () ()) +cancelPayment connexpay env pid = doRequest_ connexpay env "cancel" RequestBody + { raw = object [ "SaleGuid" .= show pid ] + , logMasker = id + } + +returnPayment :: Connexpay + -> Env + -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'. + -> Maybe USD + -> IO (Response () ()) +returnPayment connexpay env pid amt = doRequest_ connexpay env "returns" RequestBody + { raw = object $ catMaybes + [ Just $ "SaleGuid" .= show @SaleGuid pid + , ("Amount" .=) <$> amt + ] + , logMasker = id + } diff --git a/connexpay/src/Web/Connexpay/Payments/Types.hs b/connexpay/src/Web/Connexpay/Payments/Types.hs new file mode 100644 index 0000000..5f84346 --- /dev/null +++ b/connexpay/src/Web/Connexpay/Payments/Types.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} + +module Web.Connexpay.Payments.Types where + +import Data.Aeson +import Data.Aeson.TH +import Data.Fixed +import Data.Int (Int32) +import Data.Maybe +import Data.Text (Text) +import Data.Text qualified as Text +import GHC.TypeError as TypeError +import Text.Printf + +import Web.Connexpay.Http +import Web.Connexpay.Types +import Web.Connexpay.Utils + + +data AuthRequest = AuthRequest + { card :: CreditCard + , amount :: USD + , orderNumber :: Maybe Text + , statementDescription :: Maybe Text + -- ^ Merchant description that will appear in a + -- customer's statement. + , riskData :: RiskData + } + +maskAuthRequest :: LogMasker AuthRequest +maskAuthRequest req = AuthRequest + { card = maskCreditCard req.card + , amount = req.amount + , orderNumber = starWords <$> req.orderNumber + , statementDescription = req.statementDescription + , riskData = maskRiskData req.riskData + } + +newtype USD = USD Centi + deriving newtype (Read, FromJSON, ToJSON) + +-- | Credit card info +-- No 'Show' instance should be made for this type +-- in order to avoid sensitive data leaks. +data CreditCard = CreditCard + { cardNumber :: Text + , cardHolderName :: Maybe Text + , expirationDate :: ExpirationDate + , cvv2 :: Maybe Text + , customer :: Maybe Customer + -- ^ Required to get AVS + } + +type ShowError = TypeError.Text + "CreditCard must not be shown in order to avoid leaking sensitive data" + +instance TypeError ShowError => Show CreditCard where + show = error "UNREACHABLE" + +maskCreditCard :: LogMasker CreditCard +maskCreditCard cc = CreditCard + { cardNumber = maskCreditCardNumber cc.cardNumber + , cardHolderName = starWords <$> cc.cardHolderName + , expirationDate = maskExpirationDate cc.expirationDate + , cvv2 = starWords <$> cc.cvv2 + , customer = maskCustomer <$> cc.customer + } + +maskCreditCardNumber :: Text -> Text +maskCreditCardNumber number = firstDigits <> stars <> lastDigits + where + (firstDigits, rest) = Text.splitAt 4 number + toDrop = Text.length rest - 4 + (_, lastDigits) = Text.splitAt toDrop rest + stars = Text.replicate toDrop "*" + +data ExpirationDate = ExpirationDate + { year :: Word + -- ^ Last 2 digits of the year in range from 0 (2000) to 99 (2099). + -- No check is performed whether the value fits into the range. + , month :: Word + -- ^ Month of year, in range 1 (January) to 12 (December). + -- No check is performed whether the value fits into the range. + } + +instance ToJSON ExpirationDate where + toJSON expiry = + toJSON (printf "%02d%02d" expiry.year expiry.month :: String) + +maskExpirationDate :: LogMasker ExpirationDate +maskExpirationDate _ = ExpirationDate + { year = 0 + , month = 0 + } + +data Customer = Customer + { address1 :: Text + , address2 :: Maybe Text + , zip :: Maybe Text + } + +maskCustomer :: LogMasker Customer +maskCustomer customer = Customer + { address1 = starWords customer.address1 + , address2 = starWords <$> customer.address2 + , zip = customer.zip + } + +-- | Currently unpopulated +data RiskData = RiskData + +instance ToJSON RiskData where + toJSON RiskData = Object mempty + +maskRiskData :: LogMasker RiskData +maskRiskData = id + +data AuthResponse = AuthResponse + { guid :: AuthOnlyGuid + , status :: TransactionStatus + , processorStatusCode :: Maybe Text + , processorResponseMessage :: Maybe Text + , addressVerificationCode :: Maybe Text + , cvvVerificationCode :: Maybe Text + } deriving stock (Show) + +-- | Transaction status in Connexpay +-- The list is taken from https://docs.connexpay.com/reference/search-sales +data TransactionStatus + = TransactionApproved + | TransactionApprovedWarning + | TransactionCreatedLocal + -- ^ Seems to only exist in a test environment, indicates success. + | TransactionDeclined + | TransactionCreatedProcNotReached + -- ^ Communication error between Connexpay and Card Processor + | TransactionCreatedProcError + -- ^ Processor errored out + | TransactionOther Text + -- ^ In case they return something unexpected + deriving stock (Show) + +instance FromJSON TransactionStatus where + parseJSON = withText "TransactionStatus" $ pure . \case + "Transaction - Approved" -> TransactionApproved + "Transaction - Approved - Warning" -> TransactionApprovedWarning + "Transaction - CreatedLocal" -> TransactionCreatedLocal + "Transaction - Declined" -> TransactionDeclined + "Transaction - Created - Error: Processor not reached" -> + TransactionCreatedProcNotReached + "Transaction - Processor Error" -> TransactionCreatedProcError + other -> TransactionOther other + +data AuthError + = CVVFailed -- ^ CVV verification failure + | CardInvalid -- ^ Credit card details are invalid + | InvalidAmount -- ^ Money amount is invalid + | GeneralDecline -- ^ They just decline + | OtherAuthError Text -- ^ Some other processing error with 422 code + deriving stock (Show) + +-- | Guess failure type from error string. +guessAuthError :: Error () -> AuthError +guessAuthError err = case err.message of + "Error code D2020. CVV2 verification failed." -> CVVFailed + "Error code D2005. Invalid Card." -> CardInvalid + "Amount field don't allow a value greater than $999,999.99" -> InvalidAmount + "Error code D2999. General CardAuth Decline." -> GeneralDecline + txt -> OtherAuthError txt + +data VoidRequest + = VoidAuthorized AuthOnlyGuid + | VoidCaptured SaleGuid (Maybe USD) + +instance ToJSON VoidRequest where + toJSON = \case + VoidAuthorized pid -> object ["AuthOnlyGuid" .= show @AuthOnlyGuid pid] + VoidCaptured pid mbAmount -> object $ catMaybes + [ Just $ "SaleGuid" .= show pid + , ("Amount" .=) <$> mbAmount + ] + +-- | Internal data type for Capture requests. +data CPTransaction = CPTransaction + { expectedPayments :: Int32 + } + +instance ToJSON CPTransaction where + toJSON t = object [ "ExpectedPayments" .= t.expectedPayments ] + +-- | Response for the payment capture request +data CaptureResponse = CaptureResponse + { guid :: CaptureGuid + , sale :: Sale + } deriving stock (Show) + +data Sale = Sale + { guid :: SaleGuid + , status :: TransactionStatus + } deriving stock (Show) + +concat <$> sequence + [ deriveToJSON aesonOptions ''AuthRequest + , deriveToJSON aesonOptions ''CreditCard + , deriveToJSON aesonOptions ''Customer + , deriveFromJSON defaultOptions ''AuthResponse + , deriveFromJSON defaultOptions ''CaptureResponse + , deriveFromJSON defaultOptions ''Sale + ] diff --git a/connexpay/src/Web/Connexpay/Types.hs b/connexpay/src/Web/Connexpay/Types.hs index c8689c6..7a1e799 100644 --- a/connexpay/src/Web/Connexpay/Types.hs +++ b/connexpay/src/Web/Connexpay/Types.hs @@ -1,81 +1,88 @@ module Web.Connexpay.Types where -import Web.Connexpay.Data -import Web.Connexpay.Utils - import Control.Concurrent.Async -import Control.Concurrent.MVar (MVar, readMVar) -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 Control.Concurrent.MVar (MVar) +import Data.Aeson hiding (Error) +import Data.Bifunctor import Data.Text (Text) -import Data.Text qualified as Text -import Data.Text.Encoding qualified as Text import Data.UUID (UUID) -import Network.HTTP.Client as Client -import Network.HTTP.Req -import Network.HTTP.Types - -type BearerToken = Text -type DeviceGuid = UUID -type AuthOnlyGuid = UUID -type SaleGuid = UUID -type CaptureGuid = UUID - -data Connexpay = Connexpay { logAction :: Text -> IO () - , manager :: Manager - , bearerToken :: MVar (Maybe BearerToken) - , refreshAsync :: Maybe (Async ()) - , deviceGuid :: DeviceGuid - , url :: Text - , useTLS :: Bool - , login :: Text - , password :: Text - } - -newtype ConnexpayM a = ConnexpayM (ReaderT Connexpay (ExceptT ConnexpayError IO) a) - deriving newtype - (Functor, Applicative, Monad, MonadIO, MonadReader Connexpay, MonadError ConnexpayError) - -instance MonadHttp ConnexpayM where - handleHttpException (JsonHttpException e) = throwError (ConnectionError $ ParseError e) - handleHttpException (VanillaHttpException (InvalidUrlException url why)) = throwError (ConnectionError $ InvalidUrl url why) - handleHttpException (VanillaHttpException (HttpExceptionRequest _ (StatusCodeException resp bs))) - | Just err <- decodeStrict @ErrorMessage bs - , Just f <- guessFailure (statusCode $ responseStatus resp) err.message = throwError (PaymentFailure f (Just err.message)) - handleHttpException (VanillaHttpException (HttpExceptionRequest _ c)) = throwError (ConnectionError $ HttpFailure c) - - getHttpConfig = - do mgr <- asks (.manager) - log_ <- asks (.logAction) - let cfg = - defaultHttpConfig - { httpConfigAltManager = Just mgr - , httpConfigBodyPreviewLength = 8192 - -- ^ Default of 1024 is definitely not enough - , httpConfigLogResponse = logResponse log_ } - pure cfg - - -runConnexpay :: Connexpay -> ConnexpayM a -> IO (Either ConnexpayError a) -runConnexpay cp (ConnexpayM a) = runExceptT (runReaderT a cp) - -runConnexpay_ :: Connexpay -> ConnexpayM a -> IO () -runConnexpay_ cp m = - do r <- runConnexpay cp m - whenLeft r $ \err -> - cp.logAction ("Uncaught Connexpay error: " <> Text.pack (show err)) - -bearerToken :: ConnexpayM (Maybe BearerToken) -bearerToken = do v <- asks (.bearerToken) - liftIO (readMVar v) - -logResponse :: (Text -> IO ()) -> Request -> Response a -> ByteString -> IO () -logResponse log_ _req resp body = log_ msg - where msg = Text.unlines [ "Connexpay response:" - , "HTTP code: " <> tshow (statusCode (responseStatus resp)) - , "Headers: " <> tshow (Client.responseHeaders resp) - , "Body: " <> Text.decodeUtf8Lenient body - ] +import Network.HTTP.Client (Manager) + + +newtype BearerToken = BearerToken + { unBearerToken :: Text + } deriving newtype (Show, FromJSON, ToJSON) + +newtype DeviceGuid = DeviceGuid + { unDeviceGuid :: UUID + } deriving (Read, Show, FromJSON, ToJSON) via UUID + +newtype AuthOnlyGuid = AuthOnlyGuid + { unAuthOnlyGuid :: Text + } deriving newtype (Show, FromJSON, ToJSON) + +newtype SaleGuid = SaleGuid + { unSaleGuid :: Text + } deriving newtype (Show, FromJSON, ToJSON) + +newtype CaptureGuid = CaptureGuid + { unCaptureGuid :: Text + } deriving newtype (Show, FromJSON, ToJSON) + +type Logger = Text -> IO () + +data Config = Config + { host :: Text + , login :: Text + , password :: Text + , deviceGuid :: Text + , useTLS :: Bool + } + +data Connexpay = Connexpay + { config :: Config + , bearerToken :: MVar (Maybe BearerToken) + , refreshAsync :: Async () + } + +data Env = Env + { logAction :: Logger + , manager :: Manager + } + +data Response e a + = ResponseSuccess a + | ResponseError (Error e) + -- ^ Response structured error (422 status code) is received + | MissingOrExpiredToken + -- ^ Most likely invalid credentials/URL are passed during initialization. + -- No request is even sent to Connexpay. + deriving stock (Show, Functor) + +instance Bifunctor Response where + bimap f = bimapResponse (fmap f) + +bimapResponse + :: (Error e -> Error e') -> (a -> b) -> Response e a -> Response e' b +bimapResponse f g = \case + ResponseSuccess a -> ResponseSuccess (g a) + ResponseError e -> ResponseError (f e) + MissingOrExpiredToken -> MissingOrExpiredToken + +guessResponseErrorType :: (Error () -> e) -> Response () a -> Response e a +guessResponseErrorType mkErr = bimapResponse (\e -> e { errorType = mkErr e }) id + +data Error e = Error + { message :: Text + , errorId :: Text + , errorType :: e + } deriving stock (Show, Functor) + +instance FromJSON (Error ()) where + parseJSON = withObject "Error" \o -> do + message <- o .: "message" + errorId <- o .: "error_id" + pure Error + { errorType = () + , .. + } diff --git a/connexpay/src/Web/Connexpay/Utils.hs b/connexpay/src/Web/Connexpay/Utils.hs index 48af408..2c3e95c 100644 --- a/connexpay/src/Web/Connexpay/Utils.hs +++ b/connexpay/src/Web/Connexpay/Utils.hs @@ -1,15 +1,10 @@ module Web.Connexpay.Utils where +import Data.Aeson.Types import Data.Char import Data.Text (Text) import Data.Text qualified as Text -import Network.HTTP.Client qualified as Client -import Network.HTTP.Req -import Network.HTTP.Types -whenLeft :: Monad m => Either a b -> (a -> m ()) -> m () -whenLeft (Left l) f = f l -whenLeft (Right _) _ = pure () whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenJust (Just x) f = f x @@ -18,12 +13,17 @@ whenJust Nothing _ = pure () tshow :: Show a => a -> Text tshow = Text.pack . show ---responseHeaders :: HttpResponse response => response -> [Header] ---responseHeaders = Client.responseHeaders . toVanillaResponse - -responseCode :: HttpResponse response => response -> Int -responseCode = statusCode . Client.responseStatus . toVanillaResponse +starWords :: Text -> Text +starWords = Text.unwords . map toStars . Text.words + where toStars w = Text.replicate (Text.length w) "*" capitalize :: String -> String capitalize [] = [] capitalize (x : xs) = toUpper x : xs + +aesonOptions :: Options +aesonOptions = defaultOptions + { fieldLabelModifier = capitalize + , tagSingleConstructors = True + , omitNothingFields = True + } diff --git a/connexpay/tool/Main.hs b/connexpay/tool/Main.hs index 5f4ce53..8097618 100644 --- a/connexpay/tool/Main.hs +++ b/connexpay/tool/Main.hs @@ -4,40 +4,46 @@ module Main where import Control.Concurrent (yield) import Control.Monad -import Control.Monad.IO.Class import Data.Aeson -import Data.Fixed +import Data.Coerce import Data.Maybe (fromMaybe) -import Data.Money import Data.Text (Text) import Data.Text.Encoding qualified as Text import Data.Text.IO qualified as Text -import Data.UUID import Data.Yaml (decodeFileThrow) import GHC.Generics import Network.HTTP.Client import Network.HTTP.Client.TLS import Options.Applicative -import Web.Connexpay +import Web.Connexpay.Init +import Web.Connexpay.Payments import Web.Connexpay.Types -data Config = Config { login :: Text - , password :: Text - , host :: Text - , device_guid :: UUID - , use_tls :: Bool - , proxy_host :: Maybe Text - , proxy_port :: Maybe Word - } deriving stock Generic -instance FromJSON Config +data ConfigYaml = ConfigYaml + { login :: Text + , password :: Text + , host :: Text + , deviceGuid :: Text + , useTLS :: Bool + , proxyHost :: Maybe Text + , proxyPort :: Maybe Word + } deriving stock Generic -data Command = AuthSale CreditCard Centi +instance FromJSON ConfigYaml where + parseJSON = genericParseJSON defaultOptions + { fieldLabelModifier = camelTo2 '_' + } + +configFromYaml :: ConfigYaml -> Config +configFromYaml ConfigYaml{..} = Config{..} + +data Command = AuthSale CreditCard USD | VoidAuth AuthOnlyGuid - | VoidSale SaleGuid (Maybe Centi) + | VoidSale SaleGuid (Maybe USD) | CaptureSale AuthOnlyGuid | CancelSale SaleGuid - | ReturnSale SaleGuid (Maybe Centi) + | ReturnSale SaleGuid (Maybe USD) | TestAuth data CmdLine = CmdLine { configPath :: FilePath @@ -67,36 +73,41 @@ cmdParser = CmdLine <$> strOption (short 'c' <> metavar "FILE" <> help "Configur } ) expdate = do s <- str guard (length s == 4) - pure (read (take 2 s), read (drop 2 s)) - guid = argument auto (metavar "Payment UUID") + let (month, year) = splitAt 2 s + pure ExpirationDate + { year = read year + , month = read month + } + guid :: (Coercible Text guid) => Parser guid + guid = coerce @Text <$> strArgument (metavar "Payment UUID") writeLog :: Text -> IO () writeLog msg = Text.putStrLn ("Connexpay log: " <> msg) main :: IO () main = do cmdLine <- execParser (info (cmdParser <**> helper) mempty) - cnf :: Config <- decodeFileThrow cmdLine.configPath - mgr <- fromMaybe newTlsManager - $ do host <- cnf.proxy_host - port <- cnf.proxy_port + cnf :: ConfigYaml <- decodeFileThrow cmdLine.configPath + manager <- fromMaybe newTlsManager + $ do host <- cnf.proxyHost + port <- cnf.proxyPort let proxy = useProxy (Proxy (Text.encodeUtf8 host) (fromIntegral port)) s = managerSetProxy proxy defaultManagerSettings return (newManager s) - res <- initConnexpay writeLog mgr cnf.device_guid cnf.host cnf.use_tls cnf.login cnf.password - case res of - Left err -> putStrLn ("Error: " <> show err) - Right cpi -> print =<< runConnexpay cpi (doThing cmdLine.operation) + cpi <- initConnexpay writeLog manager $ configFromYaml cnf + doThing cpi Env{ logAction = writeLog, manager } cmdLine.operation -doThing :: Command -> ConnexpayM () -doThing (AuthSale creditCard amt) = liftIO . print =<< authorisePayment AuthRequest - { creditCard - , amount = Money amt - , invoice = Just "PNRPNR" - , vendor = Just "Typeable payment" - } -doThing (VoidAuth guid) = liftIO . print =<< voidPayment (VoidAuthorized guid) -doThing (VoidSale guid amt) = liftIO . print =<< voidPayment (VoidCaptured guid (Money <$> amt)) -doThing (CaptureSale guid) = liftIO . print =<< capturePayment guid -doThing (CancelSale guid) = liftIO . print =<< cancelPayment guid -doThing (ReturnSale guid amt) = liftIO . print =<< returnPayment guid (Money <$> amt) -doThing TestAuth = liftIO (forever yield) +doThing :: Connexpay -> Env -> Command -> IO () +doThing cp env = \case + AuthSale card amount -> print =<< authorisePayment cp env AuthRequest + { card + , amount + , orderNumber = Just "PNRPNR" + , statementDescription = Just "Typeable payment" + , riskData = RiskData + } + VoidAuth guid -> print =<< voidPayment cp env (VoidAuthorized guid) + VoidSale guid amt -> print =<< voidPayment cp env (VoidCaptured guid amt) + CaptureSale guid -> print =<< capturePayment cp env guid + CancelSale guid -> print =<< cancelPayment cp env guid + ReturnSale guid amt -> print =<< returnPayment cp env guid amt + TestAuth -> forever yield diff --git a/stack.yaml b/stack.yaml index b4ff741..179c60b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,11 +4,7 @@ packages: - connexpay - connexpay-optparse -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 From c6e760329eefe5d3b5eb31db01dbc3f5aaf3a627 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Thu, 19 Jun 2025 09:54:08 +0300 Subject: [PATCH 02/11] Cli --- connexpay-optparse/src/Web/Connexpay/Cli.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/connexpay-optparse/src/Web/Connexpay/Cli.hs b/connexpay-optparse/src/Web/Connexpay/Cli.hs index f1aa024..5389a3f 100644 --- a/connexpay-optparse/src/Web/Connexpay/Cli.hs +++ b/connexpay-optparse/src/Web/Connexpay/Cli.hs @@ -11,8 +11,8 @@ connexpayOpts = do host <- option str (long "connexpay-endpoint" <> metavar "URL") login <- option str (long "connexpay-login" <> metavar "LOGIN") password <- option str (long "connexpay-password" <> metavar "PASSWORD") - deviceGuid <- option auto (long "connexpay-devguid" <> metavar "GUID") - useHttp <- switch (long "use-http" <> help "Use plain HTTP instead. Insecure!") + deviceGuid <- option str (long "connexpay-devguid" <> metavar "GUID") + useHttp <- switch (long "use-http" <> help "Use plain HTTP. Insecure!") pure Config { useTLS = not useHttp , .. From 822807710a3f46317c945392c578754fa6a6d98f Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Mon, 23 Jun 2025 16:26:32 +0300 Subject: [PATCH 03/11] Using 'show' for anything other than debug is considered harmful --- connexpay/src/Web/Connexpay/Payments.hs | 6 +++--- connexpay/src/Web/Connexpay/Payments/Types.hs | 4 ++-- connexpay/src/Web/Connexpay/Utils.hs | 7 ------- 3 files changed, 5 insertions(+), 12 deletions(-) diff --git a/connexpay/src/Web/Connexpay/Payments.hs b/connexpay/src/Web/Connexpay/Payments.hs index 393e1c9..1d82229 100644 --- a/connexpay/src/Web/Connexpay/Payments.hs +++ b/connexpay/src/Web/Connexpay/Payments.hs @@ -48,7 +48,7 @@ capturePayment :: Connexpay -> IO (Response () CaptureResponse) capturePayment connexpay env pid = doRequest connexpay env "Captures" RequestBody { raw = object - [ "AuthOnlyGuid" .= show @AuthOnlyGuid pid + [ "AuthOnlyGuid" .= pid , "ConnexPayTransaction" .= CPTransaction 1 ] , logMasker = id @@ -62,7 +62,7 @@ cancelPayment :: Connexpay -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'. -> IO (Response () ()) cancelPayment connexpay env pid = doRequest_ connexpay env "cancel" RequestBody - { raw = object [ "SaleGuid" .= show pid ] + { raw = object [ "SaleGuid" .= pid ] , logMasker = id } @@ -73,7 +73,7 @@ returnPayment :: Connexpay -> IO (Response () ()) returnPayment connexpay env pid amt = doRequest_ connexpay env "returns" RequestBody { raw = object $ catMaybes - [ Just $ "SaleGuid" .= show @SaleGuid pid + [ Just $ "SaleGuid" .= pid , ("Amount" .=) <$> amt ] , logMasker = id diff --git a/connexpay/src/Web/Connexpay/Payments/Types.hs b/connexpay/src/Web/Connexpay/Payments/Types.hs index 5f84346..2a0f959 100644 --- a/connexpay/src/Web/Connexpay/Payments/Types.hs +++ b/connexpay/src/Web/Connexpay/Payments/Types.hs @@ -175,9 +175,9 @@ data VoidRequest instance ToJSON VoidRequest where toJSON = \case - VoidAuthorized pid -> object ["AuthOnlyGuid" .= show @AuthOnlyGuid pid] + VoidAuthorized pid -> object ["AuthOnlyGuid" .= pid] VoidCaptured pid mbAmount -> object $ catMaybes - [ Just $ "SaleGuid" .= show pid + [ Just $ "SaleGuid" .= pid , ("Amount" .=) <$> mbAmount ] diff --git a/connexpay/src/Web/Connexpay/Utils.hs b/connexpay/src/Web/Connexpay/Utils.hs index 2c3e95c..ee9a1cd 100644 --- a/connexpay/src/Web/Connexpay/Utils.hs +++ b/connexpay/src/Web/Connexpay/Utils.hs @@ -6,13 +6,6 @@ import Data.Text (Text) import Data.Text qualified as Text -whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenJust (Just x) f = f x -whenJust Nothing _ = pure () - -tshow :: Show a => a -> Text -tshow = Text.pack . show - starWords :: Text -> Text starWords = Text.unwords . map toStars . Text.words where toStars w = Text.replicate (Text.length w) "*" From e34c07e0b960eb1042552401f3a5f2736c466559 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Mon, 23 Jun 2025 17:11:56 +0300 Subject: [PATCH 04/11] Log with DeviceGuid --- connexpay/src/Web/Connexpay/Http.hs | 24 +++++++++++++++++++----- connexpay/src/Web/Connexpay/Types.hs | 5 ----- 2 files changed, 19 insertions(+), 10 deletions(-) diff --git a/connexpay/src/Web/Connexpay/Http.hs b/connexpay/src/Web/Connexpay/Http.hs index cd11fba..68c7851 100644 --- a/connexpay/src/Web/Connexpay/Http.hs +++ b/connexpay/src/Web/Connexpay/Http.hs @@ -13,6 +13,7 @@ import Data.Aeson import Data.Aeson.Text import Data.ByteString.Lazy qualified as Lazy (ByteString) import Data.ByteString.Lazy qualified as Lazy.ByteString +import Data.Functor import Data.Text (Text) import Data.Text.Encoding qualified as Text import Data.Text.Lazy qualified as Lazy.Text @@ -30,6 +31,21 @@ data RequestBody a = RequestBody type LogMasker a = a -> a +renderRequestBody + :: forall a. (ToJSON a) + => Connexpay + -> RequestBody a + -> (HTTP.RequestBody, Value) +renderRequestBody connexpay body = + ( HTTP.RequestBodyLBS $ encode $ withGuid connexpay.config.deviceGuid body.raw + , withGuid "" $ body.logMasker body.raw + ) + where + withGuid :: Text -> a -> Value + withGuid guid = toJSON <&> \case + Object o -> Object $ o <> "DeviceGuid" .= guid + v -> v + doRequest :: (ToJSON req, FromJSON resp) => Connexpay @@ -53,14 +69,12 @@ doRequest connexpay env endpoint body = readMVar connexpay.bearerToken >>= \case , ("Accept", "application/json") , ("Accept-Encoding", "gzip") ] - , HTTP.requestBody = HTTP.RequestBodyLBS $ encode - case toJSON body.raw of - Object o -> Object $ o <> "DeviceGuid" .= connexpay.config.deviceGuid - v -> v + , HTTP.requestBody = requestBody } + (requestBody, bodyLog) = renderRequestBody connexpay body env.logAction $ httpLog req $ mconcat [ "request" .= show @HTTP.Request req - , "body" .= body.logMasker body.raw + , "body" .= bodyLog ] resp <- HTTP.httpLbs req env.manager env.logAction $ httpLog req $ mconcat diff --git a/connexpay/src/Web/Connexpay/Types.hs b/connexpay/src/Web/Connexpay/Types.hs index 7a1e799..bd5819a 100644 --- a/connexpay/src/Web/Connexpay/Types.hs +++ b/connexpay/src/Web/Connexpay/Types.hs @@ -5,7 +5,6 @@ import Control.Concurrent.MVar (MVar) import Data.Aeson hiding (Error) import Data.Bifunctor import Data.Text (Text) -import Data.UUID (UUID) import Network.HTTP.Client (Manager) @@ -13,10 +12,6 @@ newtype BearerToken = BearerToken { unBearerToken :: Text } deriving newtype (Show, FromJSON, ToJSON) -newtype DeviceGuid = DeviceGuid - { unDeviceGuid :: UUID - } deriving (Read, Show, FromJSON, ToJSON) via UUID - newtype AuthOnlyGuid = AuthOnlyGuid { unAuthOnlyGuid :: Text } deriving newtype (Show, FromJSON, ToJSON) From 2c978eb2e69e029843585bc6025c83333a7b800b Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Mon, 23 Jun 2025 17:14:13 +0300 Subject: [PATCH 05/11] Unused package --- connexpay/connexpay.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/connexpay/connexpay.cabal b/connexpay/connexpay.cabal index efa47a2..9395c87 100644 --- a/connexpay/connexpay.cabal +++ b/connexpay/connexpay.cabal @@ -52,7 +52,6 @@ library , http-types , safe-exceptions , text - , uuid hs-source-dirs: src executable connexpay-tool From f380353b0eda61a98134b0dd74c599ab82a446b2 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Mon, 23 Jun 2025 17:20:25 +0300 Subject: [PATCH 06/11] Tidy up --- .github/workflows/haskell-ci.yml | 5 ----- 1 file changed, 5 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index a799c02..b95cb61 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -165,11 +165,6 @@ jobs: echo "package connexpay-optparse" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project cat >> cabal.project < Date: Tue, 24 Jun 2025 17:18:51 +0300 Subject: [PATCH 07/11] Error parser --- connexpay/src/Web/Connexpay/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/connexpay/src/Web/Connexpay/Types.hs b/connexpay/src/Web/Connexpay/Types.hs index bd5819a..b287c2c 100644 --- a/connexpay/src/Web/Connexpay/Types.hs +++ b/connexpay/src/Web/Connexpay/Types.hs @@ -76,7 +76,7 @@ data Error e = Error instance FromJSON (Error ()) where parseJSON = withObject "Error" \o -> do message <- o .: "message" - errorId <- o .: "error_id" + errorId <- o .: "errorId" pure Error { errorType = () , .. From ebdc150a24847c514a02e63ba8ac0f497cea0b40 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Wed, 25 Jun 2025 14:34:12 +0300 Subject: [PATCH 08/11] Amount is mandatory on refund --- connexpay/src/Web/Connexpay/Payments.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/connexpay/src/Web/Connexpay/Payments.hs b/connexpay/src/Web/Connexpay/Payments.hs index 1d82229..86662bb 100644 --- a/connexpay/src/Web/Connexpay/Payments.hs +++ b/connexpay/src/Web/Connexpay/Payments.hs @@ -18,7 +18,6 @@ module Web.Connexpay.Payments ) where import Data.Aeson -import Data.Maybe import Web.Connexpay.Http import Web.Connexpay.Payments.Types @@ -69,12 +68,12 @@ cancelPayment connexpay env pid = doRequest_ connexpay env "cancel" RequestBody returnPayment :: Connexpay -> Env -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'. - -> Maybe USD + -> USD -> IO (Response () ()) returnPayment connexpay env pid amt = doRequest_ connexpay env "returns" RequestBody - { raw = object $ catMaybes - [ Just $ "SaleGuid" .= pid - , ("Amount" .=) <$> amt + { raw = object + [ "SaleGuid" .= pid + , "Amount" .= amt ] , logMasker = id } From b5f33df79070476cc502a58c0b26aa723eb07cb5 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Wed, 25 Jun 2025 14:34:25 +0300 Subject: [PATCH 09/11] Wait for token in test tool --- connexpay/tool/Main.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/connexpay/tool/Main.hs b/connexpay/tool/Main.hs index 8097618..df7ec54 100644 --- a/connexpay/tool/Main.hs +++ b/connexpay/tool/Main.hs @@ -2,7 +2,7 @@ module Main where -import Control.Concurrent (yield) +import Control.Concurrent import Control.Monad import Data.Aeson import Data.Coerce @@ -43,7 +43,7 @@ data Command = AuthSale CreditCard USD | VoidSale SaleGuid (Maybe USD) | CaptureSale AuthOnlyGuid | CancelSale SaleGuid - | ReturnSale SaleGuid (Maybe USD) + | ReturnSale SaleGuid USD | TestAuth data CmdLine = CmdLine { configPath :: FilePath @@ -58,7 +58,7 @@ cmdParser = CmdLine <$> strOption (short 'c' <> metavar "FILE" <> help "Configur <> command "void-sale" (info (VoidSale <$> guid <*> optional amt) (progDesc "Void payment")) <> command "capture" (info (CaptureSale <$> guid) (progDesc "Capture payment")) <> command "cancel" (info (CancelSale <$> guid) (progDesc "Cancel payment")) - <> command "return" (info (ReturnSale <$> guid <*> optional amt) (progDesc "return payment")) + <> command "return" (info (ReturnSale <$> guid <*> amt) (progDesc "return payment")) <> command "test-auth" (info (pure TestAuth) (progDesc "Test token authorisation")) amt = argument auto (metavar "Payment amount") cc = CreditCard <$> argument str mempty @@ -94,8 +94,14 @@ main = do cmdLine <- execParser (info (cmdParser <**> helper) mempty) s = managerSetProxy proxy defaultManagerSettings return (newManager s) cpi <- initConnexpay writeLog manager $ configFromYaml cnf + waitToken cpi doThing cpi Env{ logAction = writeLog, manager } cmdLine.operation +waitToken :: Connexpay -> IO () +waitToken cp = readMVar cp.bearerToken >>= \case + Nothing -> threadDelay 500_000 >> waitToken cp + Just _ -> pure () + doThing :: Connexpay -> Env -> Command -> IO () doThing cp env = \case AuthSale card amount -> print =<< authorisePayment cp env AuthRequest From 488404fca11eac4db78fbe9fc30f6d993a816302 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Wed, 25 Jun 2025 14:34:55 +0300 Subject: [PATCH 10/11] Update gitignore --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index b91670a..4c975d7 100644 --- a/.gitignore +++ b/.gitignore @@ -27,3 +27,5 @@ stack.yaml.lock # Temp files *~ \#*\# + +config.yml From c9533c9311a82c5e3ef487a15578f774dee1cd78 Mon Sep 17 00:00:00 2001 From: Uladzimir Stsepchanka Date: Thu, 26 Jun 2025 11:49:47 +0300 Subject: [PATCH 11/11] Detect bad request --- connexpay/src/Web/Connexpay/Http.hs | 2 ++ connexpay/src/Web/Connexpay/Types.hs | 3 +++ 2 files changed, 5 insertions(+) diff --git a/connexpay/src/Web/Connexpay/Http.hs b/connexpay/src/Web/Connexpay/Http.hs index 68c7851..6981314 100644 --- a/connexpay/src/Web/Connexpay/Http.hs +++ b/connexpay/src/Web/Connexpay/Http.hs @@ -115,6 +115,8 @@ fromResponse resp eitherDecode resp.responseBody | resp.responseStatus == unauthorized401 = pure MissingOrExpiredToken + | resp.responseStatus == badRequest400 + = pure $ BadRequest resp.responseBody | resp.responseStatus == unprocessableEntity422 = either (Left . ResponseErrorParseError resp) (Right . ResponseError) $ eitherDecode resp.responseBody diff --git a/connexpay/src/Web/Connexpay/Types.hs b/connexpay/src/Web/Connexpay/Types.hs index b287c2c..d142c91 100644 --- a/connexpay/src/Web/Connexpay/Types.hs +++ b/connexpay/src/Web/Connexpay/Types.hs @@ -4,6 +4,7 @@ import Control.Concurrent.Async import Control.Concurrent.MVar (MVar) import Data.Aeson hiding (Error) import Data.Bifunctor +import Data.ByteString.Lazy qualified as Lazy (ByteString) import Data.Text (Text) import Network.HTTP.Client (Manager) @@ -49,6 +50,7 @@ data Response e a = ResponseSuccess a | ResponseError (Error e) -- ^ Response structured error (422 status code) is received + | BadRequest Lazy.ByteString | MissingOrExpiredToken -- ^ Most likely invalid credentials/URL are passed during initialization. -- No request is even sent to Connexpay. @@ -62,6 +64,7 @@ bimapResponse bimapResponse f g = \case ResponseSuccess a -> ResponseSuccess (g a) ResponseError e -> ResponseError (f e) + BadRequest body -> BadRequest body MissingOrExpiredToken -> MissingOrExpiredToken guessResponseErrorType :: (Error () -> e) -> Response () a -> Response e a