git.iko.soy/typeable/connexpay
on master help sign in
swap
92e8e5238 ahead, 0 behind
23 files changed+1339−425
since splitsnapshots
unifiedsplit
.github/workflows/haskell-ci.yml+215 .gitignore+31 README.org+27 cabal.haskell-ci+2 cabal.project+5 cabal.project.freeze+170 connexpay-optparse/LICENSE+20 connexpay-optparse/connexpay-optparse.cabal+42 connexpay-optparse/src/Web/Connexpay/Cli.hs+19 connexpay/LICENSE+21 connexpay/connexpay.cabal+39−40 connexpay/src/Tool.hs−80 connexpay/src/Web/Connexpay.hs−11 connexpay/src/Web/Connexpay/Auth.hs+59−23 connexpay/src/Web/Connexpay/Data.hs−32 connexpay/src/Web/Connexpay/Http.hs+128 connexpay/src/Web/Connexpay/Init.hs+39−48 connexpay/src/Web/Connexpay/Payments.hs+66−119 connexpay/src/Web/Connexpay/Payments/Types.hs+236 connexpay/src/Web/Connexpay/Types.hs+82−58 connexpay/src/Web/Connexpay/Utils.hs+15−8 connexpay/tool/Main.hs+119 stack.yaml+4−6
.github/workflows/haskell-ci.ymlnew file+215
@@ -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:
2828'PaymentError' type isn't used yet, but it will after more testing.
2929Connexpay test environment doesn't seem to report errors adequately.
3030
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+
3158* Links
3259
3360Credit 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/LICENSEnew file+20
@@ -0,0 +1,20 @@
1+Copyright (c) 2024 Nick
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be included
12+in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
connexpay-optparse/connexpay-optparse.cabalnew file+42
@@ -0,0 +1,42 @@
1+cabal-version: 3.0
2+name: connexpay-optparse
3+description: Parsing CLI arguments for connexpay
4+version: 0.1
5+synopsis: Optparse Applicative combinators for Connexpay
6+license: MIT
7+license-file: LICENSE
8+author: Nick
9+maintainer: nick@typeable.io
10+copyright: Antorica LLC
11+category: System
12+build-type: Simple
13+
14+
15+tested-with: GHC ==9.8.4 || ==9.6.6
16+
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
31+ ghc-options:
32+ -Wall -Wmissing-deriving-strategies -Wprepositive-qualified-module
33+ -Wunused-packages -Wredundant-constraints
34+
35+library
36+ import: common
37+ exposed-modules: Web.Connexpay.Cli
38+ build-depends: base >=4.14 && < 5.0
39+ , connexpay
40+ , optparse-applicative
41+ hs-source-dirs: src
42+ default-language: Haskell2010
connexpay-optparse/src/Web/Connexpay/Cli.hsnew file+19
@@ -0,0 +1,19 @@
1+{-# LANGUAGE ApplicativeDo #-}
2+
3+module Web.Connexpay.Cli where
4+
5+import Options.Applicative
6+import Web.Connexpay.Types
7+
8+
9+connexpayOpts :: Parser Config
10+connexpayOpts = do
11+ host <- option str (long "connexpay-endpoint" <> metavar "URL")
12+ login <- option str (long "connexpay-login" <> metavar "LOGIN")
13+ password <- option str (long "connexpay-password" <> metavar "PASSWORD")
14+ deviceGuid <- option str (long "connexpay-devguid" <> metavar "GUID")
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+39−40
@@ -1,69 +1,68 @@
11cabal-version: 3.0
22name: connexpay
3+description: Interacting with Connexpay API
34version: 0.1
45synopsis: ConnexPay library for Haskell
5−homepage: https://github.com/downtowntravel/connexpay
6−license: NONE
6+homepage: https://github.com/typeable/connexpay
7+license: MIT
78author: Nick
89maintainer: nick@typeable.io
910copyright: Typeable.io
1011category: Web
1112build-type: Simple
12−-- extra-source-files:
1313
14−common warnings
15− ghc-options: -Wall
14+
15+tested-with: GHC ==9.8.4 || ==9.6.6
16+
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
31+ ghc-options:
32+ -Wall -Wmissing-deriving-strategies -Wprepositive-qualified-module
33+ -Wunused-packages -Wredundant-constraints
1634
1735library
18− import: warnings
19− exposed-modules: Web.Connexpay
20− Web.Connexpay.Auth
21− Web.Connexpay.Data
22− Web.Connexpay.Init
23− Web.Connexpay.Payments
24− Web.Connexpay.Types
25− Web.Connexpay.Utils
26− default-extensions: DuplicateRecordFields
27− OverloadedLabels
28− OverloadedRecordDot
29− NoFieldSelectors
30− -- other-modules:
31− -- other-extensions:
36+ import: common
37+ exposed-modules:
38+ Web.Connexpay.Init
39+ Web.Connexpay.Payments
40+ Web.Connexpay.Types
41+ other-modules:
42+ Web.Connexpay.Auth
43+ Web.Connexpay.Http
44+ Web.Connexpay.Payments.Types
45+ Web.Connexpay.Utils
3246 build-depends: base >=4.14 && < 5.0
3347 , aeson
3448 , async
35− , bucks
3649 , bytestring
3750 , http-api-data
3851 , http-client
39− , http-client-tls
40− , mtl
41− , req
52+ , http-types
53+ , safe-exceptions
4254 , text
43− , uuid
4455 hs-source-dirs: src
45− default-language: GHC2021
4656
4757executable connexpay-tool
48− import: warnings
49− default-extensions: DuplicateRecordFields
50− OverloadedLabels
51− OverloadedRecordDot
52− NoFieldSelectors
58+ import: common
5359 build-depends: base >= 4.17
5460 , aeson
55− , async
56− , bucks
57− , bytestring
58− , http-api-data
61+ , connexpay
5962 , http-client
6063 , http-client-tls
61− , mtl
6264 , optparse-applicative
63− , req
6465 , text
65− , uuid
6666 , yaml
67− hs-source-dirs: src
68− main-is: Tool.hs
69− default-language: GHC2021
67+ hs-source-dirs: tool
68+ main-is: Main.hs
connexpay/src/Tool.hsdeleted−80
@@ -1,80 +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−
22−data Config = Config { login :: Text
23− , password :: Text
24− , host :: Text
25− , device_guid :: UUID
26− , use_tls :: Bool
27− , proxy_host :: Maybe Text
28− , proxy_port :: Maybe Word
29− } deriving Generic
30−
31−instance FromJSON Config
32−
33−data Command = AuthSale CreditCard Centi
34− | VoidSale SaleGuid
35− | CaptureSale SaleGuid
36−
37−data CmdLine = CmdLine { configPath :: FilePath
38− , operation :: Command
39− }
40−
41−cmdParser :: Parser CmdLine
42−cmdParser = CmdLine <$> strOption (short 'c' <> metavar "FILE" <> help "Configuration file path")
43− <*> subparser operation
44− where operation = command "auth" (info (AuthSale <$> cc <*> amt) (progDesc "Authorise payment"))
45− <> command "void" (info (VoidSale <$> guid) (progDesc "Void payment"))
46− <> command "capture" (info (CaptureSale <$> guid) (progDesc "Void payment"))
47− amt = argument auto (metavar "Payment amount")
48− cc = CreditCard <$> argument str mempty
49− <*> fmap pure (argument str mempty)
50− <*> argument expdate mempty
51− <*> fmap pure (argument str mempty)
52− expdate = do s <- str
53− guard (length s == 4)
54− pure (read (take 2 s), read (drop 2 s))
55− guid = argument auto (metavar "Payment UUID")
56−
57−
58−
59−writeLog :: Text -> IO ()
60−writeLog msg = Text.putStrLn ("Connexpay log: " <> msg)
61−
62−main :: IO ()
63−main = do cmdLine <- execParser (info cmdParser mempty)
64− cnf :: Config <- decodeFileThrow cmdLine.configPath
65− mgr <- fromMaybe newTlsManager
66− $ do host <- cnf.proxy_host
67− port <- cnf.proxy_port
68− let proxy = useProxy (Proxy (Text.encodeUtf8 host) (fromIntegral port))
69− s = managerSetProxy proxy defaultManagerSettings
70− return (newManager s)
71− res <- initConnexpay writeLog mgr cnf.device_guid cnf.host cnf.use_tls cnf.login cnf.password
72− case res of
73− Left err -> putStrLn ("Error: " <> show err)
74− Right cpi -> print =<< runConnexpay cpi (doThing cmdLine.operation)
75−
76−doThing :: Command -> ConnexpayM ()
77−doThing (AuthSale cc amt) = liftIO . print =<< authorisePayment cc usd Nothing
78− where usd = Money amt
79−doThing (VoidSale guid) = liftIO . print =<< voidPayment guid Nothing
80−doThing (CaptureSale guid) = liftIO . print =<< capturePayment guid
connexpay/src/Web/Connexpay.hsdeleted−11
@@ -1,11 +0,0 @@
1−module Web.Connexpay ( module Payments
2− , initConnexpay
3− , Connexpay
4− , ConnexpayM
5− , PaymentError(..)
6− , runConnexpay
7− ) where
8−
9−import Web.Connexpay.Init
10−import Web.Connexpay.Payments as Payments
11−import Web.Connexpay.Types as Export
connexpay/src/Web/Connexpay/Auth.hs+59−23
@@ -1,22 +1,31 @@
11{-# LANGUAGE OverloadedLists #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−module Web.Connexpay.Auth (authenticate) where
42
5−import Web.Connexpay.Types
3+module Web.Connexpay.Auth
4+ ( AuthReply(..)
5+ , TokenReply(..)
6+ , authenticate
7+ ) where
68
79import Control.Monad
8−import Control.Monad.Reader
910import Data.Aeson
1011import Data.Aeson.Types
1112import Data.ByteString (ByteString)
1213import Data.ByteString qualified as ByteString
14+import Data.ByteString.Lazy qualified as Lazy
15+import Data.ByteString.Lazy qualified as Lazy.ByteString
1316import Data.Text (Text)
1417import Data.Text qualified as Text
15−import Network.HTTP.Req
18+import Data.Text.Encoding qualified as Text
19+import Network.HTTP.Client qualified as HTTP
20+import Network.HTTP.Types
1621import Numeric.Natural
1722import Web.FormUrlEncoded
1823import Web.HttpApiData
1924
25+import Web.Connexpay.Http
26+import Web.Connexpay.Types
27+
28+
2029data AuthForm = AuthForm { login :: Text
2130 , password :: Text
2231 }
@@ -27,13 +36,19 @@ instance ToForm AuthForm where
2736 , ("password", toQueryParam auth.password)
2837 ]
2938
30−mkAuthForm :: Text -> Text -> ByteString
31−mkAuthForm login passwd = ByteString.toStrict (urlEncodeAsForm form)
32− where form = AuthForm login passwd
39+mkAuthForm :: Config -> ByteString
40+mkAuthForm cfg = ByteString.toStrict (urlEncodeAsForm form)
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)
3348
3449data TokenReply = TokenReply { token :: BearerToken
35− , expires_in :: Natural
36− } deriving (Show)
50+ , expiresIn :: Natural
51+ } deriving stock (Show)
3752
3853instance FromJSON TokenReply where
3954 parseJSON (Object v) = do typ <- v .: "token_type"
@@ -43,16 +58,37 @@ instance FromJSON TokenReply where
4358 <*> v .: "expires_in"
4459 parseJSON v = typeMismatch "TokenReply" v
4560
46−authenticate :: ConnexpayM (BearerToken, Natural)
47−authenticate = do login <- asks (.login)
48− password <- asks (.password)
49− host <- asks (.url)
50− tls <- asks (.useTLS)
51− let body = ReqBodyBs (mkAuthForm login password)
52− url s = s host /: "api" /: "v1" /: "token"
53− resp <-
54− if tls
55− then req POST (url https) body jsonResponse mempty
56− else req POST (url http) body jsonResponse mempty
57− let TokenReply tok ts = responseBody resp
58− pure (tok, ts)
61+authenticate :: Config -> Env -> IO AuthReply
62+authenticate config env = do
63+ let
64+ req = HTTP.defaultRequest
65+ { HTTP.method = "POST"
66+ , HTTP.host = Text.encodeUtf8 config.host
67+ , HTTP.port = if config.useTLS then 443 else 80
68+ , HTTP.secure = config.useTLS
69+ , HTTP.path = "api/v1/token"
70+ , HTTP.requestHeaders =
71+ [ ("Accept", "application/json")
72+ , ("Accept-Encoding", "gzip")
73+ ]
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+ ]
94+ pure res
connexpay/src/Web/Connexpay/Data.hsdeleted−32
@@ -1,32 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Web.Connexpay.Data ( TransactionStatus (..)
3− ) where
4−
5−import Data.Aeson
6−import Data.Aeson.Types
7−import Data.Maybe (fromMaybe)
8−import Data.Text (Text)
9−
10−-- | Transaction status in Connexpay
11−-- The list is taken from https://docs.connexpay.com/reference/search-sales
12−data TransactionStatus = TransactionApproved -- ^ Obvious
13− | TransactionDeclined -- ^ Also obvious
14− | TransactionCreatedLocal -- ^ Seems to only exist in a test environment, indicates success.
15− | TransactionCreatedProcNotReached -- ^ Communication error between Connexpay and Card Processor
16− | TransactionCreatedProcError -- ^ Processor errored out
17− | TransactionApprovedWarning -- ^ Wut 0__o FIXME: figure out what this is
18− | TransactionOther Text -- ^ In case they return something unexpected
19− deriving (Show)
20−
21−statuses :: [(Text, TransactionStatus)]
22−statuses = [ ( "Transaction - Approved", TransactionApproved )
23− , ( "Transaction - Declined", TransactionDeclined )
24− , ( "Transaction - CreatedLocal", TransactionCreatedLocal )
25− , ( "Transaction - Created - Error: Processor not reached", TransactionCreatedProcNotReached )
26− , ( "Transaction - Processor Error", TransactionCreatedProcError )
27− , ( "Transaction - Approved - Warning", TransactionApprovedWarning )
28− ]
29−
30−instance FromJSON TransactionStatus where
31− parseJSON (String s) = pure (fromMaybe (TransactionOther s) (lookup s statuses))
32− parseJSON v = typeMismatch "TransactionStatus" v
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−48
@@ -1,57 +1,48 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−module Web.Connexpay.Init where
3−
4−import Web.Connexpay.Auth
5−import Web.Connexpay.Types
6−import Web.Connexpay.Utils
1+module Web.Connexpay.Init (initConnexpay) where
72
83import Control.Concurrent
94import Control.Concurrent.Async
10−import Control.Monad.Except (catchError)
11−import Control.Monad.IO.Class
12−import Control.Monad.Reader (asks)
5+import Control.Exception.Safe
6+import Control.Monad
7+import Data.Aeson
8+import Data.Aeson.Text
139import Data.Text (Text)
10+import Data.Text qualified as Text
11+import Data.Text.Lazy qualified as Lazy.Text
1412import Network.HTTP.Client (Manager)
1513import Numeric.Natural
1614
15+import Web.Connexpay.Auth
16+import Web.Connexpay.Types
17+
18+
1719-- | Initialise Connexpay state. Log in, authenticate, and obtain bearer token.
18−initConnexpay :: (Text -> IO ()) -- ^ Logging function
19− -> Manager -- ^ HTTP client manager
20− -> DeviceGuid -- ^ Device GUID. You must obtain this from ConnexPay
21− -> Text -- ^ Connexpay host to connect with
22− -> Bool -- ^ Whether to use TLS. If unsure, say True.
23− -> Text -- ^ Login name.
24− -> Text -- ^ Password.
25− -> IO (Either PaymentError Connexpay)
26−initConnexpay logf mgr devguid url tls login password =
27− do v <- newEmptyMVar
28− let env = Connexpay { logAction = logf
29− , manager = mgr
30− , bearerToken = v
31− , refreshAsync = Nothing
32− , deviceGuid = devguid
33− , url = url
34− , useTLS = tls
35− , login = login
36− , password = password
37− }
38− runConnexpay env $ do
39− (tok, ts) <- authenticate
40− a <- liftIO $ do logf "Connexpay authentication success"
41− putMVar v tok
42− async (runConnexpay_ env $ updateToken ts)
43− pure (env { refreshAsync = Just a })
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
4445
45−updateToken :: Natural -> ConnexpayM ()
46−updateToken w = liftIO (threadDelay w') >> upd
47− where w' = fromIntegral w * 1000000
48− upd = do (tok, ts) <- authenticate
49− logf <- asks (.logAction)
50− tokVar <- asks (.bearerToken)
51− liftIO (putMVar tokVar tok)
52− liftIO (logf "Connexpay token update success")
53− updateToken (ts - 5)
54− `catchError` \err -> do
55− logf <- asks (.logAction)
56− liftIO (logf ("Connexpay token update failure: " <> tshow err))
57− updateToken 5
46+doLog :: Env -> Text -> IO ()
47+doLog env msg = env.logAction $ Lazy.Text.toStrict $ encodeToLazyText @Object $
48+ "connexpay" .= ("auth" .= msg :: Object)
connexpay/src/Web/Connexpay/Payments.hs+66−119
@@ -1,134 +1,81 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE UndecidableInstances #-}
4−module Web.Connexpay.Payments ( CreditCard(..)
5− , AuthResponse(..)
6− , authorisePayment
7− , voidPayment
8− , capturePayment
9− , cancelPayment
10− ) where
1+module Web.Connexpay.Payments
2+ ( AuthRequest(..)
3+ , USD(..)
4+ , CreditCard(..)
5+ , ExpirationDate(..)
6+ , Customer(..)
7+ , RiskData(..)
8+ , AuthorizeResult(..)
9+ , AuthResponse(..)
10+ , TransactionStatus(..)
11+ , authorisePayment
12+ , VoidRequest(..)
13+ , voidPayment
14+ , CaptureResponse(..)
15+ , Sale(..)
16+ , capturePayment
17+ , cancelPayment
18+ , returnPayment
19+ ) where
1120
12−import Control.Monad (void)
13−import Control.Monad.Reader (asks)
14−import Control.Monad.Writer.Strict
1521import Data.Aeson
16−import Data.Aeson.Types (Pair, typeMismatch)
17−import Data.Int (Int32)
18−import Data.Money
19−import Data.Proxy
20−import Data.Text (Text)
21−import Data.Text qualified as Text
22−import Data.Text.Encoding qualified as Text
23−import GHC.TypeError as TypeError
24−import Network.HTTP.Req
2522
26−import Web.Connexpay.Data
23+import Web.Connexpay.Http
24+import Web.Connexpay.Payments.Types
2725import Web.Connexpay.Types
28−import Web.Connexpay.Utils
2926
30−-- | Credit card info
31−-- No 'Show' instance should be made for this type
32−-- in order to avoid sensitive data leaks.
33−data CreditCard = CreditCard { number :: Text -- ^ Credit card number, as 'Text'.
34− , cardholder :: Maybe Text -- ^ Cardholder name, optional.
35− , expiration :: (Word, Word) -- ^ Expiration date (month,year).
36− , cvv :: Maybe Text -- ^ CVC/CVV code.
37− }
38−
39−type ShowError = TypeError.Text "CreditCard must not be shown in order to avoid leaking sensitive data"
40−
41−instance TypeError ShowError => Show CreditCard where
42− show = error "UNREACHABLE"
43−
44−instance ToJSON CreditCard where
45− toJSON cc = object
46− $ execWriter
47− $ do tell ["CardNumber" .= cc.number]
48− whenJust cc.cardholder $ \name ->
49− tell ["CardHolderName" .= name]
50− whenJust cc.cvv $ \cvv ->
51− tell ["Cvv2" .= cvv]
52− let expDate = padDate (tshow (snd cc.expiration)) <> padDate (tshow (fst cc.expiration))
53− tell ["ExpirationDate" .= expDate]
54−
55−padDate :: Text -> Text
56−padDate t | Text.length t == 1 = "0" <> t
57− | otherwise = t
58−
59−sendRequest' :: HttpResponse resp => Proxy resp -> Text -> [Pair] -> ConnexpayM resp
60−sendRequest' resp endpoint body =
61− do tok <- bearerToken
62− host <- asks (.url)
63− tls <- asks (.useTLS)
64− let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)
65− url s = s host /: "api" /: "v1" /: endpoint
66− jbody <- ReqBodyJson . object <$> addGuid body
67− if tls
68− then req POST (url https) jbody resp auth
69− else req POST (url http) jbody resp auth
70− where addGuid b = do guid <- asks (.deviceGuid)
71− return (b <> [ "DeviceGuid" .= show guid ])
72−
73−sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a)
74−sendRequestJson = sendRequest' jsonResponse
75−
76−sendRequest_ :: Text -> [Pair] -> ConnexpayM ()
77−sendRequest_ ep = void . sendRequest' ignoreResponse ep
78−
79−data AuthResponse = AuthResponse { paymentGuid :: SaleGuid
80− , status :: TransactionStatus
81− , processorStatusCode :: Maybe Text
82− , processorMessage :: Maybe Text
83− } deriving (Show)
84−
85−instance FromJSON AuthResponse where
86− parseJSON (Object o) = AuthResponse <$> o .: "guid"
87− <*> o .: "status"
88− <*> o .:? "processorStatusCode"
89− <*> o .:? "processorResponseMessage"
90− parseJSON v = typeMismatch "AuthReponse" v
9127
9228-- | Authorise a credit card payment.
93−authorisePayment :: CreditCard -- ^ Credit card details (see 'CreditCard')
94− -> Money USD -- ^ Amount to charge, USD
95− -> Maybe Text -- ^ Merchant description that will appear in a customer's statement.
96− -> ConnexpayM AuthResponse
97−authorisePayment cc amt vendor = do resp <- sendRequestJson "authonlys" body
98− pure (responseBody resp)
99− where body = execWriter $
100− do tell [ "Card" .= cc ]
101− tell ["Amount" .= getAmount amt ]
102− whenJust vendor $ \v ->
103− tell [ "StatementDescription" .= v ]
29+authorisePayment
30+ :: Connexpay -> Env -> AuthRequest -> IO (Response AuthError AuthorizeResult)
31+authorisePayment connexpay env raw =
32+ bimapResponse (guessErrorType guessAuthError) postProcessAuthResponse <$>
33+ doRequest connexpay env "authonlys" RequestBody
34+ { raw
35+ , logMasker = maskAuthRequest
36+ }
10437
10538-- | Void payment
106−voidPayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
107− -> Maybe (Money USD) -- ^ Optionally, you may only void a partial sum, with the rest being subsequently charged.
108− -> ConnexpayM ()
109−voidPayment pid amt = sendRequest_ "void" body
110− where body = execWriter $
111− do tell [ "AuthOnlyGuid" .= show pid ]
112− whenJust amt $ \m ->
113− tell [ "Amount" .= getAmount m ]
114−
115−-- | Internal data type for Capture requests.
116−data CPTransaction = CPTransaction { expectedPayments :: Int32 }
117−
118−instance ToJSON CPTransaction where
119− toJSON t = object [ "ExpectedPayments" .= t.expectedPayments ]
39+voidPayment :: Connexpay -> Env -> VoidRequest -> IO (Response () ())
40+voidPayment connexpay env raw = doRequest_ connexpay env "void" RequestBody
41+ { raw
42+ , logMasker = id
43+ }
12044
12145-- | Capture payment, previously authorised through 'authorisePayment'.
122−capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
123− -> ConnexpayM ()
124−capturePayment pid = sendRequest_ "Captures" body
125− where body = [ "AuthOnlyGuid" .= show pid
126− , "ConnexPayTransaction" .= CPTransaction 1 ]
46+capturePayment :: Connexpay
47+ -> Env
48+ -> AuthOnlyGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
49+ -> IO (Response () CaptureResponse)
50+capturePayment connexpay env pid = doRequest connexpay env "Captures" RequestBody
51+ { raw = object
52+ [ "AuthOnlyGuid" .= pid
53+ , "ConnexPayTransaction" .= CPTransaction 1
54+ ]
55+ , logMasker = id
56+ }
12757
12858-- | Cancel voided or captured payment.
12959-- In case of an authorised-only payment, voiding is performed.
13060-- Otherwise, a payment goes through a refund process.
131−cancelPayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
132− -> ConnexpayM ()
133−cancelPayment pid = sendRequest_ "cancel" body
134− where body = [ "SaleGuid" .= show pid ]
61+cancelPayment :: Connexpay
62+ -> Env
63+ -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
64+ -> IO (Response () ())
65+cancelPayment connexpay env pid = doRequest_ connexpay env "cancel" RequestBody
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−58
@@ -1,62 +1,86 @@
1−{-# LANGUAGE OverloadedStrings #-}
21module Web.Connexpay.Types where
32
4−import Web.Connexpay.Utils
5−
63import Control.Concurrent.Async
7−import Control.Concurrent.MVar (MVar, readMVar)
8−import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError)
9−import Control.Monad.IO.Class
10−import Control.Monad.Reader
4+import Control.Concurrent.MVar (MVar)
5+import Data.Aeson hiding (Error)
6+import Data.Bifunctor
7+import Data.ByteString.Lazy qualified as Lazy (ByteString)
118import Data.Text (Text)
12−import Data.Text qualified as Text
13−import Data.UUID (UUID)
14−import Network.HTTP.Client (Manager, HttpException(..), HttpExceptionContent)
15−import Network.HTTP.Req
16−
17−type BearerToken = Text
18−type DeviceGuid = UUID
19−type SaleGuid = UUID
20−
21−data Connexpay = Connexpay { logAction :: Text -> IO ()
22− , manager :: Manager
23− , bearerToken :: MVar BearerToken
24− , refreshAsync :: Maybe (Async ())
25− , deviceGuid :: DeviceGuid
26− , url :: Text
27− , useTLS :: Bool
28− , login :: Text
29− , password :: Text
30− }
31−
32−data PaymentError = AuthFailure
33− | ParseError String
34− | InvalidUrl String String
35− | HttpFailure HttpExceptionContent
36− deriving (Show)
37−
38−
39−newtype ConnexpayM a = ConnexpayM (ReaderT Connexpay (ExceptT PaymentError IO) a)
40− deriving (Functor, Applicative, Monad, MonadIO, MonadReader Connexpay, MonadError PaymentError)
41−
42−instance MonadHttp ConnexpayM where
43− handleHttpException (JsonHttpException e) = throwError (ParseError e)
44− handleHttpException (VanillaHttpException (InvalidUrlException url why)) = throwError (InvalidUrl url why)
45− handleHttpException (VanillaHttpException (HttpExceptionRequest _ c)) = throwError (HttpFailure c)
46−
47− getHttpConfig = do mgr <- asks (.manager)
48− pure (defaultHttpConfig { httpConfigAltManager = Just mgr })
49−
50−
51−runConnexpay :: Connexpay -> ConnexpayM a -> IO (Either PaymentError a)
52−runConnexpay cp (ConnexpayM a) = runExceptT (runReaderT a cp)
53−
54−runConnexpay_ :: Connexpay -> ConnexpayM a -> IO ()
55−runConnexpay_ cp m =
56− do r <- runConnexpay cp m
57− whenLeft r $ \err ->
58− cp.logAction ("Uncaught Connexpay error: " <> Text.pack (show err))
59−
60−bearerToken :: ConnexpayM BearerToken
61−bearerToken = do v <- asks (.bearerToken)
62− liftIO (readMVar v)
9+import Network.HTTP.Client (Manager)
10+
11+
12+newtype BearerToken = BearerToken
13+ { unBearerToken :: Text
14+ } deriving newtype (Show, FromJSON, ToJSON)
15+
16+newtype AuthOnlyGuid = AuthOnlyGuid
17+ { unAuthOnlyGuid :: Text
18+ } deriving newtype (Show, FromJSON, ToJSON)
19+
20+newtype SaleGuid = SaleGuid
21+ { unSaleGuid :: Text
22+ } deriving newtype (Show, FromJSON, ToJSON)
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
40+ , bearerToken :: MVar (Maybe BearerToken)
41+ , refreshAsync :: Async ()
42+ }
43+
44+data Env = Env
45+ { logAction :: Logger
46+ , manager :: Manager
47+ }
48+
49+data Response e a
50+ = ResponseSuccess a
51+ | ResponseError (Error e)
52+ -- ^ Response structured error (422 status code) is received
53+ | BadRequest Lazy.ByteString
54+ | MissingOrExpiredToken
55+ -- ^ Most likely invalid credentials/URL are passed during initialization.
56+ -- No request is even sent to Connexpay.
57+ deriving stock (Show, Functor)
58+
59+instance Bifunctor Response where
60+ bimap f = bimapResponse (fmap f)
61+
62+bimapResponse
63+ :: (Error e -> Error e') -> (a -> b) -> Response e a -> Response e' b
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 @@
11module Web.Connexpay.Utils where
22
3+import Data.Aeson.Types
4+import Data.Char
35import Data.Text (Text)
46import Data.Text qualified as Text
57
6−whenLeft :: Monad m => Either a b -> (a -> m ()) -> m ()
7−whenLeft (Left l) f = f l
8−whenLeft (Right _) _ = pure ()
98
10−whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
11−whenJust (Just x) f = f x
12−whenJust Nothing _ = pure ()
9+starWords :: Text -> Text
10+starWords = Text.unwords . map toStars . Text.words
11+ where toStars w = Text.replicate (Text.length w) "*"
1312
14−tshow :: Show a => a -> Text
15−tshow = Text.pack . show
13+capitalize :: String -> String
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+4−6
@@ -1,12 +1,10 @@
1−resolver: lts-22.13
1+resolver: lts-22.36
22
33packages:
4−- .
5−
6−extra-deps:
7− - git: https://github.com/typeable/bucks.git
8− commit: 9e378b675fe7fb88d5ddb3af068d82eb441f343c
4+- connexpay
5+- connexpay-optparse
96
107nix:
118 packages: [zlib]
9+
1210local-bin-path: bin