git.iko.soy/typeable/connexpay
on master help sign in
swap
92e8e5229 ahead, 0 behind
.github/workflows/haskell-ci.ymlnew file+215
since splitsnapshots
unifiedsplit
@@ -0,0 +1,215 @@
1+# This GitHub workflow config has been generated by a script via
2+#
3+# haskell-ci 'github' 'cabal.project'
4+#
5+# To regenerate the script (for example after adjusting tested-with) run
6+#
7+# haskell-ci regenerate
8+#
9+# For more information, see https://github.com/haskell-CI/haskell-ci
10+#
11+# version: 0.19.20250330
12+#
13+# REGENDATA ("0.19.20250330",["github","cabal.project"])
14+#
15+name: Haskell-CI
16+on:
17+ push:
18+ branches:
19+ - master
20+ pull_request:
21+ branches:
22+ - master
23+jobs:
24+ linux:
25+ name: Haskell-CI - Linux - ${{ matrix.compiler }}
26+ runs-on: ubuntu-24.04
27+ timeout-minutes:
28+ 60
29+ container:
30+ image: buildpack-deps:jammy
31+ continue-on-error: ${{ matrix.allow-failure }}
32+ strategy:
33+ matrix:
34+ include:
35+ - compiler: ghc-9.8.4
36+ compilerKind: ghc
37+ compilerVersion: 9.8.4
38+ setup-method: ghcup
39+ allow-failure: false
40+ - compiler: ghc-9.6.6
41+ compilerKind: ghc
42+ compilerVersion: 9.6.6
43+ setup-method: ghcup
44+ allow-failure: false
45+ fail-fast: false
46+ steps:
47+ - name: apt-get install
48+ run: |
49+ apt-get update
50+ apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
51+ - name: Install GHCup
52+ run: |
53+ mkdir -p "$HOME/.ghcup/bin"
54+ curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup"
55+ chmod a+x "$HOME/.ghcup/bin/ghcup"
56+ - name: Install cabal-install
57+ run: |
58+ "$HOME/.ghcup/bin/ghcup" install cabal 3.14.1.1-p1 || (cat "$HOME"/.ghcup/logs/*.* && false)
59+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.1.1-p1 -vnormal+nowrap" >> "$GITHUB_ENV"
60+ - name: Install GHC (GHCup)
61+ if: matrix.setup-method == 'ghcup'
62+ run: |
63+ "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
64+ HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER")
65+ HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#')
66+ HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#')
67+ echo "HC=$HC" >> "$GITHUB_ENV"
68+ echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
69+ echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
70+ env:
71+ HCKIND: ${{ matrix.compilerKind }}
72+ HCNAME: ${{ matrix.compiler }}
73+ HCVER: ${{ matrix.compilerVersion }}
74+ - name: Set PATH and environment variables
75+ run: |
76+ echo "$HOME/.cabal/bin" >> $GITHUB_PATH
77+ echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
78+ echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
79+ echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
80+ HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
81+ echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
82+ echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
83+ echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
84+ echo "HEADHACKAGE=false" >> "$GITHUB_ENV"
85+ echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
86+ env:
87+ HCKIND: ${{ matrix.compilerKind }}
88+ HCNAME: ${{ matrix.compiler }}
89+ HCVER: ${{ matrix.compilerVersion }}
90+ - name: env
91+ run: |
92+ env
93+ - name: write cabal config
94+ run: |
95+ mkdir -p $CABAL_DIR
96+ cat >> $CABAL_CONFIG <<EOF
97+ remote-build-reporting: anonymous
98+ write-ghc-environment-files: never
99+ remote-repo-cache: $CABAL_DIR/packages
100+ logs-dir: $CABAL_DIR/logs
101+ world-file: $CABAL_DIR/world
102+ extra-prog-path: $CABAL_DIR/bin
103+ symlink-bindir: $CABAL_DIR/bin
104+ installdir: $CABAL_DIR/bin
105+ build-summary: $CABAL_DIR/logs/build.log
106+ store-dir: $CABAL_DIR/store
107+ install-dirs user
108+ prefix: $CABAL_DIR
109+ repository hackage.haskell.org
110+ url: http://hackage.haskell.org/
111+ EOF
112+ cat >> $CABAL_CONFIG <<EOF
113+ program-default-options
114+ ghc-options: $GHCJOBS +RTS -M3G -RTS
115+ EOF
116+ cat $CABAL_CONFIG
117+ - name: versions
118+ run: |
119+ $HC --version || true
120+ $HC --print-project-git-commit-id || true
121+ $CABAL --version || true
122+ - name: update cabal index
123+ run: |
124+ $CABAL v2-update -v
125+ - name: install cabal-plan
126+ run: |
127+ mkdir -p $HOME/.cabal/bin
128+ curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.7.3.0/cabal-plan-0.7.3.0-x86_64-linux.xz > cabal-plan.xz
129+ echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c -
130+ xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
131+ rm -f cabal-plan.xz
132+ chmod a+x $HOME/.cabal/bin/cabal-plan
133+ cabal-plan --version
134+ - name: checkout
135+ uses: actions/checkout@v4
136+ with:
137+ path: source
138+ - name: initial cabal.project for sdist
139+ run: |
140+ touch cabal.project
141+ echo "packages: $GITHUB_WORKSPACE/source/connexpay" >> cabal.project
142+ echo "packages: $GITHUB_WORKSPACE/source/connexpay-optparse" >> cabal.project
143+ cat cabal.project
144+ - name: sdist
145+ run: |
146+ mkdir -p sdist
147+ $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist
148+ - name: unpack
149+ run: |
150+ mkdir -p unpacked
151+ find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
152+ - name: generate cabal.project
153+ run: |
154+ PKGDIR_connexpay="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/connexpay-[0-9.]*')"
155+ echo "PKGDIR_connexpay=${PKGDIR_connexpay}" >> "$GITHUB_ENV"
156+ PKGDIR_connexpay_optparse="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/connexpay-optparse-[0-9.]*')"
157+ echo "PKGDIR_connexpay_optparse=${PKGDIR_connexpay_optparse}" >> "$GITHUB_ENV"
158+ rm -f cabal.project cabal.project.local
159+ touch cabal.project
160+ touch cabal.project.local
161+ echo "packages: ${PKGDIR_connexpay}" >> cabal.project
162+ echo "packages: ${PKGDIR_connexpay_optparse}" >> cabal.project
163+ echo "package connexpay" >> cabal.project
164+ echo " ghc-options: -Werror=missing-methods" >> cabal.project
165+ echo "package connexpay-optparse" >> cabal.project
166+ echo " ghc-options: -Werror=missing-methods" >> cabal.project
167+ cat >> cabal.project <<EOF
168+ package connexpay
169+ ghc-options: -Werror
170+
171+ package connexpay-optparse
172+ ghc-options: -Werror
173+ EOF
174+ $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(connexpay|connexpay-optparse)$/; }' >> cabal.project.local
175+ cat cabal.project
176+ cat cabal.project.local
177+ - name: dump install plan
178+ run: |
179+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
180+ cabal-plan
181+ - name: restore cache
182+ uses: actions/cache/restore@v4
183+ with:
184+ key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
185+ path: ~/.cabal/store
186+ restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-
187+ - name: install dependencies
188+ run: |
189+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all
190+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all
191+ - name: build w/o tests
192+ run: |
193+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
194+ - name: build
195+ run: |
196+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
197+ - name: cabal check
198+ run: |
199+ cd ${PKGDIR_connexpay} || false
200+ ${CABAL} -vnormal check
201+ cd ${PKGDIR_connexpay_optparse} || false
202+ ${CABAL} -vnormal check
203+ - name: haddock
204+ run: |
205+ $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
206+ - name: unconstrained build
207+ run: |
208+ rm -f cabal.project.local
209+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
210+ - name: save cache
211+ if: always()
212+ uses: actions/cache/save@v4
213+ with:
214+ key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
215+ path: ~/.cabal/store
.gitignorenew file+31
@@ -0,0 +1,31 @@
1+# https://github.com/github/gitignore/blob/main/Haskell.gitignore
2+dist
3+dist-*
4+cabal-dev
5+*.o
6+*.hi
7+*.hie
8+*.chi
9+*.chs.h
10+*.dyn_o
11+*.dyn_hi
12+.hpc
13+.hsenv
14+.cabal-sandbox/
15+cabal.sandbox.config
16+*.prof
17+*.aux
18+*.hp
19+*.eventlog
20+.stack-work/
21+cabal.project.local
22+cabal.project.local~
23+.HTF/
24+
25+stack.yaml.lock
26+
27+# Temp files
28+*~
29+\#*\#
30+
31+config.yml
README.org+27
@@ -28,6 +28,33 @@ NOTE:
28'PaymentError' type isn't used yet, but it will after more testing.
28'PaymentError' type isn't used yet, but it will after more testing.
29Connexpay test environment doesn't seem to report errors adequately.
29Connexpay test environment doesn't seem to report errors adequately.
30
30
31+* The tool
32+
33+This repo provides a command line tool to quickly test the API. You can run it with ~stack run~.
34+Examples:
35+
36+ - ~stack run -- -c ./config.yaml auth CARDNUMBER "NAME" MMYY CVV SUM~
37+ - ~stack run -- -c ./config.yaml capture SALEGUID~
38+ - ~stack run -- -c ./config.yaml void-auth AUTHONLYGUID~
39+ - ~stack run -- -c ./config.yaml void-sale SALEGUID~
40+ - ~stack run -- -c ./config.yaml void-sale SALEGUID SUM~
41+ - ~stack run -- -c ./config.yaml cancel SALEGUID~
42+ - ~stack run -- -c ./config.yaml return SALEGUID~
43+ - ~stack run -- -c ./config.yaml return SALEGUID SUM~
44+
45+Configuration file must include the values provided to you by Connexpay:
46+
47+#+begin_src
48+login: <login>
49+password: <password>
50+device_guid: <device guid>
51+host: <hostname>
52+
53+use_tls: true # Whether or not to use TLS connection
54+proxy_host: 127.0.0.1 # Optional, if you want to proxy your requests for debugging purposes
55+proxy_port: 8080
56+#+end_src
57+
31* Links
58* Links
32
59
33Credit card sales API: https://docs.connexpay.com/reference/credit-card-sales
60Credit card sales API: https://docs.connexpay.com/reference/credit-card-sales
cabal.haskell-cinew file+2
@@ -0,0 +1,2 @@
1+branches: master
2+local-ghc-options: -Werror
cabal.projectnew file+5
@@ -0,0 +1,5 @@
1+with-compiler: ghc-9.6.6
2+
3+packages:
4+ connexpay/
5+ connexpay-optparse/
cabal.project.freezenew file+170
@@ -0,0 +1,170 @@
1+active-repositories: hackage.haskell.org:merge
2+constraints: any.Cabal ==3.10.3.0,
3+ any.Cabal-syntax ==3.10.3.0,
4+ any.OneTuple ==0.4.2,
5+ any.QuickCheck ==2.14.3,
6+ QuickCheck -old-random +templatehaskell,
7+ any.StateVar ==1.2.2,
8+ any.aeson ==2.1.2.1,
9+ aeson -cffi +ordered-keymap,
10+ any.ansi-terminal ==1.0.2,
11+ ansi-terminal -example,
12+ any.ansi-terminal-types ==0.11.5,
13+ any.appar ==0.1.8,
14+ any.array ==0.5.6.0,
15+ any.asn1-encoding ==0.9.6,
16+ any.asn1-parse ==0.9.5,
17+ any.asn1-types ==0.3.4,
18+ any.assoc ==1.1.1,
19+ assoc -tagged,
20+ any.async ==2.2.5,
21+ async -bench,
22+ any.attoparsec ==0.14.4,
23+ attoparsec -developer,
24+ any.attoparsec-iso8601 ==1.1.1.0,
25+ any.base ==4.18.2.1,
26+ any.base-compat ==0.13.1,
27+ any.base-compat-batteries ==0.13.1,
28+ any.base-orphans ==0.9.2,
29+ any.base64-bytestring ==1.2.1.0,
30+ any.basement ==0.0.16,
31+ any.bifunctors ==5.6.2,
32+ bifunctors +tagged,
33+ any.binary ==0.8.9.1,
34+ any.bitvec ==1.1.5.0,
35+ bitvec +simd,
36+ any.blaze-builder ==0.4.2.3,
37+ any.byteorder ==1.0.4,
38+ any.bytestring ==0.11.5.3,
39+ any.case-insensitive ==1.2.1.0,
40+ any.cereal ==0.5.8.3,
41+ cereal -bytestring-builder,
42+ any.colour ==2.3.6,
43+ any.comonad ==5.0.8,
44+ comonad +containers +distributive +indexed-traversable,
45+ any.conduit ==1.3.6,
46+ any.containers ==0.6.7,
47+ any.contravariant ==1.5.5,
48+ contravariant +semigroups +statevar +tagged,
49+ any.cookie ==0.4.6,
50+ any.cryptohash-md5 ==0.11.101.0,
51+ any.cryptohash-sha1 ==0.11.101.0,
52+ any.crypton ==0.34,
53+ crypton -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq +support_pclmuldq +support_rdrand -support_sse +use_target_attributes,
54+ any.crypton-connection ==0.3.2,
55+ any.crypton-x509 ==1.7.7,
56+ any.crypton-x509-store ==1.6.9,
57+ any.crypton-x509-system ==1.6.7,
58+ any.crypton-x509-validation ==1.6.12,
59+ any.data-default-class ==0.1.2.0,
60+ any.data-fix ==0.3.4,
61+ any.deepseq ==1.4.8.1,
62+ any.directory ==1.3.8.5,
63+ any.distributive ==0.6.2.1,
64+ distributive +semigroups +tagged,
65+ any.dlist ==1.0,
66+ dlist -werror,
67+ any.entropy ==0.4.1.10,
68+ entropy -donotgetentropy,
69+ any.exceptions ==0.10.7,
70+ any.filepath ==1.4.300.1,
71+ any.generically ==0.1.1,
72+ any.ghc-bignum ==1.3,
73+ any.ghc-boot-th ==9.6.6,
74+ any.ghc-prim ==0.10.0,
75+ any.hashable ==1.4.4.0,
76+ hashable +integer-gmp -random-initial-seed,
77+ any.hourglass ==0.2.12,
78+ any.hsc2hs ==0.68.10,
79+ hsc2hs -in-ghc-tree,
80+ any.http-api-data ==0.5.1,
81+ http-api-data -use-text-show,
82+ any.http-client ==0.7.17,
83+ http-client +network-uri,
84+ any.http-client-tls ==0.3.6.3,
85+ any.http-types ==0.12.4,
86+ any.indexed-traversable ==0.1.4,
87+ any.indexed-traversable-instances ==0.1.2,
88+ any.integer-conversion ==0.1.0.1,
89+ any.integer-gmp ==1.1,
90+ any.integer-logarithms ==1.0.3.1,
91+ integer-logarithms -check-bounds +integer-gmp,
92+ any.iproute ==1.7.14,
93+ any.libyaml ==0.1.4,
94+ libyaml -no-unicode -system-libyaml,
95+ any.libyaml-clib ==0.2.5,
96+ any.memory ==0.18.0,
97+ memory +support_bytestring +support_deepseq,
98+ any.mime-types ==0.1.2.0,
99+ any.mono-traversable ==1.0.20.0,
100+ any.mtl ==2.3.1,
101+ any.network ==3.1.4.0,
102+ network -devel,
103+ any.network-info ==0.2.1,
104+ any.network-uri ==2.6.4.2,
105+ any.old-locale ==1.0.0.7,
106+ any.old-time ==1.1.0.4,
107+ any.optparse-applicative ==0.18.1.0,
108+ optparse-applicative +process,
109+ any.os-string ==2.0.6,
110+ any.parsec ==3.1.16.1,
111+ any.pem ==0.2.4,
112+ any.pretty ==1.1.3.6,
113+ any.prettyprinter ==1.7.1,
114+ prettyprinter -buildreadme +text,
115+ any.prettyprinter-ansi-terminal ==1.1.3,
116+ any.primitive ==0.8.0.0,
117+ any.process ==1.6.19.0,
118+ any.random ==1.2.1.2,
119+ any.resourcet ==1.3.0,
120+ any.rts ==1.0.2,
121+ any.safe-exceptions ==0.1.7.4,
122+ any.scientific ==0.3.7.0,
123+ scientific -bytestring-builder -integer-simple,
124+ any.semialign ==1.3.1,
125+ semialign +semigroupoids,
126+ any.semigroupoids ==6.0.1,
127+ semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,
128+ any.socks ==0.6.1,
129+ any.split ==0.2.5,
130+ any.splitmix ==0.1.0.5,
131+ splitmix -optimised-mixer,
132+ any.stm ==2.5.1.0,
133+ any.streaming-commons ==0.2.2.6,
134+ streaming-commons -use-bytestring-builder,
135+ any.strict ==0.5,
136+ any.tagged ==0.8.8,
137+ tagged +deepseq +transformers,
138+ any.template-haskell ==2.20.0.0,
139+ any.text ==2.0.2,
140+ any.text-short ==0.1.6,
141+ text-short -asserts,
142+ any.th-abstraction ==0.5.0.0,
143+ any.th-compat ==0.1.5,
144+ any.these ==1.2.1,
145+ any.time ==1.12.2,
146+ any.time-compat ==1.9.6.1,
147+ time-compat -old-locale,
148+ any.tls ==1.8.0,
149+ tls +compat -hans +network,
150+ any.transformers ==0.6.1.0,
151+ any.transformers-compat ==0.7.2,
152+ transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
153+ any.unix ==2.8.4.0,
154+ any.unix-time ==0.4.15,
155+ any.unliftio-core ==0.2.1.0,
156+ any.unordered-containers ==0.2.20,
157+ unordered-containers -debug,
158+ any.uuid ==1.3.15,
159+ any.uuid-types ==1.0.5.1,
160+ any.vector ==0.13.1.0,
161+ vector +boundschecks -internalchecks -unsafechecks -wall,
162+ any.vector-algorithms ==0.9.0.2,
163+ vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
164+ any.vector-stream ==0.1.0.1,
165+ any.witherable ==0.4.2,
166+ any.yaml ==0.11.11.2,
167+ yaml +no-examples +no-exe,
168+ any.zlib ==0.6.3.0,
169+ zlib -bundled-c-zlib -non-blocking-ffi -pkg-config
170+index-state: hackage.haskell.org 2025-03-23T06:19:38Z
connexpay-optparse/connexpay-optparse.cabal+23−5
@@ -1,5 +1,6 @@
1cabal-version: 3.0
1cabal-version: 3.0
2name: connexpay-optparse
2name: connexpay-optparse
3+description: Parsing CLI arguments for connexpay
3version: 0.1
4version: 0.1
4synopsis: Optparse Applicative combinators for Connexpay
5synopsis: Optparse Applicative combinators for Connexpay
5license: MIT
6license: MIT
@@ -10,15 +11,32 @@ copyright: Antorica LLC
10category: System
11category: System
11build-type: Simple
12build-type: Simple
12
13
14+
15+tested-with: GHC ==9.8.4 || ==9.6.6
16+
13−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
14− ghc-options: -Wall
31+ ghc-options:
32+ -Wall -Wmissing-deriving-strategies -Wprepositive-qualified-module
33+ -Wunused-packages -Wredundant-constraints
15
34
16library
35library
17− import: warnings
36+ import: common
18 exposed-modules: Web.Connexpay.Cli
37 exposed-modules: Web.Connexpay.Cli
19 build-depends: base >=4.14 && < 5.0
38 build-depends: base >=4.14 && < 5.0
39+ , connexpay
20 , optparse-applicative
40 , optparse-applicative
21− , text
22− , uuid
23 hs-source-dirs: src
41 hs-source-dirs: src
24 default-language: Haskell2010
42 default-language: Haskell2010
connexpay-optparse/src/Web/Connexpay/Cli.hs+14−13
@@ -1,18 +1,19 @@
1+{-# LANGUAGE ApplicativeDo #-}
2+
1module Web.Connexpay.Cli where
3module Web.Connexpay.Cli where
2
4
3−import Data.UUID
4−import Data.Text (Text)
5import Options.Applicative
5import Options.Applicative
6+import Web.Connexpay.Types
6
7
7−data ConnexpayCli = ConnexpayCli { login :: Text
8− , password :: Text
9− , deviceGuid :: UUID
10− , endpoint :: Text
11− } deriving Show
12
8
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/LICENSEnew file+21
@@ -0,0 +1,21 @@
1+MIT License
2+
3+Copyright (c) 2023 Typeable
4+
5+Permission is hereby granted, free of charge, to any person obtaining a copy
6+of this software and associated documentation files (the "Software"), to deal
7+in the Software without restriction, including without limitation the rights
8+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9+copies of the Software, and to permit persons to whom the Software is
10+furnished to do so, subject to the following conditions:
11+
12+The above copyright notice and this permission notice shall be included in all
13+copies or substantial portions of the Software.
14+
15+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21+SOFTWARE.
connexpay/connexpay.cabal+38−47
@@ -1,77 +1,68 @@
1cabal-version: 3.0
1cabal-version: 3.0
2name: connexpay
2name: connexpay
3+description: Interacting with Connexpay API
3version: 0.1
4version: 0.1
4synopsis: ConnexPay library for Haskell
5synopsis: ConnexPay library for Haskell
5−homepage: https://github.com/downtowntravel/connexpay
6+homepage: https://github.com/typeable/connexpay
6−license: NONE
7+license: MIT
7author: Nick
8author: Nick
8maintainer: nick@typeable.io
9maintainer: nick@typeable.io
9copyright: Typeable.io
10copyright: Typeable.io
10category: Web
11category: Web
11build-type: Simple
12build-type: Simple
12−-- extra-source-files:
13
13
14+
15+tested-with: GHC ==9.8.4 || ==9.6.6
16+
14−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
15− ghc-options: -Wall
31+ ghc-options:
32+ -Wall -Wmissing-deriving-strategies -Wprepositive-qualified-module
33+ -Wunused-packages -Wredundant-constraints
16
34
17library
35library
18− import: warnings
36+ import: common
19− exposed-modules: Web.Connexpay
37+ exposed-modules:
20− Web.Connexpay.Auth
21− Web.Connexpay.Data
22− Web.Connexpay.Init
38+ Web.Connexpay.Init
23− Web.Connexpay.Payments
39+ Web.Connexpay.Payments
24− Web.Connexpay.Types
40+ Web.Connexpay.Types
41+ other-modules:
42+ Web.Connexpay.Auth
43+ Web.Connexpay.Http
44+ Web.Connexpay.Payments.Types
25− Web.Connexpay.Utils
45+ Web.Connexpay.Utils
26− default-extensions: DuplicateRecordFields
27− OverloadedLabels
28− OverloadedRecordDot
29− NoFieldSelectors
30− -- other-modules:
31− -- other-extensions:
32 build-depends: base >=4.14 && < 5.0
46 build-depends: base >=4.14 && < 5.0
33 , aeson
47 , aeson
34 , async
48 , async
35− , bucks
36 , bytestring
49 , bytestring
37 , http-api-data
50 , http-api-data
38 , http-client
51 , http-client
39 , http-types
52 , http-types
40− , mtl
53+ , safe-exceptions
41− , req
42 , text
54 , text
43− , uuid
44 hs-source-dirs: src
55 hs-source-dirs: src
45− default-language: GHC2021
46
56
47executable connexpay-tool
57executable connexpay-tool
48− import: warnings
58+ import: common
49− default-extensions: DuplicateRecordFields
50− OverloadedLabels
51− OverloadedRecordDot
52− NoFieldSelectors
53 build-depends: base >= 4.17
59 build-depends: base >= 4.17
54 , aeson
60 , aeson
55− , async
61+ , connexpay
56− , bucks
57− , bytestring
58− , http-api-data
59 , http-client
62 , http-client
60 , http-client-tls
63 , http-client-tls
61− , http-types
62− , mtl
63 , optparse-applicative
64 , optparse-applicative
64− , req
65 , text
65 , text
66− , uuid
67 , yaml
66 , yaml
68− hs-source-dirs: src
67+ hs-source-dirs: tool
69− other-modules: Web.Connexpay
70− Web.Connexpay.Auth
71− Web.Connexpay.Data
72− Web.Connexpay.Init
73− Web.Connexpay.Payments
74− Web.Connexpay.Types
75− Web.Connexpay.Utils
76− main-is: Tool.hs
68+ main-is: Main.hs
77− default-language: GHC2021
connexpay/src/Tool.hsdeleted−81
@@ -1,81 +0,0 @@
1−{-# LANGUAGE ApplicativeDo #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Main where
4−
5−import Control.Monad
6−import Control.Monad.IO.Class
7−import Data.Aeson
8−import Data.Fixed
9−import Data.Maybe (fromMaybe)
10−import Data.Money
11−import Data.Text (Text)
12−import Data.Text.Encoding qualified as Text
13−import Data.Text.IO qualified as Text
14−import Data.UUID
15−import Data.Yaml (decodeFileThrow)
16−import GHC.Generics
17−import Network.HTTP.Client
18−import Network.HTTP.Client.TLS
19−import Options.Applicative
20−import Web.Connexpay
21−import Web.Connexpay.Types
22−
23−data Config = Config { login :: Text
24− , password :: Text
25− , host :: Text
26− , device_guid :: UUID
27− , use_tls :: Bool
28− , proxy_host :: Maybe Text
29− , proxy_port :: Maybe Word
30− } deriving Generic
31−
32−instance FromJSON Config
33−
34−data Command = AuthSale CreditCard Centi
35− | VoidSale SaleGuid
36− | CaptureSale SaleGuid
37−
38−data CmdLine = CmdLine { configPath :: FilePath
39− , operation :: Command
40− }
41−
42−cmdParser :: Parser CmdLine
43−cmdParser = CmdLine <$> strOption (short 'c' <> metavar "FILE" <> help "Configuration file path")
44− <*> subparser operation
45− where operation = command "auth" (info (AuthSale <$> cc <*> amt) (progDesc "Authorise payment"))
46− <> command "void" (info (VoidSale <$> guid) (progDesc "Void payment"))
47− <> command "capture" (info (CaptureSale <$> guid) (progDesc "Void payment"))
48− amt = argument auto (metavar "Payment amount")
49− cc = CreditCard <$> argument str mempty
50− <*> fmap pure (argument str mempty)
51− <*> argument expdate mempty
52− <*> fmap pure (argument str mempty)
53− expdate = do s <- str
54− guard (length s == 4)
55− pure (read (take 2 s), read (drop 2 s))
56− guid = argument auto (metavar "Payment UUID")
57−
58−
59−
60−writeLog :: Text -> IO ()
61−writeLog msg = Text.putStrLn ("Connexpay log: " <> msg)
62−
63−main :: IO ()
64−main = do cmdLine <- execParser (info cmdParser mempty)
65− cnf :: Config <- decodeFileThrow cmdLine.configPath
66− mgr <- fromMaybe newTlsManager
67− $ do host <- cnf.proxy_host
68− port <- cnf.proxy_port
69− let proxy = useProxy (Proxy (Text.encodeUtf8 host) (fromIntegral port))
70− s = managerSetProxy proxy defaultManagerSettings
71− return (newManager s)
72− res <- initConnexpay writeLog mgr cnf.device_guid cnf.host cnf.use_tls cnf.login cnf.password
73− case res of
74− Left err -> putStrLn ("Error: " <> show err)
75− Right cpi -> print =<< runConnexpay cpi (doThing cmdLine.operation)
76−
77−doThing :: Command -> ConnexpayM ()
78−doThing (AuthSale cc amt) = liftIO . print =<< authorisePayment cc usd Nothing Nothing
79− where usd = Money amt
80−doThing (VoidSale guid) = liftIO . print =<< voidPayment guid Nothing
81−doThing (CaptureSale guid) = liftIO . print =<< capturePayment guid
connexpay/src/Web/Connexpay.hsdeleted−15
@@ -1,15 +0,0 @@
1−module Web.Connexpay ( module Payments
2− , initConnexpay
3− , Connexpay(..)
4− , ConnexpayM
5− , PaymentError(..)
6− , PaymentFailure(..)
7− , TransactionStatus(..)
8− , describeFailure
9− , runConnexpay
10− ) where
11−
12−import Web.Connexpay.Data
13−import Web.Connexpay.Init
14−import Web.Connexpay.Payments as Payments
15−import Web.Connexpay.Types
connexpay/src/Web/Connexpay/Auth.hs+59−23
@@ -1,22 +1,31 @@
1{-# LANGUAGE OverloadedLists #-}
1{-# LANGUAGE OverloadedLists #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Web.Connexpay.Auth (authenticate) where
4
2
5−import Web.Connexpay.Types
3+module Web.Connexpay.Auth
4+ ( AuthReply(..)
5+ , TokenReply(..)
6+ , authenticate
7+ ) where
6
8
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
19
24
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,13 +36,19 @@ instance ToForm AuthForm where
27 , ("password", toQueryParam auth.password)
36 , ("password", toQueryParam auth.password)
28 ]
37 ]
29
38
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)
33
48
34data TokenReply = TokenReply { token :: BearerToken
49data TokenReply = TokenReply { token :: BearerToken
35− , expires_in :: Natural
50+ , expiresIn :: Natural
36− } deriving (Show)
51+ } deriving stock (Show)
37
52
38instance FromJSON TokenReply where
53instance FromJSON TokenReply where
39 parseJSON (Object v) = do typ <- v .: "token_type"
54 parseJSON (Object v) = do typ <- v .: "token_type"
@@ -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
45
60
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−76
@@ -1,76 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Web.Connexpay.Data ( TransactionStatus(..)
3− , PaymentFailure(..)
4− , describeFailure
5− , guessFailure
6− , ErrorMessage(..)
7− , PaymentError(..)
8− ) where
9−
10−import Data.Aeson
11−import Data.Aeson.Types
12−import Data.Maybe (fromMaybe)
13−import Data.Text (Text)
14−import Network.HTTP.Client
15−
16−-- | Transaction status in Connexpay
17−-- The list is taken from https://docs.connexpay.com/reference/search-sales
18−data TransactionStatus = TransactionApproved -- ^ Obvious
19− | TransactionDeclined -- ^ Also obvious
20− | TransactionCreatedLocal -- ^ Seems to only exist in a test environment, indicates success.
21− | TransactionCreatedProcNotReached -- ^ Communication error between Connexpay and Card Processor
22− | TransactionCreatedProcError -- ^ Processor errored out
23− | TransactionApprovedWarning -- ^ Wut 0__o FIXME: figure out what this is
24− | TransactionOther Text -- ^ In case they return something unexpected
25− deriving (Eq, Ord, Show)
26−
27−statuses :: [(Text, TransactionStatus)]
28−statuses = [ ( "Transaction - Approved", TransactionApproved )
29− , ( "Transaction - Declined", TransactionDeclined )
30− , ( "Transaction - CreatedLocal", TransactionCreatedLocal )
31− , ( "Transaction - Created - Error: Processor not reached", TransactionCreatedProcNotReached )
32− , ( "Transaction - Processor Error", TransactionCreatedProcError )
33− , ( "Transaction - Approved - Warning", TransactionApprovedWarning )
34− ]
35−
36−instance FromJSON TransactionStatus where
37− parseJSON (String s) = pure (fromMaybe (TransactionOther s) (lookup s statuses))
38− parseJSON v = typeMismatch "TransactionStatus" v
39−
40−-- | Payment failure types.
41−-- This type describes failures that related to either credit card being invalid,
42−-- client account having insufficient funds, and other non-technical conditions.
43−-- FIXME: this list is not exhaustive. Add more values whenever we encounter them.
44−data PaymentFailure = CVVFailed -- ^ CVV verification failure
45− | CardInvalid -- ^ Credit card details are invalid
46− | InvalidAmount -- ^ Money amount is invalid
47− | LocalTransaction -- ^ Special case for transactions that were registered but did't go through somehow.
48− deriving (Eq, Show)
49−
50−describeFailure :: PaymentFailure -> Text
51−describeFailure CVVFailed = "CVV authorisation failure"
52−describeFailure CardInvalid = "Invalid credit card details"
53−describeFailure InvalidAmount = "Invalid amount of money requested"
54−describeFailure LocalTransaction = "Transaction registered but not processed. Consult with payment processor."
55−
56−-- | Guess failure type from HTTP code and supplied error string.
57−guessFailure :: Int -> Text -> Maybe PaymentFailure
58−guessFailure 422 "Error code D2020. CVV2 verification failed." = Just CVVFailed
59−guessFailure 422 "Error code D2005. Invalid Card." = Just CardInvalid
60−guessFailure 422 "Amount field don't allow a value greater than $999,999.99" = Just InvalidAmount
61−guessFailure _ _ = Nothing
62−
63−-- | Error response from Connexpay
64−data ErrorMessage = ErrorMessage { message :: Text
65− , errorId :: Text }
66−
67−instance FromJSON ErrorMessage where
68− parseJSON (Object o) = ErrorMessage <$> o .: "message"
69− <*> o .: "errorId"
70− parseJSON v = typeMismatch "ErrorMessage" v
71−
72−data PaymentError = ParseError String
73− | InvalidUrl String String
74− | HttpFailure HttpExceptionContent
75− | PaymentFailure PaymentFailure
76− deriving (Show)
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
9+
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+39−49
@@ -1,58 +1,48 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Web.Connexpay.Init where
1+module Web.Connexpay.Init (initConnexpay) where
3−
4−import Web.Connexpay.Auth
5−import Web.Connexpay.Data
6−import Web.Connexpay.Types
7−import Web.Connexpay.Utils
8
2
9import Control.Concurrent
3import Control.Concurrent
10import Control.Concurrent.Async
4import Control.Concurrent.Async
11−import Control.Monad.Except (catchError)
5+import Control.Exception.Safe
12−import Control.Monad.IO.Class
6+import Control.Monad
13−import Control.Monad.Reader (asks)
7+import Data.Aeson
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
17
14
15+import Web.Connexpay.Auth
16+import Web.Connexpay.Types
17+
18+
18-- | Initialise Connexpay state. Log in, authenticate, and obtain bearer token.
19-- | Initialise Connexpay state. Log in, authenticate, and obtain bearer token.
19−initConnexpay :: (Text -> IO ()) -- ^ Logging function
20+initConnexpay
21+ :: Logger
20− -> Manager -- ^ HTTP client manager
22+ -> Manager
21− -> DeviceGuid -- ^ Device GUID. You must obtain this from ConnexPay
23+ -> Config
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 PaymentError Connexpay)
24+ -> IO Connexpay
27−initConnexpay logf mgr devguid url tls login password =
25+initConnexpay logAction manager config = do
28− do v <- newEmptyMVar
29− let env = Connexpay { logAction = logf
30− , manager = mgr
31− , bearerToken = v
26+ bearerToken <- newMVar Nothing
32− , refreshAsync = Nothing
27+ let env = Env{..}
33− , deviceGuid = devguid
28+ refreshAsync <- async $ forever $
34− , url = url
29+ updateToken config env bearerToken 0 `catchAny` \err -> do
35− , useTLS = tls
30+ doLog env $
36− , login = login
31+ "Connexpay token update exception: " <> Text.pack (displayException err)
37− , password = password
32+ threadDelay 5_000_000
38− }
33+ pure Connexpay{..}
39− runConnexpay env $ do
34+
40− (tok, ts) <- authenticate
35+updateToken :: Config -> Env -> MVar (Maybe BearerToken) -> Natural -> IO ()
41− a <- liftIO $ do logf "Connexpay authentication success"
36+updateToken config env tokVar w =
42− putMVar v tok
37+ threadDelay (fromIntegral w * 1_000_000) >> upd
43− async (runConnexpay_ env $ updateToken ts)
38+ where
44− pure (env { refreshAsync = Just a })
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
45
45
46−updateToken :: Natural -> ConnexpayM ()
46+doLog :: Env -> Text -> IO ()
47−updateToken w = liftIO (threadDelay w') >> upd
47+doLog env msg = env.logAction $ Lazy.Text.toStrict $ encodeToLazyText @Object $
48− where w' = fromIntegral w * 1000000
48+ "connexpay" .= ("auth" .= msg :: Object)
49− upd = do (tok, ts) <- authenticate
50− logf <- asks (.logAction)
51− tokVar <- asks (.bearerToken)
52− liftIO (putMVar tokVar tok)
53− liftIO (logf "Connexpay token update success")
54− updateToken (ts - 5)
55− `catchError` \err -> do
56− logf <- asks (.logAction)
57− liftIO (logf ("Connexpay token update failure: " <> tshow err))
58− updateToken 5
connexpay/src/Web/Connexpay/Payments.hs+66−138
@@ -1,153 +1,81 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE UndecidableInstances #-}
4−module Web.Connexpay.Payments ( CreditCard(..)
1+module Web.Connexpay.Payments
2+ ( AuthRequest(..)
3+ , USD(..)
4+ , CreditCard(..)
5+ , ExpirationDate(..)
6+ , Customer(..)
7+ , RiskData(..)
8+ , AuthorizeResult(..)
5− , AuthResponse(..)
9+ , AuthResponse(..)
10+ , TransactionStatus(..)
6− , authorisePayment
11+ , authorisePayment
12+ , VoidRequest(..)
7− , voidPayment
13+ , voidPayment
14+ , CaptureResponse(..)
15+ , Sale(..)
8− , capturePayment
16+ , capturePayment
9− , cancelPayment
17+ , cancelPayment
18+ , returnPayment
10− ) where
19+ ) where
11
20
12−import Control.Monad (when,void)
13−import Control.Monad.Except (throwError)
14−import Control.Monad.Reader (asks)
15−import Control.Monad.Writer.Strict
16import Data.Aeson
21import Data.Aeson
17−import Data.Aeson.KeyMap qualified as KeyMap
18−import Data.Aeson.Types (Pair, typeMismatch)
19−import Data.Int (Int32)
20−import Data.Money
21−import Data.Proxy
22−import Data.Text (Text)
23−import Data.Text qualified as Text
24−import Data.Text.Encoding qualified as Text
25−import GHC.TypeError as TypeError
26−import Network.HTTP.Req
27
22
28−import Web.Connexpay.Data
23+import Web.Connexpay.Http
24+import Web.Connexpay.Payments.Types
29import Web.Connexpay.Types
25import Web.Connexpay.Types
30−import Web.Connexpay.Utils
31
26
32−-- | Credit card info
33−-- No 'Show' instance should be made for this type
34−-- in order to avoid sensitive data leaks.
35−data CreditCard = CreditCard { number :: Text -- ^ Credit card number, as 'Text'.
36− , cardholder :: Maybe Text -- ^ Cardholder name, optional.
37− , expiration :: (Word, Word) -- ^ Expiration date (month,year).
38− , cvv :: Maybe Text -- ^ CVC/CVV code.
39− }
40−
41−type ShowError = TypeError.Text "CreditCard must not be shown in order to avoid leaking sensitive data"
42−
43−instance TypeError ShowError => Show CreditCard where
44− show = error "UNREACHABLE"
45−
46−instance ToJSON CreditCard where
47− toJSON cc = object
48− $ execWriter
49− $ do tell ["CardNumber" .= cc.number]
50− whenJust cc.cardholder $ \name ->
51− tell ["CardHolderName" .= name]
52− whenJust cc.cvv $ \cvv ->
53− tell ["Cvv2" .= cvv]
54− let expDate = padDate (tshow (snd cc.expiration)) <> padDate (tshow (fst cc.expiration))
55− tell ["ExpirationDate" .= expDate]
56−
57−padDate :: Text -> Text
58−padDate t | Text.length t == 1 = "0" <> t
59− | otherwise = t
60−
61−sendRequest' :: HttpResponse resp => Proxy resp -> Text -> [Pair] -> ConnexpayM resp
62−sendRequest' resp endpoint body =
63− do tok <- bearerToken
64− host <- asks (.url)
65− tls <- asks (.useTLS)
66− let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)
67− url s = s host /: "api" /: "v1" /: endpoint
68− jbody <- ReqBodyJson . object <$> addGuid body
69− if tls
70− then req POST (url https) jbody resp auth
71− else req POST (url http) jbody resp auth
72− where addGuid b = do guid <- asks (.deviceGuid)
73− return (b <> [ "DeviceGuid" .= show guid ])
74−
75−sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a)
76−sendRequestJson = sendRequest' jsonResponse
77−
78−sendRequest_ :: Text -> [Pair] -> ConnexpayM ()
79−sendRequest_ ep = void . sendRequest' ignoreResponse ep
80−
81−data AuthResponse = AuthResponse { paymentGuid :: SaleGuid
82− , status :: TransactionStatus
83− , processorStatusCode :: Maybe Text
84− , processorMessage :: Maybe Text
85− } deriving (Show)
86−
87−instance FromJSON AuthResponse where
88− parseJSON (Object o) = AuthResponse <$> o .: "guid"
89− <*> o .: "status"
90− <*> o .:? "processorStatusCode"
91− <*> o .:? "processorResponseMessage"
92− parseJSON v = typeMismatch "AuthReponse" v
93
27
94-- | Authorise a credit card payment.
28-- | Authorise a credit card payment.
95−authorisePayment :: CreditCard -- ^ Credit card details (see 'CreditCard')
29+authorisePayment
96− -> Money USD -- ^ Amount to charge, USD
30+ :: Connexpay -> Env -> AuthRequest -> IO (Response AuthError AuthorizeResult)
97− -> Maybe Text -- ^ Invoice description
98− -> Maybe Text -- ^ Merchant description that will appear in a customer's statement.
99− -> ConnexpayM AuthResponse
100−authorisePayment cc amt invoice vendor =
31+authorisePayment connexpay env raw =
101− do resp <- sendRequestJson "authonlys" body
32+ bimapResponse (guessErrorType guessAuthError) postProcessAuthResponse <$>
102− let rbody = responseBody resp
33+ doRequest connexpay env "authonlys" RequestBody
103− -- Special case for Connexpay local transaction
34+ { raw
104− -- This status means that the transaction was registered,
35+ , logMasker = maskAuthRequest
105− -- but Connexpay stopped its processing and it won't be
36+ }
106− -- moved any further.
107− -- Also, when I asked Ken from Connexpay about this,
108− -- he told me he had never seen this status before.
109− when (rbody.status == TransactionCreatedLocal) $
110− throwError (PaymentFailure LocalTransaction)
111− pure rbody
112− where body = execWriter $
113− do tell [ "Card" .= cc ]
114− tell [ "Amount" .= getAmount amt ]
115− whenJust invoice $ \i ->
116− tell [ "OrderNumber" .= i ]
117− whenJust vendor $ \v ->
118− tell [ "StatementDescription" .= v ]
119− -- We are supposed to pass RiskData, but it still
120− -- can be an empty object. Consider population this
121− -- should the need arise.
122− tell [ "RiskData" .= KeyMap.empty @() ]
123
37
124-- | Void payment
38-- | Void payment
125−voidPayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
39+voidPayment :: Connexpay -> Env -> VoidRequest -> IO (Response () ())
126− -> Maybe (Money USD) -- ^ Optionally, you may only void a partial sum, with the rest being subsequently charged.
40+voidPayment connexpay env raw = doRequest_ connexpay env "void" RequestBody
127− -> ConnexpayM ()
41+ { raw
128−voidPayment pid amt = sendRequest_ "void" body
42+ , logMasker = id
129− where body = execWriter $
43+ }
130− do tell [ "AuthOnlyGuid" .= show pid ]
131− whenJust amt $ \m ->
132− tell [ "Amount" .= getAmount m ]
133−
134−-- | Internal data type for Capture requests.
135−data CPTransaction = CPTransaction { expectedPayments :: Int32 }
136−
137−instance ToJSON CPTransaction where
138− toJSON t = object [ "ExpectedPayments" .= t.expectedPayments ]
139
44
140-- | Capture payment, previously authorised through 'authorisePayment'.
45-- | Capture payment, previously authorised through 'authorisePayment'.
46+capturePayment :: Connexpay
47+ -> Env
141−capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
48+ -> AuthOnlyGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
142− -> ConnexpayM ()
49+ -> IO (Response () CaptureResponse)
143−capturePayment pid = sendRequest_ "Captures" body
50+capturePayment connexpay env pid = doRequest connexpay env "Captures" RequestBody
51+ { raw = object
144− where body = [ "AuthOnlyGuid" .= show pid
52+ [ "AuthOnlyGuid" .= pid
145− , "ConnexPayTransaction" .= CPTransaction 1 ]
53+ , "ConnexPayTransaction" .= CPTransaction 1
54+ ]
55+ , logMasker = id
56+ }
146
57
147-- | Cancel voided or captured payment.
58-- | Cancel voided or captured payment.
148-- In case of an authorised-only payment, voiding is performed.
59-- In case of an authorised-only payment, voiding is performed.
149-- Otherwise, a payment goes through a refund process.
60-- Otherwise, a payment goes through a refund process.
61+cancelPayment :: Connexpay
62+ -> Env
150−cancelPayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
63+ -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
151− -> ConnexpayM ()
64+ -> IO (Response () ())
152−cancelPayment pid = sendRequest_ "cancel" body
65+cancelPayment connexpay env pid = doRequest_ connexpay env "cancel" RequestBody
153− where body = [ "SaleGuid" .= show pid ]
66+ { raw = object [ "SaleGuid" .= pid ]
67+ , logMasker = id
68+ }
69+
70+returnPayment :: Connexpay
71+ -> Env
72+ -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
73+ -> USD
74+ -> IO (Response () ())
75+returnPayment connexpay env pid amt = doRequest_ connexpay env "returns" RequestBody
76+ { raw = object
77+ [ "SaleGuid" .= pid
78+ , "Amount" .= amt
79+ ]
80+ , logMasker = id
81+ }
connexpay/src/Web/Connexpay/Payments/Types.hsnew file+236
@@ -0,0 +1,236 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TemplateHaskell #-}
3+
4+module Web.Connexpay.Payments.Types where
5+
6+import Data.Aeson
7+import Data.Aeson.TH
8+import Data.Fixed
9+import Data.Function
10+import Data.Int (Int32)
11+import Data.Maybe
12+import Data.Text (Text)
13+import Data.Text qualified as Text
14+import GHC.TypeError as TypeError
15+import Text.Printf
16+
17+import Web.Connexpay.Http
18+import Web.Connexpay.Types
19+import Web.Connexpay.Utils
20+
21+
22+data AuthRequest = AuthRequest
23+ { card :: CreditCard
24+ , amount :: USD
25+ , orderNumber :: Maybe Text
26+ , statementDescription :: Maybe Text
27+ -- ^ Merchant description that will appear in a
28+ -- customer's statement.
29+ , riskData :: RiskData
30+ }
31+
32+maskAuthRequest :: LogMasker AuthRequest
33+maskAuthRequest req = AuthRequest
34+ { card = maskCreditCard req.card
35+ , amount = req.amount
36+ , orderNumber = starWords <$> req.orderNumber
37+ , statementDescription = req.statementDescription
38+ , riskData = maskRiskData req.riskData
39+ }
40+
41+newtype USD = USD Centi
42+ deriving newtype (Read, FromJSON, ToJSON)
43+
44+-- | Credit card info
45+-- No 'Show' instance should be made for this type
46+-- in order to avoid sensitive data leaks.
47+data CreditCard = CreditCard
48+ { cardNumber :: Text
49+ , cardHolderName :: Maybe Text
50+ , expirationDate :: ExpirationDate
51+ , cvv2 :: Maybe Text
52+ , customer :: Maybe Customer
53+ -- ^ Required to get AVS
54+ }
55+
56+type ShowError = TypeError.Text
57+ "CreditCard must not be shown in order to avoid leaking sensitive data"
58+
59+instance TypeError ShowError => Show CreditCard where
60+ show = error "UNREACHABLE"
61+
62+maskCreditCard :: LogMasker CreditCard
63+maskCreditCard cc = CreditCard
64+ { cardNumber = maskCreditCardNumber cc.cardNumber
65+ , cardHolderName = starWords <$> cc.cardHolderName
66+ , expirationDate = maskExpirationDate cc.expirationDate
67+ , cvv2 = starWords <$> cc.cvv2
68+ , customer = maskCustomer <$> cc.customer
69+ }
70+
71+maskCreditCardNumber :: Text -> Text
72+maskCreditCardNumber number = firstDigits <> stars <> lastDigits
73+ where
74+ (firstDigits, rest) = Text.splitAt 4 number
75+ toDrop = Text.length rest - 4
76+ (_, lastDigits) = Text.splitAt toDrop rest
77+ stars = Text.replicate toDrop "*"
78+
79+data ExpirationDate = ExpirationDate
80+ { year :: Word
81+ -- ^ Last 2 digits of the year in range from 0 (2000) to 99 (2099).
82+ -- No check is performed whether the value fits into the range.
83+ , month :: Word
84+ -- ^ Month of year, in range 1 (January) to 12 (December).
85+ -- No check is performed whether the value fits into the range.
86+ }
87+
88+instance ToJSON ExpirationDate where
89+ toJSON expiry =
90+ toJSON (printf "%02d%02d" expiry.year expiry.month :: String)
91+
92+maskExpirationDate :: LogMasker ExpirationDate
93+maskExpirationDate _ = ExpirationDate
94+ { year = 0
95+ , month = 0
96+ }
97+
98+data Customer = Customer
99+ { address1 :: Text
100+ , address2 :: Maybe Text
101+ , zip :: Maybe Text
102+ }
103+
104+maskCustomer :: LogMasker Customer
105+maskCustomer customer = Customer
106+ { address1 = starWords customer.address1
107+ , address2 = starWords <$> customer.address2
108+ , zip = customer.zip
109+ }
110+
111+-- | Currently unpopulated
112+data RiskData = RiskData
113+
114+instance ToJSON RiskData where
115+ toJSON RiskData = Object mempty
116+
117+maskRiskData :: LogMasker RiskData
118+maskRiskData = id
119+
120+data AuthorizeResult
121+ = Authorized AuthResponse
122+ -- ^ Transaction has been created and authorized successfully
123+ | Declined AuthResponse
124+ -- ^ Transaction has been created, but not authorized,
125+ -- e.g. declined by internal Connexpay fraud checks
126+ | Ambiguous AuthResponse
127+ -- ^ We can't interpret the result, e.g. wasProcess=true,
128+ -- but transaction status is not approved.
129+ -- Something for further investigation.
130+ deriving stock (Show)
131+
132+postProcessAuthResponse :: AuthResponse -> AuthorizeResult
133+postProcessAuthResponse resp = resp & case (completed, statusOk) of
134+ (True, True) -> Authorized
135+ (False, False) -> Declined
136+ _ -> Ambiguous
137+ where
138+ -- Connexpay documentation is not very clear about 'wasProcessed' semantics
139+ -- when it is missing, so we are intentionally strict here with the idea
140+ -- to warn about all 'Ambiguous' cases and adjust this code accordingly.
141+ completed = resp.wasProcessed == Just True
142+ statusOk = resp.status `elem` [TransactionApproved, TransactionApprovedWarning]
143+
144+data AuthResponse = AuthResponse
145+ { guid :: AuthOnlyGuid
146+ , status :: TransactionStatus
147+ , processorStatusCode :: Maybe Text
148+ , processorResponseMessage :: Maybe Text
149+ , addressVerificationCode :: Maybe Text
150+ , cvvVerificationCode :: Maybe Text
151+ , wasProcessed :: Maybe Bool
152+ } deriving stock (Show)
153+
154+-- | Transaction status in Connexpay
155+-- The list is taken from https://docs.connexpay.com/reference/search-sales
156+data TransactionStatus
157+ = TransactionApproved
158+ | TransactionApprovedWarning
159+ | TransactionCreatedLocal
160+ -- ^ Seems to only exist in a test environment, indicates success.
161+ | TransactionDeclined
162+ | TransactionCreatedProcNotReached
163+ -- ^ Communication error between Connexpay and Card Processor
164+ | TransactionCreatedProcError
165+ -- ^ Processor errored out
166+ | TransactionOther Text
167+ -- ^ In case they return something unexpected
168+ deriving stock (Eq, Show)
169+
170+instance FromJSON TransactionStatus where
171+ parseJSON = withText "TransactionStatus" $ pure . \case
172+ "Transaction - Approved" -> TransactionApproved
173+ "Transaction - Approved - Warning" -> TransactionApprovedWarning
174+ "Transaction - CreatedLocal" -> TransactionCreatedLocal
175+ "Transaction - Declined" -> TransactionDeclined
176+ "Transaction - Created - Error: Processor not reached" ->
177+ TransactionCreatedProcNotReached
178+ "Transaction - Processor Error" -> TransactionCreatedProcError
179+ other -> TransactionOther other
180+
181+data AuthError
182+ = CVVFailed -- ^ CVV verification failure
183+ | CardInvalid -- ^ Credit card details are invalid
184+ | InvalidAmount -- ^ Money amount is invalid
185+ | GeneralDecline -- ^ They just decline
186+ | OtherAuthError Text -- ^ Some other processing error with 422 code
187+ deriving stock (Show)
188+
189+-- | Guess failure type from error string.
190+guessAuthError :: Error () -> AuthError
191+guessAuthError err = case err.message of
192+ "Error code D2020. CVV2 verification failed." -> CVVFailed
193+ "Error code D2005. Invalid Card." -> CardInvalid
194+ "Amount field don't allow a value greater than $999,999.99" -> InvalidAmount
195+ "Error code D2999. General CardAuth Decline." -> GeneralDecline
196+ txt -> OtherAuthError txt
197+
198+data VoidRequest
199+ = VoidAuthorized AuthOnlyGuid
200+ | VoidCaptured SaleGuid (Maybe USD)
201+
202+instance ToJSON VoidRequest where
203+ toJSON = \case
204+ VoidAuthorized pid -> object ["AuthOnlyGuid" .= pid]
205+ VoidCaptured pid mbAmount -> object $ catMaybes
206+ [ Just $ "SaleGuid" .= pid
207+ , ("Amount" .=) <$> mbAmount
208+ ]
209+
210+-- | Internal data type for Capture requests.
211+data CPTransaction = CPTransaction
212+ { expectedPayments :: Int32
213+ }
214+
215+instance ToJSON CPTransaction where
216+ toJSON t = object [ "ExpectedPayments" .= t.expectedPayments ]
217+
218+-- | Response for the payment capture request
219+data CaptureResponse = CaptureResponse
220+ { guid :: CaptureGuid
221+ , sale :: Sale
222+ } deriving stock (Show)
223+
224+data Sale = Sale
225+ { guid :: SaleGuid
226+ , status :: TransactionStatus
227+ } deriving stock (Show)
228+
229+concat <$> sequence
230+ [ deriveToJSON aesonOptions ''AuthRequest
231+ , deriveToJSON aesonOptions ''CreditCard
232+ , deriveToJSON aesonOptions ''Customer
233+ , deriveFromJSON defaultOptions ''AuthResponse
234+ , deriveFromJSON defaultOptions ''CaptureResponse
235+ , deriveFromJSON defaultOptions ''Sale
236+ ]
connexpay/src/Web/Connexpay/Types.hs+82−57
@@ -1,61 +1,86 @@
1−{-# LANGUAGE OverloadedStrings #-}
2module Web.Connexpay.Types where
1module Web.Connexpay.Types where
3
2
4−import Web.Connexpay.Data
5−import Web.Connexpay.Utils
6−
7import Control.Concurrent.Async
3import Control.Concurrent.Async
8−import Control.Concurrent.MVar (MVar, readMVar)
4+import Control.Concurrent.MVar (MVar)
9−import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError)
10−import Control.Monad.IO.Class
11−import Control.Monad.Reader
12−import Data.Aeson
5+import Data.Aeson hiding (Error)
6+import Data.Bifunctor
7+import Data.ByteString.Lazy qualified as Lazy (ByteString)
13import Data.Text (Text)
8import Data.Text (Text)
14−import Data.Text qualified as Text
15−import Data.UUID (UUID)
16−import Network.HTTP.Client
9+import Network.HTTP.Client (Manager)
17−import Network.HTTP.Req
10+
18−import Network.HTTP.Types
11+
19−
20−type BearerToken = Text
12+newtype BearerToken = BearerToken
21−type DeviceGuid = UUID
13+ { unBearerToken :: Text
14+ } deriving newtype (Show, FromJSON, ToJSON)
15+
16+newtype AuthOnlyGuid = AuthOnlyGuid
17+ { unAuthOnlyGuid :: Text
18+ } deriving newtype (Show, FromJSON, ToJSON)
19+
22−type SaleGuid = UUID
20+newtype SaleGuid = SaleGuid
23−
21+ { unSaleGuid :: Text
24−data Connexpay = Connexpay { logAction :: Text -> IO ()
22+ } deriving newtype (Show, FromJSON, ToJSON)
25− , manager :: Manager
23+
26− , bearerToken :: MVar BearerToken
24+newtype CaptureGuid = CaptureGuid
27− , refreshAsync :: Maybe (Async ())
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
28− , deviceGuid :: DeviceGuid
34+ , deviceGuid :: Text
29− , url :: Text
30− , useTLS :: Bool
35+ , useTLS :: Bool
31− , login :: Text
32− , password :: Text
33− }
36+ }
34−
37+
35−newtype ConnexpayM a = ConnexpayM (ReaderT Connexpay (ExceptT PaymentError IO) a)
38+data Connexpay = Connexpay
36− deriving (Functor, Applicative, Monad, MonadIO, MonadReader Connexpay, MonadError PaymentError)
39+ { config :: Config
37−
40+ , bearerToken :: MVar (Maybe BearerToken)
38−instance MonadHttp ConnexpayM where
41+ , refreshAsync :: Async ()
39− handleHttpException (JsonHttpException e) = throwError (ParseError e)
42+ }
40− handleHttpException (VanillaHttpException (InvalidUrlException url why)) = throwError (InvalidUrl url why)
43+
41− handleHttpException (VanillaHttpException (HttpExceptionRequest _ (StatusCodeException resp bs)))
44+data Env = Env
42− | Just err <- decodeStrict @ErrorMessage bs
45+ { logAction :: Logger
43− , Just f <- guessFailure (statusCode $ responseStatus resp) err.message = throwError (PaymentFailure f)
46+ , manager :: Manager
44− handleHttpException (VanillaHttpException (HttpExceptionRequest _ c)) = throwError (HttpFailure c)
47+ }
45−
48+
46− getHttpConfig = do mgr <- asks (.manager)
49+data Response e a
47− pure (defaultHttpConfig { httpConfigAltManager = Just mgr })
50+ = ResponseSuccess a
48−
51+ | ResponseError (Error e)
49−
52+ -- ^ Response structured error (422 status code) is received
50−runConnexpay :: Connexpay -> ConnexpayM a -> IO (Either PaymentError a)
53+ | BadRequest Lazy.ByteString
51−runConnexpay cp (ConnexpayM a) = runExceptT (runReaderT a cp)
54+ | MissingOrExpiredToken
52−
55+ -- ^ Most likely invalid credentials/URL are passed during initialization.
53−runConnexpay_ :: Connexpay -> ConnexpayM a -> IO ()
56+ -- No request is even sent to Connexpay.
54−runConnexpay_ cp m =
57+ deriving stock (Show, Functor)
55− do r <- runConnexpay cp m
58+
56− whenLeft r $ \err ->
59+instance Bifunctor Response where
57− cp.logAction ("Uncaught Connexpay error: " <> Text.pack (show err))
60+ bimap f = bimapResponse (fmap f)
58−
61+
59−bearerToken :: ConnexpayM BearerToken
62+bimapResponse
60−bearerToken = do v <- asks (.bearerToken)
63+ :: (Error e -> Error e') -> (a -> b) -> Response e a -> Response e' b
61− liftIO (readMVar v)
64+bimapResponse f g = \case
65+ ResponseSuccess a -> ResponseSuccess (g a)
66+ ResponseError e -> ResponseError (f e)
67+ BadRequest body -> BadRequest body
68+ MissingOrExpiredToken -> MissingOrExpiredToken
69+
70+guessErrorType :: (Error () -> e) -> Error () -> Error e
71+guessErrorType mkErr e = e { errorType = mkErr e }
72+
73+data Error e = Error
74+ { message :: Text
75+ , errorId :: Text
76+ , errorType :: e
77+ } deriving stock (Show, Functor)
78+
79+instance FromJSON (Error ()) where
80+ parseJSON = withObject "Error" \o -> do
81+ message <- o .: "message"
82+ errorId <- o .: "errorId"
83+ pure Error
84+ { errorType = ()
85+ , ..
86+ }
connexpay/src/Web/Connexpay/Utils.hs+15−8
@@ -1,15 +1,22 @@
1module Web.Connexpay.Utils where
1module Web.Connexpay.Utils where
2
2
3+import Data.Aeson.Types
4+import Data.Char
3import Data.Text (Text)
5import Data.Text (Text)
4import Data.Text qualified as Text
6import Data.Text qualified as Text
5
7
6−whenLeft :: Monad m => Either a b -> (a -> m ()) -> m ()
7−whenLeft (Left l) f = f l
8−whenLeft (Right _) _ = pure ()
9
8
10−whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
9+starWords :: Text -> Text
11−whenJust (Just x) f = f x
10+starWords = Text.unwords . map toStars . Text.words
12−whenJust Nothing _ = pure ()
11+ where toStars w = Text.replicate (Text.length w) "*"
13
12
14−tshow :: Show a => a -> Text
13+capitalize :: String -> String
15−tshow = Text.pack . show
14+capitalize [] = []
15+capitalize (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.hsnew file+119
@@ -0,0 +1,119 @@
1+{-# LANGUAGE ApplicativeDo #-}
2+
3+module Main where
4+
5+import Control.Concurrent
6+import Control.Monad
7+import Data.Aeson
8+import Data.Coerce
9+import Data.Maybe (fromMaybe)
10+import Data.Text (Text)
11+import Data.Text.Encoding qualified as Text
12+import Data.Text.IO qualified as Text
13+import Data.Yaml (decodeFileThrow)
14+import GHC.Generics
15+import Network.HTTP.Client
16+import Network.HTTP.Client.TLS
17+import Options.Applicative
18+import Web.Connexpay.Init
19+import Web.Connexpay.Payments
20+import Web.Connexpay.Types
21+
22+
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
32+
33+instance FromJSON ConfigYaml where
34+ parseJSON = genericParseJSON defaultOptions
35+ { fieldLabelModifier = camelTo2 '_'
36+ }
37+
38+configFromYaml :: ConfigYaml -> Config
39+configFromYaml ConfigYaml{..} = Config{..}
40+
41+data Command = AuthSale CreditCard USD
42+ | VoidAuth AuthOnlyGuid
43+ | VoidSale SaleGuid (Maybe USD)
44+ | CaptureSale AuthOnlyGuid
45+ | CancelSale SaleGuid
46+ | ReturnSale SaleGuid USD
47+ | TestAuth
48+
49+data CmdLine = CmdLine { configPath :: FilePath
50+ , operation :: Command
51+ }
52+
53+cmdParser :: Parser CmdLine
54+cmdParser = CmdLine <$> strOption (short 'c' <> metavar "FILE" <> help "Configuration file path")
55+ <*> subparser operation
56+ where operation = command "auth" (info (AuthSale <$> cc <*> amt) (progDesc "Authorise payment"))
57+ <> command "void-auth" (info (VoidAuth <$> guid) (progDesc "Void payment"))
58+ <> command "void-sale" (info (VoidSale <$> guid <*> optional amt) (progDesc "Void payment"))
59+ <> command "capture" (info (CaptureSale <$> guid) (progDesc "Capture payment"))
60+ <> command "cancel" (info (CancelSale <$> guid) (progDesc "Cancel payment"))
61+ <> command "return" (info (ReturnSale <$> guid <*> amt) (progDesc "return payment"))
62+ <> command "test-auth" (info (pure TestAuth) (progDesc "Test token authorisation"))
63+ amt = argument auto (metavar "Payment amount")
64+ cc = CreditCard <$> argument str mempty
65+ <*> fmap pure (argument str mempty)
66+ <*> argument expdate mempty
67+ <*> fmap pure (argument str mempty)
68+ <*> pure
69+ ( Just Customer
70+ { address1 = "123 Test St"
71+ , address2 = Nothing
72+ , zip = Just "EC1A1BB"
73+ } )
74+ expdate = do s <- str
75+ guard (length s == 4)
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
82+ guid = coerce @Text <$> strArgument (metavar "Payment UUID")
83+
84+writeLog :: Text -> IO ()
85+writeLog msg = Text.putStrLn ("Connexpay log: " <> msg)
86+
87+main :: IO ()
88+main = do cmdLine <- execParser (info (cmdParser <**> helper) mempty)
89+ cnf :: ConfigYaml <- decodeFileThrow cmdLine.configPath
90+ manager <- fromMaybe newTlsManager
91+ $ do host <- cnf.proxyHost
92+ port <- cnf.proxyPort
93+ let proxy = useProxy (Proxy (Text.encodeUtf8 host) (fromIntegral port))
94+ s = managerSetProxy proxy defaultManagerSettings
95+ return (newManager s)
96+ cpi <- initConnexpay writeLog manager $ configFromYaml cnf
97+ waitToken cpi
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+
105+doThing :: Connexpay -> Env -> Command -> IO ()
106+doThing cp env = \case
107+ AuthSale card amount -> print =<< authorisePayment cp env AuthRequest
108+ { card
109+ , amount
110+ , orderNumber = Just "PNRPNR"
111+ , statementDescription = Just "Typeable payment"
112+ , riskData = RiskData
113+ }
114+ VoidAuth guid -> print =<< voidPayment cp env (VoidAuthorized guid)
115+ VoidSale guid amt -> print =<< voidPayment cp env (VoidCaptured guid amt)
116+ CaptureSale guid -> print =<< capturePayment cp env guid
117+ CancelSale guid -> print =<< cancelPayment cp env guid
118+ ReturnSale guid amt -> print =<< returnPayment cp env guid amt
119+ TestAuth -> forever yield
stack.yaml+2−5
@@ -1,13 +1,10 @@
1−resolver: lts-22.13
1+resolver: lts-22.36
2
2
3packages:
3packages:
4- connexpay
4- connexpay
5- connexpay-optparse
5- connexpay-optparse
6
6
7−extra-deps:
8− - git: https://github.com/typeable/bucks.git
9− commit: 9e378b675fe7fb88d5ddb3af068d82eb441f343c
10−
11nix:
7nix:
12 packages: [zlib]
8 packages: [zlib]
9+
13local-bin-path: bin
10local-bin-path: bin