9300166 · typeable/connexpay

git.iko.soy/typeable/connexpay

on master help sign in

Replace 'req' with 'http-client' (#8)

9300166Uladzimir Stsepchanka1 year ago

.github/workflows/haskell-ci.yml+4−8

compare with master

unifiedsplit

@@ -165,15 +165,11 @@ jobs:

165 echo "package connexpay-optparse" >> cabal.project

166 echo " ghc-options: -Werror=missing-methods" >> cabal.project

167 cat >> cabal.project <<EOF

168− source-repository-package

168+ package connexpay

169− type: git

169+ ghc-options: -Werror

170− location: https://github.com/typeable/bucks.git

171− tag: 9e378b675fe7fb88d5ddb3af068d82eb441f343c

172

170

173− source-repository-package

171+ package connexpay-optparse

174− type: git

172+ ghc-options: -Werror

175− location: https://github.com/typeable/req.git

176− tag: 8829ac5197f7a4b3f04b7fdfc3ea66cfe70ab0a5

177 EOF

173 EOF

178 $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(connexpay|connexpay-optparse)$/; }' >> cabal.project.local

174 $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(connexpay|connexpay-optparse)$/; }' >> cabal.project.local

179 cat cabal.project

175 cat cabal.project

.gitignore+2

@@ -27,3 +27,5 @@ stack.yaml.lock

27# Temp files

28*~

29\#*\#

30+

31+config.yml

cabal.haskell-ci+1

@@ -1 +1,2 @@

1branches: master

2+local-ghc-options: -Werror

cabal.project−10

@@ -3,13 +3,3 @@ with-compiler: ghc-9.6.6

3packages:

4 connexpay/

5 connexpay-optparse/

6−

7−source-repository-package

8− type: git

9− location: https://github.com/typeable/bucks.git

10− tag: 9e378b675fe7fb88d5ddb3af068d82eb441f343c

11−

12−source-repository-package

13− type: git

14− location: https://github.com/typeable/req.git

15− tag: 8829ac5197f7a4b3f04b7fdfc3ea66cfe70ab0a5

cabal.project.freeze+1−32

@@ -4,9 +4,6 @@ constraints: any.Cabal ==3.10.3.0,

4 any.OneTuple ==0.4.2,

5 any.QuickCheck ==2.14.3,

6 QuickCheck -old-random +templatehaskell,

7− any.RSA ==2.4.1,

8− any.SHA ==1.6.4.4,

9− SHA -exe,

10 any.StateVar ==1.2.2,

7 any.StateVar ==1.2.2,

11 any.aeson ==2.1.2.1,

8 any.aeson ==2.1.2.1,

12 aeson -cffi +ordered-keymap,

9 aeson -cffi +ordered-keymap,

@@ -25,7 +22,6 @@ constraints: any.Cabal ==3.10.3.0,

25 any.attoparsec ==0.14.4,

22 any.attoparsec ==0.14.4,

26 attoparsec -developer,

23 attoparsec -developer,

27 any.attoparsec-iso8601 ==1.1.1.0,

24 any.attoparsec-iso8601 ==1.1.1.0,

28− any.authenticate-oauth ==1.7,

29 any.base ==4.18.2.1,

25 any.base ==4.18.2.1,

30 any.base-compat ==0.13.1,

26 any.base-compat ==0.13.1,

31 any.base-compat-batteries ==0.13.1,

27 any.base-compat-batteries ==0.13.1,

@@ -38,8 +34,6 @@ constraints: any.Cabal ==3.10.3.0,

38 any.bitvec ==1.1.5.0,

34 any.bitvec ==1.1.5.0,

39 bitvec +simd,

35 bitvec +simd,

40 any.blaze-builder ==0.4.2.3,

36 any.blaze-builder ==0.4.2.3,

41− any.bucks ==0.1,

42− bucks -aeson -openapi -rel8,

43 any.byteorder ==1.0.4,

37 any.byteorder ==1.0.4,

44 any.bytestring ==0.11.5.3,

38 any.bytestring ==0.11.5.3,

45 any.case-insensitive ==1.2.1.0,

39 any.case-insensitive ==1.2.1.0,

@@ -53,9 +47,6 @@ constraints: any.Cabal ==3.10.3.0,

53 any.contravariant ==1.5.5,

47 any.contravariant ==1.5.5,

54 contravariant +semigroups +statevar +tagged,

48 contravariant +semigroups +statevar +tagged,

55 any.cookie ==0.4.6,

49 any.cookie ==0.4.6,

56− any.crypto-api ==0.13.3,

57− crypto-api -all_cpolys,

58− any.crypto-pubkey-types ==0.4.3,

59 any.cryptohash-md5 ==0.11.101.0,

50 any.cryptohash-md5 ==0.11.101.0,

60 any.cryptohash-sha1 ==0.11.101.0,

51 any.cryptohash-sha1 ==0.11.101.0,

61 any.crypton ==0.34,

52 any.crypton ==0.34,

@@ -65,11 +56,7 @@ constraints: any.Cabal ==3.10.3.0,

65 any.crypton-x509-store ==1.6.9,

56 any.crypton-x509-store ==1.6.9,

66 any.crypton-x509-system ==1.6.7,

57 any.crypton-x509-system ==1.6.7,

67 any.crypton-x509-validation ==1.6.12,

58 any.crypton-x509-validation ==1.6.12,

68− any.data-default ==0.7.1.1,

69 any.data-default-class ==0.1.2.0,

59 any.data-default-class ==0.1.2.0,

70− any.data-default-instances-containers ==0.0.1,

71− any.data-default-instances-dlist ==0.0.1,

72− any.data-default-instances-old-locale ==0.0.1,

73 any.data-fix ==0.3.4,

60 any.data-fix ==0.3.4,

74 any.deepseq ==1.4.8.1,

61 any.deepseq ==1.4.8.1,

75 any.directory ==1.3.8.5,

62 any.directory ==1.3.8.5,

@@ -85,7 +72,6 @@ constraints: any.Cabal ==3.10.3.0,

85 any.ghc-bignum ==1.3,

72 any.ghc-bignum ==1.3,

86 any.ghc-boot-th ==9.6.6,

73 any.ghc-boot-th ==9.6.6,

87 any.ghc-prim ==0.10.0,

74 any.ghc-prim ==0.10.0,

88− any.groups ==0.5.3,

89 any.hashable ==1.4.4.0,

75 any.hashable ==1.4.4.0,

90 hashable +integer-gmp -random-initial-seed,

76 hashable +integer-gmp -random-initial-seed,

91 any.hourglass ==0.2.12,

77 any.hourglass ==0.2.12,

@@ -107,18 +93,11 @@ constraints: any.Cabal ==3.10.3.0,

107 any.libyaml ==0.1.4,

93 any.libyaml ==0.1.4,

108 libyaml -no-unicode -system-libyaml,

94 libyaml -no-unicode -system-libyaml,

109 any.libyaml-clib ==0.2.5,

95 any.libyaml-clib ==0.2.5,

110− any.megaparsec ==9.5.0,

111− megaparsec -dev,

112 any.memory ==0.18.0,

96 any.memory ==0.18.0,

113 memory +support_bytestring +support_deepseq,

97 memory +support_bytestring +support_deepseq,

114 any.mime-types ==0.1.2.0,

98 any.mime-types ==0.1.2.0,

115− any.modern-uri ==0.3.6.1,

116− modern-uri -dev,

117− any.monad-control ==1.0.3.1,

118 any.mono-traversable ==1.0.20.0,

99 any.mono-traversable ==1.0.20.0,

119 any.mtl ==2.3.1,

100 any.mtl ==2.3.1,

120− any.mtl-compat ==0.2.2,

121− mtl-compat -two-point-one -two-point-two,

122 any.network ==3.1.4.0,

101 any.network ==3.1.4.0,

123 network -devel,

102 network -devel,

124 any.network-info ==0.2.1,

103 any.network-info ==0.2.1,

@@ -129,8 +108,6 @@ constraints: any.Cabal ==3.10.3.0,

129 optparse-applicative +process,

108 optparse-applicative +process,

130 any.os-string ==2.0.6,

109 any.os-string ==2.0.6,

131 any.parsec ==3.1.16.1,

110 any.parsec ==3.1.16.1,

132− any.parser-combinators ==1.3.0,

133− parser-combinators -dev,

134 any.pem ==0.2.4,

111 any.pem ==0.2.4,

135 any.pretty ==1.1.3.6,

112 any.pretty ==1.1.3.6,

136 any.prettyprinter ==1.7.1,

113 any.prettyprinter ==1.7.1,

@@ -138,16 +115,10 @@ constraints: any.Cabal ==3.10.3.0,

138 any.prettyprinter-ansi-terminal ==1.1.3,

115 any.prettyprinter-ansi-terminal ==1.1.3,

139 any.primitive ==0.8.0.0,

116 any.primitive ==0.8.0.0,

140 any.process ==1.6.19.0,

117 any.process ==1.6.19.0,

141− any.profunctors ==5.6.2,

142 any.random ==1.2.1.2,

118 any.random ==1.2.1.2,

143− any.reflection ==2.1.8,

144− reflection -slow +template-haskell,

145− any.req ==3.13.4,

146− req -dev,

147 any.resourcet ==1.3.0,

119 any.resourcet ==1.3.0,

148− any.retry ==0.9.3.1,

149− retry -lib-werror,

150 any.rts ==1.0.2,

120 any.rts ==1.0.2,

121+ any.safe-exceptions ==0.1.7.4,

151 any.scientific ==0.3.7.0,

122 any.scientific ==0.3.7.0,

152 scientific -bytestring-builder -integer-simple,

123 scientific -bytestring-builder -integer-simple,

153 any.semialign ==1.3.1,

124 any.semialign ==1.3.1,

@@ -177,8 +148,6 @@ constraints: any.Cabal ==3.10.3.0,

177 any.tls ==1.8.0,

148 any.tls ==1.8.0,

178 tls +compat -hans +network,

149 tls +compat -hans +network,

179 any.transformers ==0.6.1.0,

150 any.transformers ==0.6.1.0,

180− any.transformers-base ==0.4.6,

181− transformers-base +orphaninstances,

182 any.transformers-compat ==0.7.2,

151 any.transformers-compat ==0.7.2,

183 transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,

152 transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,

184 any.unix ==2.8.4.0,

153 any.unix ==2.8.4.0,

connexpay-optparse/connexpay-optparse.cabal+19−5

@@ -14,15 +14,29 @@ build-type: Simple

15tested-with: GHC ==9.8.4 || ==9.6.6

17−common warnings

17+common common

18+ default-extensions:

19+ BlockArguments

20+ DeriveAnyClass

21+ DerivingVia

22+ DuplicateRecordFields

23+ LambdaCase

24+ MultiWayIf

25+ NoFieldSelectors

26+ OverloadedLabels

27+ OverloadedRecordDot

28+ OverloadedStrings

29+ RecordWildCards

30+ default-language: GHC2021

18− ghc-options: -Wall

31+ ghc-options:

32+ -Wall -Wmissing-deriving-strategies -Wprepositive-qualified-module

33+ -Wunused-packages -Wredundant-constraints

20library

35library

21− import: warnings

36+ import: common

22 exposed-modules: Web.Connexpay.Cli

37 exposed-modules: Web.Connexpay.Cli

23 build-depends: base >=4.14 && < 5.0

38 build-depends: base >=4.14 && < 5.0

39+ , connexpay

24 , optparse-applicative

40 , optparse-applicative

25− , text

26− , uuid

27 hs-source-dirs: src

41 hs-source-dirs: src

28 default-language: Haskell2010

42 default-language: Haskell2010

connexpay-optparse/src/Web/Connexpay/Cli.hs+14−13

@@ -1,18 +1,19 @@

1+{-# LANGUAGE ApplicativeDo #-}

1module Web.Connexpay.Cli where

3module Web.Connexpay.Cli where

3−import Data.UUID

4−import Data.Text (Text)

5import Options.Applicative

6+import Web.Connexpay.Types

7−data ConnexpayCli = ConnexpayCli { login :: Text

8− , password :: Text

9− , deviceGuid :: UUID

10− , endpoint :: Text

11− } deriving Show

13−connexpayOpts :: Parser ConnexpayCli

9+connexpayOpts :: Parser Config

14−connexpayOpts =

10+connexpayOpts = do

11+ host <- option str (long "connexpay-endpoint" <> metavar "URL")

15− ConnexpayCli <$> option str (long "connexpay-login" <> metavar "LOGIN")

12+ login <- option str (long "connexpay-login" <> metavar "LOGIN")

16− <*> option str (long "connexpay-password" <> metavar "PASSWORD")

13+ password <- option str (long "connexpay-password" <> metavar "PASSWORD")

17− <*> option auto (long "connexpay-devguid" <> metavar "GUID")

14+ deviceGuid <- option str (long "connexpay-devguid" <> metavar "GUID")

18− <*> option str (long "connexpay-endpoint" <> metavar "URL")

15+ useHttp <- switch (long "use-http" <> help "Use plain HTTP. Insecure!")

16+ pure Config

17+ { useTLS = not useHttp

18+ , ..

19+ }

connexpay/connexpay.cabal+10−13

@@ -34,38 +34,35 @@ common common

35library

36 import: common

37− exposed-modules: Web.Connexpay

37+ exposed-modules:

38+ Web.Connexpay.Init

39+ Web.Connexpay.Payments

40+ Web.Connexpay.Types

41+ other-modules:

38− Web.Connexpay.Auth

42+ Web.Connexpay.Auth

39− Web.Connexpay.Data

43+ Web.Connexpay.Http

40− Web.Connexpay.Init

41− Web.Connexpay.Payments

44+ Web.Connexpay.Payments.Types

42− Web.Connexpay.Types

43− Web.Connexpay.Utils

45+ Web.Connexpay.Utils

44 build-depends: base >=4.14 && < 5.0

46 build-depends: base >=4.14 && < 5.0

45 , aeson

47 , aeson

46 , async

48 , async

47− , bucks

48 , bytestring

49 , bytestring

49 , http-api-data

50 , http-api-data

50 , http-client

51 , http-client

51 , http-types

52 , http-types

52− , mtl

53+ , safe-exceptions

53− , req

54 , text

55− , uuid

56 hs-source-dirs: src

55 hs-source-dirs: src

58executable connexpay-tool

57executable connexpay-tool

59 import: common

58 import: common

60 build-depends: base >= 4.17

59 build-depends: base >= 4.17

61 , aeson

60 , aeson

62− , bucks

63 , connexpay

61 , connexpay

64 , http-client

62 , http-client

65 , http-client-tls

63 , http-client-tls

66 , optparse-applicative

64 , optparse-applicative

67 , text

65 , text

68− , uuid

69 , yaml

66 , yaml

70 hs-source-dirs: tool

67 hs-source-dirs: tool

71 main-is: Main.hs

68 main-is: Main.hs

connexpay/src/Web/Connexpay.hsdeleted−16

@@ -1,16 +0,0 @@

1−module Web.Connexpay ( module Payments

2− , initConnexpay

3− , Connexpay(..)

4− , ConnexpayM

5− , PaymentFailure(..)

6− , ConnectionError(..)

7− , ConnexpayError(..)

8− , TransactionStatus(..)

9− , describeFailure

10− , runConnexpay

11− ) where

12−

13−import Web.Connexpay.Data

14−import Web.Connexpay.Init

15−import Web.Connexpay.Payments as Payments

16−import Web.Connexpay.Types

connexpay/src/Web/Connexpay/Auth.hs+58−22

@@ -1,22 +1,31 @@

1{-# LANGUAGE OverloadedLists #-}

3−module Web.Connexpay.Auth (authenticate) where

3+module Web.Connexpay.Auth

4−

4+ ( AuthReply(..)

5−import Web.Connexpay.Types

5+ , TokenReply(..)

6+ , authenticate

7+ ) where

7import Control.Monad

9import Control.Monad

8−import Control.Monad.Reader

9import Data.Aeson

10import Data.Aeson

10import Data.Aeson.Types

11import Data.Aeson.Types

11import Data.ByteString (ByteString)

12import Data.ByteString (ByteString)

12import Data.ByteString qualified as ByteString

13import Data.ByteString qualified as ByteString

14+import Data.ByteString.Lazy qualified as Lazy

15+import Data.ByteString.Lazy qualified as Lazy.ByteString

13import Data.Text (Text)

16import Data.Text (Text)

14import Data.Text qualified as Text

17import Data.Text qualified as Text

18+import Data.Text.Encoding qualified as Text

19+import Network.HTTP.Client qualified as HTTP

15−import Network.HTTP.Req

20+import Network.HTTP.Types

16import Numeric.Natural

21import Numeric.Natural

17import Web.FormUrlEncoded

22import Web.FormUrlEncoded

18import Web.HttpApiData

23import Web.HttpApiData

25+import Web.Connexpay.Http

26+import Web.Connexpay.Types

27+

28+

20data AuthForm = AuthForm { login :: Text

29data AuthForm = AuthForm { login :: Text

21 , password :: Text

30 , password :: Text

22 }

31 }

@@ -27,12 +36,18 @@ instance ToForm AuthForm where

27 , ("password", toQueryParam auth.password)

36 , ("password", toQueryParam auth.password)

28 ]

37 ]

30−mkAuthForm :: Text -> Text -> ByteString

39+mkAuthForm :: Config -> ByteString

31−mkAuthForm login passwd = ByteString.toStrict (urlEncodeAsForm form)

40+mkAuthForm cfg = ByteString.toStrict (urlEncodeAsForm form)

32− where form = AuthForm login passwd

41+ where form = AuthForm cfg.login cfg.password

42+

43+data AuthReply

44+ = Authorized TokenReply

45+ | Unauthorized (HTTP.Response Lazy.ByteString)

46+ | AuthParseError String

47+ deriving stock (Show)

34data TokenReply = TokenReply { token :: BearerToken

49data TokenReply = TokenReply { token :: BearerToken

35− , expires_in :: Natural

50+ , expiresIn :: Natural

36 } deriving stock (Show)

51 } deriving stock (Show)

38instance FromJSON TokenReply where

53instance FromJSON TokenReply where

@@ -43,16 +58,37 @@ instance FromJSON TokenReply where

43 <*> v .: "expires_in"

58 <*> v .: "expires_in"

44 parseJSON v = typeMismatch "TokenReply" v

59 parseJSON v = typeMismatch "TokenReply" v

46−authenticate :: ConnexpayM (BearerToken, Natural)

61+authenticate :: Config -> Env -> IO AuthReply

47−authenticate = do login <- asks (.login)

62+authenticate config env = do

48− password <- asks (.password)

63+ let

49− host <- asks (.url)

64+ req = HTTP.defaultRequest

50− tls <- asks (.useTLS)

65+ { HTTP.method = "POST"

51− let body = ReqBodyBs (mkAuthForm login password)

66+ , HTTP.host = Text.encodeUtf8 config.host

67+ , HTTP.port = if config.useTLS then 443 else 80

68+ , HTTP.secure = config.useTLS

52− url s = s host /: "api" /: "v1" /: "token"

69+ , HTTP.path = "api/v1/token"

53− resp <-

70+ , HTTP.requestHeaders =

54− if tls

71+ [ ("Accept", "application/json")

55− then req POST (url https) body jsonResponse mempty

72+ , ("Accept-Encoding", "gzip")

56− else req POST (url http) body jsonResponse mempty

73+ ]

57− let TokenReply tok ts = responseBody resp

74+ , HTTP.requestBody = HTTP.RequestBodyBS $ mkAuthForm config

75+ }

76+ env.logAction $ httpLog req $ "request" .= show @HTTP.Request req

77+ resp <- HTTP.httpLbs req env.manager

78+ let

79+ res

80+ | statusIsSuccessful resp.responseStatus

81+ = either AuthParseError Authorized $ eitherDecode resp.responseBody

82+ | otherwise

83+ = Unauthorized resp

84+ env.logAction $ httpLog req case res of

85+ -- Don't log body! As it contains sensitive info

86+ Authorized _ -> "result".= ("success" :: Text)

87+ Unauthorized _ -> "result" .= ("unauthorized" :: Text) <> "body:" .=

88+ (Text.decodeUtf8Lenient $ Lazy.ByteString.toStrict resp.responseBody)

89+ AuthParseError err -> mconcat

90+ [ "result" .= ("parse_error: " <> err)

91+ , "body" .=

92+ (Text.decodeUtf8Lenient $ Lazy.ByteString.toStrict resp.responseBody)

93+ ]

58− pure (tok, ts)

94+ pure res

connexpay/src/Web/Connexpay/Data.hsdeleted−95

@@ -1,95 +0,0 @@

1−module Web.Connexpay.Data ( TransactionStatus(..)

2− , PaymentFailure(..)

3− , ConnectionError(..)

4− , ConnexpayError(..)

5− , describeFailure

6− , guessFailure

7− , ErrorMessage(..)

8− ) where

9−

10−import Control.Exception

11−import Data.Aeson

12−import Data.Aeson.Types

13−import Data.Maybe (fromMaybe)

14−import Data.Text (Text)

15−import Network.HTTP.Client

16−

17−-- | Transaction status in Connexpay

18−-- The list is taken from https://docs.connexpay.com/reference/search-sales

19−data TransactionStatus = TransactionApproved -- ^ Obvious

20− | TransactionDeclined -- ^ Also obvious

21− | TransactionCreatedLocal -- ^ Seems to only exist in a test environment, indicates success.

22− | TransactionCreatedProcNotReached -- ^ Communication error between Connexpay and Card Processor

23− | TransactionCreatedProcError -- ^ Processor errored out

24− | TransactionApprovedWarning -- ^ Wut 0__o FIXME: figure out what this is

25− | TransactionOther Text -- ^ In case they return something unexpected

26− deriving stock (Eq, Ord, Show)

27−

28−statuses :: [(Text, TransactionStatus)]

29−statuses = [ ( "Transaction - Approved", TransactionApproved )

30− , ( "Transaction - Declined", TransactionDeclined )

31− , ( "Transaction - CreatedLocal", TransactionCreatedLocal )

32− , ( "Transaction - Created - Error: Processor not reached", TransactionCreatedProcNotReached )

33− , ( "Transaction - Processor Error", TransactionCreatedProcError )

34− , ( "Transaction - Approved - Warning", TransactionApprovedWarning )

35− ]

36−

37−instance FromJSON TransactionStatus where

38− parseJSON (String s) = pure (fromMaybe (TransactionOther s) (lookup s statuses))

39− parseJSON v = typeMismatch "TransactionStatus" v

40−

41−-- | Payment failure types.

42−-- This type describes failures that related to either credit card being invalid,

43−-- client account having insufficient funds, and other non-technical conditions.

44−-- FIXME: this list is not exhaustive. Add more values whenever we encounter them.

45−data PaymentFailure = CVVFailed -- ^ CVV verification failure

46− | CardInvalid -- ^ Credit card details are invalid

47− | InvalidAmount -- ^ Money amount is invalid

48− | GeneralDecline -- ^ They just decline

49− | LocalTransaction -- ^ Special case for transactions that were registered but did't go through somehow.

50− | OtherProcessingError Text -- ^ Some other processing error with 422 code

51− deriving stock (Eq, Show)

52−

53−describeFailure :: PaymentFailure -> Text

54−describeFailure CVVFailed = "CVV authorisation failure"

55−describeFailure CardInvalid = "Invalid credit card details"

56−describeFailure InvalidAmount = "Invalid amount of money requested"

57−describeFailure GeneralDecline = "General card decine"

58−describeFailure LocalTransaction = "Transaction registered but not processed. Consult with payment processor."

59−describeFailure (OtherProcessingError txt) = "Transaction declined due to other error: " <> txt

60−

61−-- | Guess failure type from HTTP code and supplied error string.

62−guessFailure :: Int -> Text -> Maybe PaymentFailure

63−guessFailure 422 "Error code D2020. CVV2 verification failed." = Just CVVFailed

64−guessFailure 422 "Error code D2005. Invalid Card." = Just CardInvalid

65−guessFailure 422 "Amount field don't allow a value greater than $999,999.99" = Just InvalidAmount

66−guessFailure 422 "Error code D2999. General CardAuth Decline." = Just GeneralDecline

67−guessFailure 422 txt = Just (OtherProcessingError txt)

68−guessFailure _ _ = Nothing

69−

70−-- | Error response from Connexpay

71−data ErrorMessage = ErrorMessage { message :: Text

72− , errorId :: Text }

73−

74−instance FromJSON ErrorMessage where

75− parseJSON (Object o) = ErrorMessage <$> o .: "message"

76− <*> o .: "errorId"

77− parseJSON v = typeMismatch "ErrorMessage" v

78−

79−data ConnectionError = ParseError String

80− | InvalidUrl String String

81− | HttpFailure HttpExceptionContent

82− | TokenError String

83− deriving stock Show

84−

85−-- | Error type for Connexpay.

86−-- There are two possible cases here:

87−-- * Connection failure means the payment may or may not have gotten through.

88−-- This would be typically thrown as an exception in an application.

89−-- * Payment failure means Connexpay returned an error and the payment wasn't authorised.

90−-- No exception here, this must be handled as usual.

91−data ConnexpayError = ConnectionError ConnectionError

92− | PaymentFailure PaymentFailure (Maybe Text)

93− deriving stock (Show)

94−

95−instance Exception ConnexpayError

connexpay/src/Web/Connexpay/Http.hsnew file+128

@@ -0,0 +1,128 @@

1+module Web.Connexpay.Http

2+ ( RequestBody(..)

3+ , LogMasker

4+ , doRequest

5+ , doRequest_

6+ , fromResponse

7+ , httpLog

8+ ) where

10+import Control.Concurrent

11+import Control.Exception.Safe

12+import Data.Aeson

13+import Data.Aeson.Text

14+import Data.ByteString.Lazy qualified as Lazy (ByteString)

15+import Data.ByteString.Lazy qualified as Lazy.ByteString

16+import Data.Functor

17+import Data.Text (Text)

18+import Data.Text.Encoding qualified as Text

19+import Data.Text.Lazy qualified as Lazy.Text

20+import Network.HTTP.Client qualified as HTTP

21+import Network.HTTP.Types

22+

23+import Web.Connexpay.Types

24+

25+

26+data RequestBody a = RequestBody

27+ { raw :: a

28+ -- ^ To be sent to Connexpay

29+ , logMasker :: LogMasker a

30+ }

31+

32+type LogMasker a = a -> a

33+

34+renderRequestBody

35+ :: forall a. (ToJSON a)

36+ => Connexpay

37+ -> RequestBody a

38+ -> (HTTP.RequestBody, Value)

39+renderRequestBody connexpay body =

40+ ( HTTP.RequestBodyLBS $ encode $ withGuid connexpay.config.deviceGuid body.raw

41+ , withGuid "<DEVICE_GUID>" $ body.logMasker body.raw

42+ )

43+ where

44+ withGuid :: Text -> a -> Value

45+ withGuid guid = toJSON <&> \case

46+ Object o -> Object $ o <> "DeviceGuid" .= guid

47+ v -> v

48+

49+doRequest

50+ :: (ToJSON req, FromJSON resp)

51+ => Connexpay

52+ -> Env

53+ -> Text

54+ -> RequestBody req

55+ -> IO (Response () resp)

56+ -- ^ Left on non-200 repsonses

57+doRequest connexpay env endpoint body = readMVar connexpay.bearerToken >>= \case

58+ Nothing -> pure MissingOrExpiredToken

59+ Just (BearerToken token) -> do

60+ let

61+ req = HTTP.applyBearerAuth (Text.encodeUtf8 token) HTTP.defaultRequest

62+ { HTTP.method = "POST"

63+ , HTTP.host = Text.encodeUtf8 connexpay.config.host

64+ , HTTP.port = if connexpay.config.useTLS then 443 else 80

65+ , HTTP.secure = connexpay.config.useTLS

66+ , HTTP.path = "api/v1/" <> Text.encodeUtf8 endpoint

67+ , HTTP.requestHeaders =

68+ [ ("Content-Type", "application/json; charset=utf-8")

69+ , ("Accept", "application/json")

70+ , ("Accept-Encoding", "gzip")

71+ ]

72+ , HTTP.requestBody = requestBody

73+ }

74+ (requestBody, bodyLog) = renderRequestBody connexpay body

75+ env.logAction $ httpLog req $ mconcat

76+ [ "request" .= show @HTTP.Request req

77+ , "body" .= bodyLog

78+ ]

79+ resp <- HTTP.httpLbs req env.manager

80+ env.logAction $ httpLog req $ mconcat

81+ [ "response_code" .= statusCode resp.responseStatus

82+ , "body" .= Text.decodeUtf8Lenient (Lazy.ByteString.toStrict resp.responseBody)

83+ ]

84+ either throwM pure $ fromResponse resp

85+

86+doRequest_

87+ :: (ToJSON req)

88+ => Connexpay

89+ -> Env

90+ -> Text

91+ -> RequestBody req

92+ -> IO (Response () ())

93+doRequest_ connexpay env endpoint body = fmap @(Response ()) (const @_ @Value ())

94+ <$> doRequest connexpay env endpoint body

95+

96+-- | We should aim to never see this in practice.

97+data FromResponseException

98+ = UnexpectedResponse (HTTP.Response Lazy.ByteString)

99+ -- ^ Unexpected response status code (neither 2XX, nor 422)

100+ | ResponseSuccessParseError (HTTP.Response Lazy.ByteString) String

101+ -- ^ Failed to parse /success/ response.

102+ -- Thus, operation is likely successful, but we can't analyze the response.

103+ | ResponseErrorParseError (HTTP.Response Lazy.ByteString) String

104+ -- ^ Failed to parse /error/ (422) response.

105+ deriving stock (Show)

106+ deriving anyclass (Exception)

107+

108+fromResponse

109+ :: (FromJSON a)

110+ => HTTP.Response Lazy.ByteString

111+ -> Either FromResponseException (Response () a)

112+fromResponse resp

113+ | statusIsSuccessful resp.responseStatus

114+ = either (Left . ResponseSuccessParseError resp) (Right . ResponseSuccess) $

115+ eitherDecode resp.responseBody

116+ | resp.responseStatus == unauthorized401

117+ = pure MissingOrExpiredToken

118+ | resp.responseStatus == badRequest400

119+ = pure $ BadRequest resp.responseBody

120+ | resp.responseStatus == unprocessableEntity422

121+ = either (Left . ResponseErrorParseError resp) (Right . ResponseError) $

122+ eitherDecode resp.responseBody

123+ | otherwise

124+ = Left $ UnexpectedResponse resp

125+

126+httpLog :: HTTP.Request -> Object -> Text

127+httpLog req payload = Lazy.Text.toStrict $ encodeToLazyText @Object $

128+ "connexpay" .= (payload <> "path" .= Text.decodeUtf8Lenient req.path)

connexpay/src/Web/Connexpay/Init.hs+37−58

@@ -1,69 +1,48 @@

1module Web.Connexpay.Init (initConnexpay) where

3−import Web.Connexpay.Auth

4−import Web.Connexpay.Data

5−import Web.Connexpay.Types

6−import Web.Connexpay.Utils

7−

8import Control.Concurrent

3import Control.Concurrent

9import Control.Concurrent.Async

4import Control.Concurrent.Async

10−import Control.Monad (void)

5+import Control.Exception.Safe

11−import Control.Monad.Except (catchError)

6+import Control.Monad

12−import Control.Monad.IO.Class

7+import Data.Aeson

13−import Control.Monad.Reader (asks)

8+import Data.Aeson.Text

14import Data.Text (Text)

9import Data.Text (Text)

10+import Data.Text qualified as Text

11+import Data.Text.Lazy qualified as Lazy.Text

15import Network.HTTP.Client (Manager)

12import Network.HTTP.Client (Manager)

16import Numeric.Natural

13import Numeric.Natural

18−-- | Initialise Connexpay state. Log in, authenticate, and obtain bearer token.

15+import Web.Connexpay.Auth

19−initConnexpay :: (Text -> IO ()) -- ^ Logging function

16+import Web.Connexpay.Types

20− -> Manager -- ^ HTTP client manager

21− -> DeviceGuid -- ^ Device GUID. You must obtain this from ConnexPay

22− -> Text -- ^ Connexpay host to connect with

23− -> Bool -- ^ Whether to use TLS. If unsure, say True.

24− -> Text -- ^ Login name.

25− -> Text -- ^ Password.

26− -> IO (Either ConnexpayError Connexpay)

27−initConnexpay logf mgr devguid url tls login password =

28− do v <- newMVar Nothing

29− let env = Connexpay { logAction = logf

30− , manager = mgr

31− , bearerToken = v

32− , refreshAsync = Nothing

33− , deviceGuid = devguid

34− , url = url

35− , useTLS = tls

36− , login = login

37− , password = password

38− }

39− runConnexpay env $ do

40− ts <- initialAuth v logf

41− a <- liftIO (async (runConnexpay_ env $ updateToken ts))

42− pure (env { refreshAsync = Just a })

44−initialAuth :: MVar (Maybe BearerToken) -> (Text -> IO ()) -> ConnexpayM Natural

45−initialAuth v logf =

46− do (tok, ts) <- authenticate

47− liftIO $ do logf "Connexpay authentication success"

48− void (swapMVar v (Just tok))

49− return ts

50− `catchError` \err -> do

51− liftIO (logf ("Initial connexpay authentication failed: " <> tshow err))

52− -- if initial authentication failed, wait 1 second?

53− -- there isn't much else to do, really.

54− return 1

19+-- | Initialise Connexpay state. Log in, authenticate, and obtain bearer token.

20+initConnexpay

21+ :: Logger

22+ -> Manager

23+ -> Config

24+ -> IO Connexpay

25+initConnexpay logAction manager config = do

26+ bearerToken <- newMVar Nothing

27+ let env = Env{..}

28+ refreshAsync <- async $ forever $

29+ updateToken config env bearerToken 0 `catchAny` \err -> do

30+ doLog env $

31+ "Connexpay token update exception: " <> Text.pack (displayException err)

32+ threadDelay 5_000_000

33+ pure Connexpay{..}

34+

35+updateToken :: Config -> Env -> MVar (Maybe BearerToken) -> Natural -> IO ()

36+updateToken config env tokVar w =

37+ threadDelay (fromIntegral w * 1_000_000) >> upd

38+ where

39+ upd = authenticate config env >>= \case

40+ Authorized tok -> do

41+ _ <- swapMVar tokVar (Just tok.token)

42+ updateToken config env tokVar (tok.expiresIn - 5)

43+ _ -> do

44+ updateToken config env tokVar 5

57−updateToken :: Natural -> ConnexpayM ()

46+doLog :: Env -> Text -> IO ()

58−updateToken w = liftIO (threadDelay w') >> upd

47+doLog env msg = env.logAction $ Lazy.Text.toStrict $ encodeToLazyText @Object $

59− where w' = fromIntegral w * 1000000

48+ "connexpay" .= ("auth" .= msg :: Object)

60− upd = do (tok, ts) <- authenticate

61− logf <- asks (.logAction)

62− tokVar <- asks (.bearerToken)

63− liftIO (void $ swapMVar tokVar (Just tok))

64− liftIO (logf "Connexpay token update success")

65− updateToken (ts - 5)

66− `catchError` \err -> do

67− logf <- asks (.logAction)

68− liftIO (logf ("Connexpay token update failure: " <> tshow err))

69− updateToken 5

connexpay/src/Web/Connexpay/Payments.hs+64−224

@@ -1,239 +1,79 @@

1−{-# LANGUAGE DataKinds #-}

1+module Web.Connexpay.Payments

2−{-# LANGUAGE TemplateHaskell #-}

2+ ( AuthRequest(..)

3−{-# LANGUAGE UndecidableInstances #-}

3+ , USD(..)

4+ , CreditCard(..)

5+ , ExpirationDate(..)

6+ , Customer(..)

7+ , RiskData(..)

8+ , AuthResponse(..)

9+ , TransactionStatus(..)

10+ , authorisePayment

11+ , VoidRequest(..)

12+ , voidPayment

13+ , CaptureResponse(..)

14+ , Sale(..)

15+ , capturePayment

16+ , cancelPayment

17+ , returnPayment

18+ ) where

5−module Web.Connexpay.Payments ( CreditCard(..)

6− , AuthRequest(..)

7− , Customer(..)

8− , AuthResponse(..)

9− , authorisePayment

10− , VoidRequest(..)

11− , voidPayment

12− , CaptureResponse(..)

13− , capturePayment

14− , cancelPayment

15− , returnPayment

16− ) where

17−

18−import Control.Monad (when,void)

19−import Control.Monad.Except (throwError)

20−import Control.Monad.Reader (asks)

21−import Control.Monad.Writer.Strict

22import Data.Aeson

20import Data.Aeson

23−import Data.Aeson.KeyMap qualified as KeyMap

24−import Data.Aeson.TH

25−import Data.Aeson.Types (Pair, typeMismatch)

26−import Data.ByteString.Lazy qualified as ByteString

27−import Data.Int (Int32)

28−import Data.Money

29−import Data.Proxy

30−import Data.Text (Text)

31−import Data.Text qualified as Text

32−import Data.Text.Encoding qualified as Text

33−import GHC.TypeError as TypeError

34−import Network.HTTP.Req

36−import Web.Connexpay.Data

22+import Web.Connexpay.Http

23+import Web.Connexpay.Payments.Types

37import Web.Connexpay.Types

24import Web.Connexpay.Types

38−import Web.Connexpay.Utils

39−

40−

41−data Customer = Customer { address1 :: Text

42− , address2 :: Maybe Text

43− , zip :: Maybe Text

44− }

45−

46−deriveToJSON defaultOptions

47− { fieldLabelModifier = capitalize

48− , omitNothingFields = True

49− } ''Customer

50−

51−-- | Credit card info

52−-- No 'Show' instance should be made for this type

53−-- in order to avoid sensitive data leaks.

54−data CreditCard = CreditCard { number :: Text -- ^ Credit card number, as 'Text'.

55− , cardholder :: Maybe Text -- ^ Cardholder name, optional.

56− , expiration :: (Word, Word) -- ^ Expiration date (month,year).

57− , cvv :: Maybe Text -- ^ CVC/CVV code.

58− , customer :: Maybe Customer -- ^ Required to get AVS

59− }

60−type ShowError = TypeError.Text "CreditCard must not be shown in order to avoid leaking sensitive data"

61−

62−instance TypeError ShowError => Show CreditCard where

63− show = error "UNREACHABLE"

64−

65−instance ToJSON CreditCard where

66− toJSON cc = object

67− $ execWriter

68− $ do tell ["CardNumber" .= cc.number]

69− whenJust cc.cardholder $ \name ->

70− tell ["CardHolderName" .= name]

71− whenJust cc.cvv $ \cvv ->

72− tell ["Cvv2" .= cvv]

73− let expDate = padDate (tshow (snd cc.expiration)) <> padDate (tshow (fst cc.expiration))

74− tell ["ExpirationDate" .= expDate]

75− whenJust cc.customer $ \customer ->

76− tell [ "Customer" .= customer ]

77−

78−padDate :: Text -> Text

79−padDate t | Text.length t == 1 = "0" <> t

80− | otherwise = t

81−

82−sendRequest' :: HttpResponse resp => Proxy resp -> Text -> [Pair] -> ConnexpayM resp

83−sendRequest' resp endpoint body =

84− do mtok <- bearerToken

85− tok <- case mtok of

86− Just t -> pure t

87− Nothing -> throwError (ConnectionError $ TokenError "No authentication token available. Check connection parameters?")

88− host <- asks (.url)

89− tls <- asks (.useTLS)

90− let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)

91− url s = s host /: "api" /: "v1" /: endpoint

92− obj <- object <$> addGuid body

93− let jbody = ReqBodyJson obj

94− r <- if tls

95− then reqCb POST (url https) jbody resp auth (logRequest obj)

96− else reqCb POST (url http) jbody resp auth (logRequest obj)

97− pure r

98− where

99− addGuid b =

100− do guid <- asks (.deviceGuid)

101− return (b <> [ "DeviceGuid" .= show guid ])

102− logRequest v r =

103− do log_ <- asks (.logAction)

104− -- Remove card info from logs

105− let v' = case v of

106− Object obj

107− | Just c <- KeyMap.lookup "Card" obj -> Object (KeyMap.insert "Card" (replaceCard c) obj)

108− other -> other

109− msg = Text.unlines [ "Connexpay request:"

110− , tshow r

111− , Text.decodeUtf8 (ByteString.toStrict $ encode v')

112− ]

113− _ <- liftIO (log_ msg)

114− return r

115− replaceCard (Object c) =

116− Object

117− $ KeyMap.insert "CardNumber" (String "<REDACTED>")

118− $ KeyMap.insert "Cvv2" (String "<REDACTED>")

119− $ c

120− replaceCard v = v

121−

122−sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a)

123−sendRequestJson = sendRequest' jsonResponse

124

125−sendRequest_ :: Text -> [Pair] -> ConnexpayM ()

126−sendRequest_ ep = void . sendRequest' ignoreResponse ep

127−

128−data AuthResponse = AuthResponse { paymentGuid :: AuthOnlyGuid

129− , status :: TransactionStatus

130− , processorStatusCode :: Maybe Text

131− , processorMessage :: Maybe Text

132− , addressVerificationCode :: Maybe Text

133− , cvvVerificationCode :: Maybe Text

134− } deriving stock (Show)

135−

136−instance FromJSON AuthResponse where

137− parseJSON (Object o) = AuthResponse <$> o .: "guid"

138− <*> o .: "status"

139− <*> o .:? "processorStatusCode"

140− <*> o .:? "processorResponseMessage"

141− <*> o .:? "addressVerificationCode"

142− <*> o .:? "cvvVerificationCode"

143− parseJSON v = typeMismatch "AuthReponse" v

144−

145−data AuthRequest = AuthRequest { creditCard :: CreditCard

146− , amount :: Money USD

147− , invoice :: Maybe Text

148− , vendor :: Maybe Text

149− -- ^ Merchant description that will appear in a

150− -- customer's statement.

151− }

152

153-- | Authorise a credit card payment.

27-- | Authorise a credit card payment.

154−authorisePayment :: AuthRequest

28+authorisePayment

155− -> ConnexpayM AuthResponse

29+ :: Connexpay -> Env -> AuthRequest -> IO (Response AuthError AuthResponse)

156−authorisePayment request =

30+authorisePayment connexpay env raw = guessResponseErrorType guessAuthError <$>

157− do resp <- sendRequestJson "authonlys" body

31+ doRequest connexpay env "authonlys" RequestBody

158− let rbody = responseBody resp

32+ { raw

159− -- Special case for Connexpay local transaction

33+ , logMasker = maskAuthRequest

160− -- This status means that the transaction was registered,

34+ }

161− -- but Connexpay stopped its processing and it won't be

162− -- moved any further.

163− -- Also, when I asked Ken from Connexpay about this,

164− -- he told me he had never seen this status before.

165− when (rbody.status == TransactionCreatedLocal) $

166− throwError (PaymentFailure LocalTransaction Nothing)

167− pure rbody

168− where body = execWriter $

169− do tell [ "Card" .= request.creditCard ]

170− tell [ "Amount" .= getAmount request.amount ]

171− whenJust request.invoice $ \i ->

172− tell [ "OrderNumber" .= i ]

173− whenJust request.vendor $ \v ->

174− tell [ "StatementDescription" .= v ]

175− -- We are supposed to pass RiskData, but it still

176− -- can be an empty object. Consider population this

177− -- should the need arise.

178− tell [ "RiskData" .= KeyMap.empty @() ]

179−

180−data VoidRequest = VoidAuthorized AuthOnlyGuid | VoidCaptured SaleGuid (Maybe (Money USD))

181

182-- | Void payment

36-- | Void payment

183−voidPayment :: VoidRequest

37+voidPayment :: Connexpay -> Env -> VoidRequest -> IO (Response () ())

184− -> ConnexpayM ()

38+voidPayment connexpay env raw = doRequest_ connexpay env "void" RequestBody

185−voidPayment (VoidAuthorized pid) = sendRequest_ "void" body

39+ { raw

186− where body = [ "AuthOnlyGuid" .= show pid ]

40+ , logMasker = id

187−voidPayment (VoidCaptured pid amt) = sendRequest_ "void" body

41+ }

188− where body = execWriter $

189− do tell [ "SaleGuid" .= show pid ]

190− whenJust amt $ \m ->

191− tell [ "Amount" .= getAmount m ]

192−

193−-- | Internal data type for Capture requests.

194−data CPTransaction = CPTransaction { expectedPayments :: Int32 }

195−

196−instance ToJSON CPTransaction where

197− toJSON t = object [ "ExpectedPayments" .= t.expectedPayments ]

198−

199−-- | Response for the payment capture request

200−data CaptureResponse = CaptureResponse { captureGuid :: CaptureGuid

201− , saleGuid :: SaleGuid

202− , saleStatus :: TransactionStatus

203− } deriving stock (Show)

204−

205−instance FromJSON CaptureResponse where

206− parseJSON (Object o) =

207− do cguid <- o .: "guid"

208− sale <- o .: "sale"

209− saleGuid <- sale .: "guid"

210− status <- sale .: "status"

211− pure (CaptureResponse cguid saleGuid status)

212− parseJSON v = typeMismatch "CaptureResponse" v

213

214-- | Capture payment, previously authorised through 'authorisePayment'.

43-- | Capture payment, previously authorised through 'authorisePayment'.

44+capturePayment :: Connexpay

45+ -> Env

215−capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.

46+ -> AuthOnlyGuid -- ^ Sales GUID, obtained from 'authorisePayment'.

216− -> ConnexpayM CaptureResponse

47+ -> IO (Response () CaptureResponse)

217−capturePayment pid =

48+capturePayment connexpay env pid = doRequest connexpay env "Captures" RequestBody

218− do resp <- sendRequestJson "Captures" body

49+ { raw = object

219− let rbody = responseBody resp

220− pure rbody

221− where body = [ "AuthOnlyGuid" .= show pid

50+ [ "AuthOnlyGuid" .= pid

222− , "ConnexPayTransaction" .= CPTransaction 1 ]

51+ , "ConnexPayTransaction" .= CPTransaction 1

52+ ]

53+ , logMasker = id

54+ }

223

224-- | Cancel voided or captured payment.

56-- | Cancel voided or captured payment.

225-- In case of an authorised-only payment, voiding is performed.

57-- In case of an authorised-only payment, voiding is performed.

226-- Otherwise, a payment goes through a refund process.

58-- Otherwise, a payment goes through a refund process.

59+cancelPayment :: Connexpay

60+ -> Env

227−cancelPayment :: SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.

61+ -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.

228− -> ConnexpayM ()

62+ -> IO (Response () ())

229−cancelPayment pid = sendRequest_ "cancel" body

63+cancelPayment connexpay env pid = doRequest_ connexpay env "cancel" RequestBody

230− where body = [ "SaleGuid" .= show pid ]

64+ { raw = object [ "SaleGuid" .= pid ]

231−

65+ , logMasker = id

66+ }

67+

68+returnPayment :: Connexpay

69+ -> Env

232−returnPayment :: SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.

70+ -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.

233− -> Maybe (Money USD)

71+ -> USD

234− -> ConnexpayM ()

72+ -> IO (Response () ())

235−returnPayment pid amt = sendRequest_ "returns" body

73+returnPayment connexpay env pid amt = doRequest_ connexpay env "returns" RequestBody

236− where body = execWriter $

74+ { raw = object

237− do tell [ "SaleGuid" .= show pid ]

75+ [ "SaleGuid" .= pid

238− whenJust amt $ \m ->

239− tell [ "Amount" .= getAmount m ]

76+ , "Amount" .= amt

77+ ]

78+ , logMasker = id

79+ }

connexpay/src/Web/Connexpay/Payments/Types.hsnew file+210

@@ -0,0 +1,210 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE TemplateHaskell #-}

4+module Web.Connexpay.Payments.Types where

6+import Data.Aeson

7+import Data.Aeson.TH

8+import Data.Fixed

9+import Data.Int (Int32)

10+import Data.Maybe

11+import Data.Text (Text)

12+import Data.Text qualified as Text

13+import GHC.TypeError as TypeError

14+import Text.Printf

15+

16+import Web.Connexpay.Http

17+import Web.Connexpay.Types

18+import Web.Connexpay.Utils

19+

20+

21+data AuthRequest = AuthRequest

22+ { card :: CreditCard

23+ , amount :: USD

24+ , orderNumber :: Maybe Text

25+ , statementDescription :: Maybe Text

26+ -- ^ Merchant description that will appear in a

27+ -- customer's statement.

28+ , riskData :: RiskData

29+ }

30+

31+maskAuthRequest :: LogMasker AuthRequest

32+maskAuthRequest req = AuthRequest

33+ { card = maskCreditCard req.card

34+ , amount = req.amount

35+ , orderNumber = starWords <$> req.orderNumber

36+ , statementDescription = req.statementDescription

37+ , riskData = maskRiskData req.riskData

38+ }

39+

40+newtype USD = USD Centi

41+ deriving newtype (Read, FromJSON, ToJSON)

42+

43+-- | Credit card info

44+-- No 'Show' instance should be made for this type

45+-- in order to avoid sensitive data leaks.

46+data CreditCard = CreditCard

47+ { cardNumber :: Text

48+ , cardHolderName :: Maybe Text

49+ , expirationDate :: ExpirationDate

50+ , cvv2 :: Maybe Text

51+ , customer :: Maybe Customer

52+ -- ^ Required to get AVS

53+ }

54+

55+type ShowError = TypeError.Text

56+ "CreditCard must not be shown in order to avoid leaking sensitive data"

57+

58+instance TypeError ShowError => Show CreditCard where

59+ show = error "UNREACHABLE"

60+

61+maskCreditCard :: LogMasker CreditCard

62+maskCreditCard cc = CreditCard

63+ { cardNumber = maskCreditCardNumber cc.cardNumber

64+ , cardHolderName = starWords <$> cc.cardHolderName

65+ , expirationDate = maskExpirationDate cc.expirationDate

66+ , cvv2 = starWords <$> cc.cvv2

67+ , customer = maskCustomer <$> cc.customer

68+ }

69+

70+maskCreditCardNumber :: Text -> Text

71+maskCreditCardNumber number = firstDigits <> stars <> lastDigits

72+ where

73+ (firstDigits, rest) = Text.splitAt 4 number

74+ toDrop = Text.length rest - 4

75+ (_, lastDigits) = Text.splitAt toDrop rest

76+ stars = Text.replicate toDrop "*"

77+

78+data ExpirationDate = ExpirationDate

79+ { year :: Word

80+ -- ^ Last 2 digits of the year in range from 0 (2000) to 99 (2099).

81+ -- No check is performed whether the value fits into the range.

82+ , month :: Word

83+ -- ^ Month of year, in range 1 (January) to 12 (December).

84+ -- No check is performed whether the value fits into the range.

85+ }

86+

87+instance ToJSON ExpirationDate where

88+ toJSON expiry =

89+ toJSON (printf "%02d%02d" expiry.year expiry.month :: String)

90+

91+maskExpirationDate :: LogMasker ExpirationDate

92+maskExpirationDate _ = ExpirationDate

93+ { year = 0

94+ , month = 0

95+ }

96+

97+data Customer = Customer

98+ { address1 :: Text

99+ , address2 :: Maybe Text

100+ , zip :: Maybe Text

101+ }

102+

103+maskCustomer :: LogMasker Customer

104+maskCustomer customer = Customer

105+ { address1 = starWords customer.address1

106+ , address2 = starWords <$> customer.address2

107+ , zip = customer.zip

108+ }

109+

110+-- | Currently unpopulated

111+data RiskData = RiskData

112+

113+instance ToJSON RiskData where

114+ toJSON RiskData = Object mempty

115+

116+maskRiskData :: LogMasker RiskData

117+maskRiskData = id

118+

119+data AuthResponse = AuthResponse

120+ { guid :: AuthOnlyGuid

121+ , status :: TransactionStatus

122+ , processorStatusCode :: Maybe Text

123+ , processorResponseMessage :: Maybe Text

124+ , addressVerificationCode :: Maybe Text

125+ , cvvVerificationCode :: Maybe Text

126+ } deriving stock (Show)

127+

128+-- | Transaction status in Connexpay

129+-- The list is taken from https://docs.connexpay.com/reference/search-sales

130+data TransactionStatus

131+ = TransactionApproved

132+ | TransactionApprovedWarning

133+ | TransactionCreatedLocal

134+ -- ^ Seems to only exist in a test environment, indicates success.

135+ | TransactionDeclined

136+ | TransactionCreatedProcNotReached

137+ -- ^ Communication error between Connexpay and Card Processor

138+ | TransactionCreatedProcError

139+ -- ^ Processor errored out

140+ | TransactionOther Text

141+ -- ^ In case they return something unexpected

142+ deriving stock (Show)

143+

144+instance FromJSON TransactionStatus where

145+ parseJSON = withText "TransactionStatus" $ pure . \case

146+ "Transaction - Approved" -> TransactionApproved

147+ "Transaction - Approved - Warning" -> TransactionApprovedWarning

148+ "Transaction - CreatedLocal" -> TransactionCreatedLocal

149+ "Transaction - Declined" -> TransactionDeclined

150+ "Transaction - Created - Error: Processor not reached" ->

151+ TransactionCreatedProcNotReached

152+ "Transaction - Processor Error" -> TransactionCreatedProcError

153+ other -> TransactionOther other

154+

155+data AuthError

156+ = CVVFailed -- ^ CVV verification failure

157+ | CardInvalid -- ^ Credit card details are invalid

158+ | InvalidAmount -- ^ Money amount is invalid

159+ | GeneralDecline -- ^ They just decline

160+ | OtherAuthError Text -- ^ Some other processing error with 422 code

161+ deriving stock (Show)

162+

163+-- | Guess failure type from error string.

164+guessAuthError :: Error () -> AuthError

165+guessAuthError err = case err.message of

166+ "Error code D2020. CVV2 verification failed." -> CVVFailed

167+ "Error code D2005. Invalid Card." -> CardInvalid

168+ "Amount field don't allow a value greater than $999,999.99" -> InvalidAmount

169+ "Error code D2999. General CardAuth Decline." -> GeneralDecline

170+ txt -> OtherAuthError txt

171+

172+data VoidRequest

173+ = VoidAuthorized AuthOnlyGuid

174+ | VoidCaptured SaleGuid (Maybe USD)

175+

176+instance ToJSON VoidRequest where

177+ toJSON = \case

178+ VoidAuthorized pid -> object ["AuthOnlyGuid" .= pid]

179+ VoidCaptured pid mbAmount -> object $ catMaybes

180+ [ Just $ "SaleGuid" .= pid

181+ , ("Amount" .=) <$> mbAmount

182+ ]

183+

184+-- | Internal data type for Capture requests.

185+data CPTransaction = CPTransaction

186+ { expectedPayments :: Int32

187+ }

188+

189+instance ToJSON CPTransaction where

190+ toJSON t = object [ "ExpectedPayments" .= t.expectedPayments ]

191+

192+-- | Response for the payment capture request

193+data CaptureResponse = CaptureResponse

194+ { guid :: CaptureGuid

195+ , sale :: Sale

196+ } deriving stock (Show)

197+

198+data Sale = Sale

199+ { guid :: SaleGuid

200+ , status :: TransactionStatus

201+ } deriving stock (Show)

202+

203+concat <$> sequence

204+ [ deriveToJSON aesonOptions ''AuthRequest

205+ , deriveToJSON aesonOptions ''CreditCard

206+ , deriveToJSON aesonOptions ''Customer

207+ , deriveFromJSON defaultOptions ''AuthResponse

208+ , deriveFromJSON defaultOptions ''CaptureResponse

209+ , deriveFromJSON defaultOptions ''Sale

210+ ]

connexpay/src/Web/Connexpay/Types.hs+82−77

@@ -1,81 +1,86 @@

1module Web.Connexpay.Types where

3−import Web.Connexpay.Data

4−import Web.Connexpay.Utils

5−

6import Control.Concurrent.Async

3import Control.Concurrent.Async

7−import Control.Concurrent.MVar (MVar, readMVar)

4+import Control.Concurrent.MVar (MVar)

8−import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError)

9−import Control.Monad.IO.Class

10−import Control.Monad.Reader

11−import Data.Aeson

5+import Data.Aeson hiding (Error)

6+import Data.Bifunctor

12−import Data.ByteString (ByteString)

7+import Data.ByteString.Lazy qualified as Lazy (ByteString)

13import Data.Text (Text)

8import Data.Text (Text)

14−import Data.Text qualified as Text

9+import Network.HTTP.Client (Manager)

15−import Data.Text.Encoding qualified as Text

10+

16−import Data.UUID (UUID)

11+

17−import Network.HTTP.Client as Client

12+newtype BearerToken = BearerToken

18−import Network.HTTP.Req

13+ { unBearerToken :: Text

19−import Network.HTTP.Types

14+ } deriving newtype (Show, FromJSON, ToJSON)

20−

15+

21−type BearerToken = Text

16+newtype AuthOnlyGuid = AuthOnlyGuid

22−type DeviceGuid = UUID

17+ { unAuthOnlyGuid :: Text

23−type AuthOnlyGuid = UUID

18+ } deriving newtype (Show, FromJSON, ToJSON)

24−type SaleGuid = UUID

19+

25−type CaptureGuid = UUID

20+newtype SaleGuid = SaleGuid

26−

21+ { unSaleGuid :: Text

27−data Connexpay = Connexpay { logAction :: Text -> IO ()

22+ } deriving newtype (Show, FromJSON, ToJSON)

28− , manager :: Manager

23+

24+newtype CaptureGuid = CaptureGuid

25+ { unCaptureGuid :: Text

26+ } deriving newtype (Show, FromJSON, ToJSON)

27+

28+type Logger = Text -> IO ()

29+

30+data Config = Config

31+ { host :: Text

32+ , login :: Text

33+ , password :: Text

34+ , deviceGuid :: Text

35+ , useTLS :: Bool

36+ }

37+

38+data Connexpay = Connexpay

39+ { config :: Config

29− , bearerToken :: MVar (Maybe BearerToken)

40+ , bearerToken :: MVar (Maybe BearerToken)

30− , refreshAsync :: Maybe (Async ())

41+ , refreshAsync :: Async ()

31− , deviceGuid :: DeviceGuid

42+ }

32− , url :: Text

43+

33− , useTLS :: Bool

44+data Env = Env

34− , login :: Text

45+ { logAction :: Logger

35− , password :: Text

46+ , manager :: Manager

36− }

47+ }

37−

48+

38−newtype ConnexpayM a = ConnexpayM (ReaderT Connexpay (ExceptT ConnexpayError IO) a)

49+data Response e a

39− deriving newtype

50+ = ResponseSuccess a

40− (Functor, Applicative, Monad, MonadIO, MonadReader Connexpay, MonadError ConnexpayError)

51+ | ResponseError (Error e)

41−

52+ -- ^ Response structured error (422 status code) is received

42−instance MonadHttp ConnexpayM where

53+ | BadRequest Lazy.ByteString

43− handleHttpException (JsonHttpException e) = throwError (ConnectionError $ ParseError e)

54+ | MissingOrExpiredToken

44− handleHttpException (VanillaHttpException (InvalidUrlException url why)) = throwError (ConnectionError $ InvalidUrl url why)

55+ -- ^ Most likely invalid credentials/URL are passed during initialization.

45− handleHttpException (VanillaHttpException (HttpExceptionRequest _ (StatusCodeException resp bs)))

56+ -- No request is even sent to Connexpay.

46− | Just err <- decodeStrict @ErrorMessage bs

57+ deriving stock (Show, Functor)

47− , Just f <- guessFailure (statusCode $ responseStatus resp) err.message = throwError (PaymentFailure f (Just err.message))

58+

48− handleHttpException (VanillaHttpException (HttpExceptionRequest _ c)) = throwError (ConnectionError $ HttpFailure c)

59+instance Bifunctor Response where

49−

60+ bimap f = bimapResponse (fmap f)

50− getHttpConfig =

61+

51− do mgr <- asks (.manager)

62+bimapResponse

52− log_ <- asks (.logAction)

63+ :: (Error e -> Error e') -> (a -> b) -> Response e a -> Response e' b

53− let cfg =

64+bimapResponse f g = \case

54− defaultHttpConfig

65+ ResponseSuccess a -> ResponseSuccess (g a)

55− { httpConfigAltManager = Just mgr

66+ ResponseError e -> ResponseError (f e)

56− , httpConfigBodyPreviewLength = 8192

67+ BadRequest body -> BadRequest body

57− -- ^ Default of 1024 is definitely not enough

68+ MissingOrExpiredToken -> MissingOrExpiredToken

58− , httpConfigLogResponse = logResponse log_ }

69+

59− pure cfg

70+guessResponseErrorType :: (Error () -> e) -> Response () a -> Response e a

60−

71+guessResponseErrorType mkErr = bimapResponse (\e -> e { errorType = mkErr e }) id

61−

72+

62−runConnexpay :: Connexpay -> ConnexpayM a -> IO (Either ConnexpayError a)

73+data Error e = Error

63−runConnexpay cp (ConnexpayM a) = runExceptT (runReaderT a cp)

74+ { message :: Text

64−

75+ , errorId :: Text

65−runConnexpay_ :: Connexpay -> ConnexpayM a -> IO ()

76+ , errorType :: e

66−runConnexpay_ cp m =

77+ } deriving stock (Show, Functor)

67− do r <- runConnexpay cp m

78+

68− whenLeft r $ \err ->

79+instance FromJSON (Error ()) where

69− cp.logAction ("Uncaught Connexpay error: " <> Text.pack (show err))

80+ parseJSON = withObject "Error" \o -> do

70−

81+ message <- o .: "message"

71−bearerToken :: ConnexpayM (Maybe BearerToken)

82+ errorId <- o .: "errorId"

72−bearerToken = do v <- asks (.bearerToken)

83+ pure Error

73− liftIO (readMVar v)

84+ { errorType = ()

74−

85+ , ..

75−logResponse :: (Text -> IO ()) -> Request -> Response a -> ByteString -> IO ()

86+ }

76−logResponse log_ _req resp body = log_ msg

77− where msg = Text.unlines [ "Connexpay response:"

78− , "HTTP code: " <> tshow (statusCode (responseStatus resp))

79− , "Headers: " <> tshow (Client.responseHeaders resp)

80− , "Body: " <> Text.decodeUtf8Lenient body

81− ]

connexpay/src/Web/Connexpay/Utils.hs+11−18

@@ -1,29 +1,22 @@

1module Web.Connexpay.Utils where

3+import Data.Aeson.Types

3import Data.Char

4import Data.Char

4import Data.Text (Text)

5import Data.Text (Text)

5import Data.Text qualified as Text

6import Data.Text qualified as Text

6−import Network.HTTP.Client qualified as Client

7−import Network.HTTP.Req

8−import Network.HTTP.Types

10−whenLeft :: Monad m => Either a b -> (a -> m ()) -> m ()

11−whenLeft (Left l) f = f l

12−whenLeft (Right _) _ = pure ()

14−whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()

9+starWords :: Text -> Text

15−whenJust (Just x) f = f x

10+starWords = Text.unwords . map toStars . Text.words

16−whenJust Nothing _ = pure ()

11+ where toStars w = Text.replicate (Text.length w) "*"

17−

18−tshow :: Show a => a -> Text

19−tshow = Text.pack . show

20−

21−--responseHeaders :: HttpResponse response => response -> [Header]

22−--responseHeaders = Client.responseHeaders . toVanillaResponse

23−

24−responseCode :: HttpResponse response => response -> Int

25−responseCode = statusCode . Client.responseStatus . toVanillaResponse

27capitalize :: String -> String

13capitalize :: String -> String

28capitalize [] = []

14capitalize [] = []

29capitalize (x : xs) = toUpper x : xs

15capitalize (x : xs) = toUpper x : xs

16+

17+aesonOptions :: Options

18+aesonOptions = defaultOptions

19+ { fieldLabelModifier = capitalize

20+ , tagSingleConstructors = True

21+ , omitNothingFields = True

22+ }

connexpay/tool/Main.hs+59−42

@@ -2,42 +2,48 @@

3module Main where

5−import Control.Concurrent (yield)

5+import Control.Concurrent

6import Control.Monad

7−import Control.Monad.IO.Class

8import Data.Aeson

7import Data.Aeson

9−import Data.Fixed

8+import Data.Coerce

10import Data.Maybe (fromMaybe)

9import Data.Maybe (fromMaybe)

11−import Data.Money

12import Data.Text (Text)

10import Data.Text (Text)

13import Data.Text.Encoding qualified as Text

11import Data.Text.Encoding qualified as Text

14import Data.Text.IO qualified as Text

12import Data.Text.IO qualified as Text

15−import Data.UUID

16import Data.Yaml (decodeFileThrow)

13import Data.Yaml (decodeFileThrow)

17import GHC.Generics

14import GHC.Generics

18import Network.HTTP.Client

15import Network.HTTP.Client

19import Network.HTTP.Client.TLS

16import Network.HTTP.Client.TLS

20import Options.Applicative

17import Options.Applicative

21−import Web.Connexpay

18+import Web.Connexpay.Init

19+import Web.Connexpay.Payments

22import Web.Connexpay.Types

20import Web.Connexpay.Types

24−data Config = Config { login :: Text

25− , password :: Text

26− , host :: Text

27− , device_guid :: UUID

28− , use_tls :: Bool

29− , proxy_host :: Maybe Text

30− , proxy_port :: Maybe Word

31− } deriving stock Generic

33−instance FromJSON Config

23+data ConfigYaml = ConfigYaml

24+ { login :: Text

25+ , password :: Text

26+ , host :: Text

27+ , deviceGuid :: Text

28+ , useTLS :: Bool

29+ , proxyHost :: Maybe Text

30+ , proxyPort :: Maybe Word

31+ } deriving stock Generic

33+instance FromJSON ConfigYaml where

34+ parseJSON = genericParseJSON defaultOptions

35+ { fieldLabelModifier = camelTo2 '_'

36+ }

37+

38+configFromYaml :: ConfigYaml -> Config

39+configFromYaml ConfigYaml{..} = Config{..}

40+

35−data Command = AuthSale CreditCard Centi

41+data Command = AuthSale CreditCard USD

36 | VoidAuth AuthOnlyGuid

42 | VoidAuth AuthOnlyGuid

37− | VoidSale SaleGuid (Maybe Centi)

43+ | VoidSale SaleGuid (Maybe USD)

38 | CaptureSale AuthOnlyGuid

44 | CaptureSale AuthOnlyGuid

39 | CancelSale SaleGuid

45 | CancelSale SaleGuid

40− | ReturnSale SaleGuid (Maybe Centi)

46+ | ReturnSale SaleGuid USD

41 | TestAuth

47 | TestAuth

43data CmdLine = CmdLine { configPath :: FilePath

49data CmdLine = CmdLine { configPath :: FilePath

@@ -52,7 +58,7 @@ cmdParser = CmdLine <$> strOption (short 'c' <> metavar "FILE" <> help "Configur

52 <> command "void-sale" (info (VoidSale <$> guid <*> optional amt) (progDesc "Void payment"))

58 <> command "void-sale" (info (VoidSale <$> guid <*> optional amt) (progDesc "Void payment"))

53 <> command "capture" (info (CaptureSale <$> guid) (progDesc "Capture payment"))

59 <> command "capture" (info (CaptureSale <$> guid) (progDesc "Capture payment"))

54 <> command "cancel" (info (CancelSale <$> guid) (progDesc "Cancel payment"))

60 <> command "cancel" (info (CancelSale <$> guid) (progDesc "Cancel payment"))

55− <> command "return" (info (ReturnSale <$> guid <*> optional amt) (progDesc "return payment"))

61+ <> command "return" (info (ReturnSale <$> guid <*> amt) (progDesc "return payment"))

56 <> command "test-auth" (info (pure TestAuth) (progDesc "Test token authorisation"))

62 <> command "test-auth" (info (pure TestAuth) (progDesc "Test token authorisation"))

57 amt = argument auto (metavar "Payment amount")

63 amt = argument auto (metavar "Payment amount")

58 cc = CreditCard <$> argument str mempty

64 cc = CreditCard <$> argument str mempty

@@ -67,36 +73,47 @@ cmdParser = CmdLine <$> strOption (short 'c' <> metavar "FILE" <> help "Configur

67 } )

73 } )

68 expdate = do s <- str

74 expdate = do s <- str

69 guard (length s == 4)

75 guard (length s == 4)

70− pure (read (take 2 s), read (drop 2 s))

76+ let (month, year) = splitAt 2 s

77+ pure ExpirationDate

78+ { year = read year

79+ , month = read month

80+ }

81+ guid :: (Coercible Text guid) => Parser guid

71− guid = argument auto (metavar "Payment UUID")

82+ guid = coerce @Text <$> strArgument (metavar "Payment UUID")

73writeLog :: Text -> IO ()

84writeLog :: Text -> IO ()

74writeLog msg = Text.putStrLn ("Connexpay log: " <> msg)

85writeLog msg = Text.putStrLn ("Connexpay log: " <> msg)

76main :: IO ()

87main :: IO ()

77main = do cmdLine <- execParser (info (cmdParser <**> helper) mempty)

88main = do cmdLine <- execParser (info (cmdParser <**> helper) mempty)

78− cnf :: Config <- decodeFileThrow cmdLine.configPath

89+ cnf :: ConfigYaml <- decodeFileThrow cmdLine.configPath

79− mgr <- fromMaybe newTlsManager

90+ manager <- fromMaybe newTlsManager

80− $ do host <- cnf.proxy_host

91+ $ do host <- cnf.proxyHost

81− port <- cnf.proxy_port

92+ port <- cnf.proxyPort

82 let proxy = useProxy (Proxy (Text.encodeUtf8 host) (fromIntegral port))

93 let proxy = useProxy (Proxy (Text.encodeUtf8 host) (fromIntegral port))

83 s = managerSetProxy proxy defaultManagerSettings

94 s = managerSetProxy proxy defaultManagerSettings

84 return (newManager s)

95 return (newManager s)

85− res <- initConnexpay writeLog mgr cnf.device_guid cnf.host cnf.use_tls cnf.login cnf.password

96+ cpi <- initConnexpay writeLog manager $ configFromYaml cnf

86− case res of

97+ waitToken cpi

87− Left err -> putStrLn ("Error: " <> show err)

88− Right cpi -> print =<< runConnexpay cpi (doThing cmdLine.operation)

98+ doThing cpi Env{ logAction = writeLog, manager } cmdLine.operation

99+

100+waitToken :: Connexpay -> IO ()

101+waitToken cp = readMVar cp.bearerToken >>= \case

102+ Nothing -> threadDelay 500_000 >> waitToken cp

103+ Just _ -> pure ()

104

90−doThing :: Command -> ConnexpayM ()

105+doThing :: Connexpay -> Env -> Command -> IO ()

106+doThing cp env = \case

91−doThing (AuthSale creditCard amt) = liftIO . print =<< authorisePayment AuthRequest

107+ AuthSale card amount -> print =<< authorisePayment cp env AuthRequest

92− { creditCard

108+ { card

93− , amount = Money amt

109+ , amount

94− , invoice = Just "PNRPNR"

110+ , orderNumber = Just "PNRPNR"

95− , vendor = Just "Typeable payment"

111+ , statementDescription = Just "Typeable payment"

112+ , riskData = RiskData

96− }

113+ }

97−doThing (VoidAuth guid) = liftIO . print =<< voidPayment (VoidAuthorized guid)

114+ VoidAuth guid -> print =<< voidPayment cp env (VoidAuthorized guid)

98−doThing (VoidSale guid amt) = liftIO . print =<< voidPayment (VoidCaptured guid (Money <$> amt))

115+ VoidSale guid amt -> print =<< voidPayment cp env (VoidCaptured guid amt)

99−doThing (CaptureSale guid) = liftIO . print =<< capturePayment guid

116+ CaptureSale guid -> print =<< capturePayment cp env guid

100−doThing (CancelSale guid) = liftIO . print =<< cancelPayment guid

117+ CancelSale guid -> print =<< cancelPayment cp env guid

101−doThing (ReturnSale guid amt) = liftIO . print =<< returnPayment guid (Money <$> amt)

118+ ReturnSale guid amt -> print =<< returnPayment cp env guid amt

102−doThing TestAuth = liftIO (forever yield)

119+ TestAuth -> forever yield

stack.yaml+1−5

@@ -4,11 +4,7 @@ packages:

4- connexpay

5- connexpay-optparse

7−extra-deps:

8− - git: https://github.com/typeable/bucks.git

9− commit: 9e378b675fe7fb88d5ddb3af068d82eb441f343c

10− - git: https://github.com/typeable/req.git

11− commit: 8829ac5197f7a4b3f04b7fdfc3ea66cfe70ab0a5

12nix:

7nix:

13 packages: [zlib]

8 packages: [zlib]

14local-bin-path: bin

10local-bin-path: bin