git.iko.soy/typeable/connexpay
on master help sign in
swap
92e8e5238 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/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 @@
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-client-tls
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− , mtl
62 , optparse-applicative
64 , optparse-applicative
63− , req
64 , text
65 , text
65− , uuid
66 , yaml
66 , yaml
67− hs-source-dirs: src
67+ hs-source-dirs: tool
68− main-is: Tool.hs
68+ main-is: Main.hs
69− default-language: GHC2021
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 @@
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−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
1+module Web.Connexpay.Init (initConnexpay) where
3−
4−import Web.Connexpay.Auth
5−import Web.Connexpay.Types
6−import Web.Connexpay.Utils
7
2
8import Control.Concurrent
3import Control.Concurrent
9import Control.Concurrent.Async
4import Control.Concurrent.Async
10−import Control.Monad.Except (catchError)
5+import Control.Exception.Safe
11−import Control.Monad.IO.Class
6+import Control.Monad
12−import Control.Monad.Reader (asks)
7+import Data.Aeson
8+import Data.Aeson.Text
13import Data.Text (Text)
9import Data.Text (Text)
10+import Data.Text qualified as Text
11+import Data.Text.Lazy qualified as Lazy.Text
14import Network.HTTP.Client (Manager)
12import Network.HTTP.Client (Manager)
15import Numeric.Natural
13import Numeric.Natural
16
14
15+import Web.Connexpay.Auth
16+import Web.Connexpay.Types
17+
18+
17-- | Initialise Connexpay state. Log in, authenticate, and obtain bearer token.
19-- | Initialise Connexpay state. Log in, authenticate, and obtain bearer token.
18−initConnexpay :: (Text -> IO ()) -- ^ Logging function
20+initConnexpay
21+ :: Logger
19− -> Manager -- ^ HTTP client manager
22+ -> Manager
20− -> DeviceGuid -- ^ Device GUID. You must obtain this from ConnexPay
23+ -> Config
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)
24+ -> IO Connexpay
26−initConnexpay logf mgr devguid url tls login password =
25+initConnexpay logAction manager config = do
27− do v <- newEmptyMVar
28− let env = Connexpay { logAction = logf
29− , manager = mgr
30− , bearerToken = v
26+ bearerToken <- newMVar Nothing
31− , refreshAsync = Nothing
27+ let env = Env{..}
32− , deviceGuid = devguid
28+ refreshAsync <- async $ forever $
33− , url = url
29+ updateToken config env bearerToken 0 `catchAny` \err -> do
34− , useTLS = tls
30+ doLog env $
35− , login = login
31+ "Connexpay token update exception: " <> Text.pack (displayException err)
36− , password = password
32+ threadDelay 5_000_000
37− }
33+ pure Connexpay{..}
38− runConnexpay env $ do
34+
39− (tok, ts) <- authenticate
35+updateToken :: Config -> Env -> MVar (Maybe BearerToken) -> Natural -> IO ()
40− a <- liftIO $ do logf "Connexpay authentication success"
36+updateToken config env tokVar w =
41− putMVar v tok
37+ threadDelay (fromIntegral w * 1_000_000) >> upd
42− async (runConnexpay_ env $ updateToken ts)
38+ where
43− 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
44
45
45−updateToken :: Natural -> ConnexpayM ()
46+doLog :: Env -> Text -> IO ()
46−updateToken w = liftIO (threadDelay w') >> upd
47+doLog env msg = env.logAction $ Lazy.Text.toStrict $ encodeToLazyText @Object $
47− where w' = fromIntegral w * 1000000
48+ "connexpay" .= ("auth" .= msg :: Object)
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
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(..)
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 (void)
13−import Control.Monad.Reader (asks)
14−import Control.Monad.Writer.Strict
15import Data.Aeson
21import 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
25
22
26−import Web.Connexpay.Data
23+import Web.Connexpay.Http
24+import Web.Connexpay.Payments.Types
27import Web.Connexpay.Types
25import Web.Connexpay.Types
28−import Web.Connexpay.Utils
29
26
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
91
27
92-- | Authorise a credit card payment.
28-- | Authorise a credit card payment.
93−authorisePayment :: CreditCard -- ^ Credit card details (see 'CreditCard')
29+authorisePayment
94− -> Money USD -- ^ Amount to charge, USD
30+ :: Connexpay -> Env -> AuthRequest -> IO (Response AuthError AuthorizeResult)
95− -> Maybe Text -- ^ Merchant description that will appear in a customer's statement.
31+authorisePayment connexpay env raw =
96− -> ConnexpayM AuthResponse
32+ bimapResponse (guessErrorType guessAuthError) postProcessAuthResponse <$>
97−authorisePayment cc amt vendor = do resp <- sendRequestJson "authonlys" body
33+ doRequest connexpay env "authonlys" RequestBody
98− pure (responseBody resp)
34+ { raw
99− where body = execWriter $
35+ , logMasker = maskAuthRequest
100− do tell [ "Card" .= cc ]
36+ }
101− tell ["Amount" .= getAmount amt ]
102− whenJust vendor $ \v ->
103− tell [ "StatementDescription" .= v ]
104
37
105-- | Void payment
38-- | Void payment
106−voidPayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
39+voidPayment :: Connexpay -> Env -> VoidRequest -> IO (Response () ())
107− -> 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
108− -> ConnexpayM ()
41+ { raw
109−voidPayment pid amt = sendRequest_ "void" body
42+ , logMasker = id
110− where body = execWriter $
43+ }
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 ]
120
44
121-- | Capture payment, previously authorised through 'authorisePayment'.
45-- | Capture payment, previously authorised through 'authorisePayment'.
46+capturePayment :: Connexpay
47+ -> Env
122−capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
48+ -> AuthOnlyGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
123− -> ConnexpayM ()
49+ -> IO (Response () CaptureResponse)
124−capturePayment pid = sendRequest_ "Captures" body
50+capturePayment connexpay env pid = doRequest connexpay env "Captures" RequestBody
51+ { raw = object
125− where body = [ "AuthOnlyGuid" .= show pid
52+ [ "AuthOnlyGuid" .= pid
126− , "ConnexPayTransaction" .= CPTransaction 1 ]
53+ , "ConnexPayTransaction" .= CPTransaction 1
54+ ]
55+ , logMasker = id
56+ }
127
57
128-- | Cancel voided or captured payment.
58-- | Cancel voided or captured payment.
129-- In case of an authorised-only payment, voiding is performed.
59-- In case of an authorised-only payment, voiding is performed.
130-- Otherwise, a payment goes through a refund process.
60-- Otherwise, a payment goes through a refund process.
61+cancelPayment :: Connexpay
62+ -> Env
131−cancelPayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
63+ -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
132− -> ConnexpayM ()
64+ -> IO (Response () ())
133−cancelPayment pid = sendRequest_ "cancel" body
65+cancelPayment connexpay env pid = doRequest_ connexpay env "cancel" RequestBody
134− 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−58
@@ -1,62 +1,86 @@
1−{-# LANGUAGE OverloadedStrings #-}
2module Web.Connexpay.Types where
1module Web.Connexpay.Types where
3
2
4−import Web.Connexpay.Utils
5−
6import Control.Concurrent.Async
3import Control.Concurrent.Async
7−import Control.Concurrent.MVar (MVar, readMVar)
4+import Control.Concurrent.MVar (MVar)
8−import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError)
5+import Data.Aeson hiding (Error)
9−import Control.Monad.IO.Class
6+import Data.Bifunctor
10−import Control.Monad.Reader
7+import Data.ByteString.Lazy qualified as Lazy (ByteString)
11import Data.Text (Text)
8import Data.Text (Text)
12−import Data.Text qualified as Text
13−import Data.UUID (UUID)
14−import Network.HTTP.Client (Manager, HttpException(..), HttpExceptionContent)
9+import Network.HTTP.Client (Manager)
15−import Network.HTTP.Req
10+
16−
11+
17−type BearerToken = Text
12+newtype BearerToken = BearerToken
18−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+
19−type SaleGuid = UUID
20+newtype SaleGuid = SaleGuid
20−
21+ { unSaleGuid :: Text
21−data Connexpay = Connexpay { logAction :: Text -> IO ()
22+ } deriving newtype (Show, FromJSON, ToJSON)
22− , manager :: Manager
23+
23− , bearerToken :: MVar BearerToken
24+newtype CaptureGuid = CaptureGuid
24− , 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
25− , deviceGuid :: DeviceGuid
34+ , deviceGuid :: Text
26− , url :: Text
27− , useTLS :: Bool
35+ , useTLS :: Bool
28− , login :: Text
29− , password :: Text
30− }
36+ }
31−
37+
32−data PaymentError = AuthFailure
38+data Connexpay = Connexpay
33− | ParseError String
39+ { config :: Config
34− | InvalidUrl String String
40+ , bearerToken :: MVar (Maybe BearerToken)
35− | HttpFailure HttpExceptionContent
41+ , refreshAsync :: Async ()
36− deriving (Show)
42+ }
37−
43+
38−
44+data Env = Env
39−newtype ConnexpayM a = ConnexpayM (ReaderT Connexpay (ExceptT PaymentError IO) a)
45+ { logAction :: Logger
40− deriving (Functor, Applicative, Monad, MonadIO, MonadReader Connexpay, MonadError PaymentError)
46+ , manager :: Manager
41−
47+ }
42−instance MonadHttp ConnexpayM where
48+
43− handleHttpException (JsonHttpException e) = throwError (ParseError e)
49+data Response e a
44− handleHttpException (VanillaHttpException (InvalidUrlException url why)) = throwError (InvalidUrl url why)
50+ = ResponseSuccess a
45− handleHttpException (VanillaHttpException (HttpExceptionRequest _ c)) = throwError (HttpFailure c)
51+ | ResponseError (Error e)
46−
52+ -- ^ Response structured error (422 status code) is received
47− getHttpConfig = do mgr <- asks (.manager)
53+ | BadRequest Lazy.ByteString
48− pure (defaultHttpConfig { httpConfigAltManager = Just mgr })
54+ | MissingOrExpiredToken
49−
55+ -- ^ Most likely invalid credentials/URL are passed during initialization.
50−
56+ -- No request is even sent to Connexpay.
51−runConnexpay :: Connexpay -> ConnexpayM a -> IO (Either PaymentError a)
57+ deriving stock (Show, Functor)
52−runConnexpay cp (ConnexpayM a) = runExceptT (runReaderT a cp)
58+
53−
59+instance Bifunctor Response where
54−runConnexpay_ :: Connexpay -> ConnexpayM a -> IO ()
60+ bimap f = bimapResponse (fmap f)
55−runConnexpay_ cp m =
61+
56− do r <- runConnexpay cp m
62+bimapResponse
57− whenLeft r $ \err ->
63+ :: (Error e -> Error e') -> (a -> b) -> Response e a -> Response e' b
58− cp.logAction ("Uncaught Connexpay error: " <> Text.pack (show err))
64+bimapResponse f g = \case
59−
65+ ResponseSuccess a -> ResponseSuccess (g a)
60−bearerToken :: ConnexpayM BearerToken
66+ ResponseError e -> ResponseError (f e)
61−bearerToken = do v <- asks (.bearerToken)
67+ BadRequest body -> BadRequest body
62− liftIO (readMVar v)
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+4−6
@@ -1,12 +1,10 @@
1−resolver: lts-22.13
1+resolver: lts-22.36
2
2
3packages:
3packages:
4−- .
4+- connexpay
5−
5+- connexpay-optparse
6−extra-deps:
7− - git: https://github.com/typeable/bucks.git
8− commit: 9e378b675fe7fb88d5ddb3af068d82eb441f343c
9
6
10nix:
7nix:
11 packages: [zlib]
8 packages: [zlib]
9+
12local-bin-path: bin
10local-bin-path: bin