git.iko.soy/typeable/connexpay
on 81ee6ff help sign in
92e8e52
swap
0 ahead, 38 behind
23 files changed+425−1339
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+40−39 connexpay/src/Tool.hs+80 connexpay/src/Web/Connexpay.hs+11 connexpay/src/Web/Connexpay/Auth.hs+23−59 connexpay/src/Web/Connexpay/Data.hs+32 connexpay/src/Web/Connexpay/Http.hs−128 connexpay/src/Web/Connexpay/Init.hs+48−39 connexpay/src/Web/Connexpay/Payments.hs+119−66 connexpay/src/Web/Connexpay/Payments/Types.hs−236 connexpay/src/Web/Connexpay/Types.hs+58−82 connexpay/src/Web/Connexpay/Utils.hs+8−15 connexpay/tool/Main.hs−119 stack.yaml+6−4
.github/workflows/haskell-ci.ymldeleted−215
@@ -1,215 +0,0 @@
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
.gitignoredeleted−31
@@ -1,31 +0,0 @@
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,33 +28,6 @@ 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−
5831* Links
5932
6033Credit card sales API: https://docs.connexpay.com/reference/credit-card-sales
cabal.haskell-cideleted−2
@@ -1,2 +0,0 @@
1−branches: master
2−local-ghc-options: -Werror
cabal.projectdeleted−5
@@ -1,5 +0,0 @@
1−with-compiler: ghc-9.6.6
2−
3−packages:
4− connexpay/
5− connexpay-optparse/
cabal.project.freezedeleted−170
@@ -1,170 +0,0 @@
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/LICENSEdeleted−20
@@ -1,20 +0,0 @@
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.cabaldeleted−42
@@ -1,42 +0,0 @@
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.hsdeleted−19
@@ -1,19 +0,0 @@
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/LICENSEdeleted−21
@@ -1,21 +0,0 @@
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+40−39
@@ -1,68 +1,69 @@
11cabal-version: 3.0
22name: connexpay
3−description: Interacting with Connexpay API
43version: 0.1
54synopsis: ConnexPay library for Haskell
6−homepage: https://github.com/typeable/connexpay
7−license: MIT
5+homepage: https://github.com/downtowntravel/connexpay
6+license: NONE
87author: Nick
98maintainer: nick@typeable.io
109copyright: Typeable.io
1110category: Web
1211build-type: Simple
12+-- extra-source-files:
1313
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
14+common warnings
15+ ghc-options: -Wall
3416
3517library
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
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:
4632 build-depends: base >=4.14 && < 5.0
4733 , aeson
4834 , async
35+ , bucks
4936 , bytestring
5037 , http-api-data
5138 , http-client
52− , http-types
53− , safe-exceptions
39+ , http-client-tls
40+ , mtl
41+ , req
5442 , text
43+ , uuid
5544 hs-source-dirs: src
45+ default-language: GHC2021
5646
5747executable connexpay-tool
58− import: common
48+ import: warnings
49+ default-extensions: DuplicateRecordFields
50+ OverloadedLabels
51+ OverloadedRecordDot
52+ NoFieldSelectors
5953 build-depends: base >= 4.17
6054 , aeson
61− , connexpay
55+ , async
56+ , bucks
57+ , bytestring
58+ , http-api-data
6259 , http-client
6360 , http-client-tls
61+ , mtl
6462 , optparse-applicative
63+ , req
6564 , text
65+ , uuid
6666 , yaml
67− hs-source-dirs: tool
68− main-is: Main.hs
67+ hs-source-dirs: src
68+ main-is: Tool.hs
69+ default-language: GHC2021
connexpay/src/Tool.hsnew file+80
@@ -0,0 +1,80 @@
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.hsnew file+11
@@ -0,0 +1,11 @@
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+23−59
@@ -1,31 +1,22 @@
11{-# LANGUAGE OverloadedLists #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Web.Connexpay.Auth (authenticate) where
24
3−module Web.Connexpay.Auth
4− ( AuthReply(..)
5− , TokenReply(..)
6− , authenticate
7− ) where
5+import Web.Connexpay.Types
86
97import Control.Monad
8+import Control.Monad.Reader
109import Data.Aeson
1110import Data.Aeson.Types
1211import Data.ByteString (ByteString)
1312import Data.ByteString qualified as ByteString
14−import Data.ByteString.Lazy qualified as Lazy
15−import Data.ByteString.Lazy qualified as Lazy.ByteString
1613import Data.Text (Text)
1714import Data.Text qualified as Text
18−import Data.Text.Encoding qualified as Text
19−import Network.HTTP.Client qualified as HTTP
20−import Network.HTTP.Types
15+import Network.HTTP.Req
2116import Numeric.Natural
2217import Web.FormUrlEncoded
2318import Web.HttpApiData
2419
25−import Web.Connexpay.Http
26−import Web.Connexpay.Types
27−
28−
2920data AuthForm = AuthForm { login :: Text
3021 , password :: Text
3122 }
@@ -36,19 +27,13 @@ instance ToForm AuthForm where
3627 , ("password", toQueryParam auth.password)
3728 ]
3829
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)
30+mkAuthForm :: Text -> Text -> ByteString
31+mkAuthForm login passwd = ByteString.toStrict (urlEncodeAsForm form)
32+ where form = AuthForm login passwd
4833
4934data TokenReply = TokenReply { token :: BearerToken
50− , expiresIn :: Natural
51− } deriving stock (Show)
35+ , expires_in :: Natural
36+ } deriving (Show)
5237
5338instance FromJSON TokenReply where
5439 parseJSON (Object v) = do typ <- v .: "token_type"
@@ -58,37 +43,16 @@ instance FromJSON TokenReply where
5843 <*> v .: "expires_in"
5944 parseJSON v = typeMismatch "TokenReply" v
6045
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
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)
connexpay/src/Web/Connexpay/Data.hsnew file+32
@@ -0,0 +1,32 @@
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.hsdeleted−128
@@ -1,128 +0,0 @@
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+48−39
@@ -1,48 +1,57 @@
1−module Web.Connexpay.Init (initConnexpay) where
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
27
38import Control.Concurrent
49import Control.Concurrent.Async
5−import Control.Exception.Safe
6−import Control.Monad
7−import Data.Aeson
8−import Data.Aeson.Text
10+import Control.Monad.Except (catchError)
11+import Control.Monad.IO.Class
12+import Control.Monad.Reader (asks)
913import Data.Text (Text)
10−import Data.Text qualified as Text
11−import Data.Text.Lazy qualified as Lazy.Text
1214import Network.HTTP.Client (Manager)
1315import Numeric.Natural
1416
15−import Web.Connexpay.Auth
16−import Web.Connexpay.Types
17−
18−
1917-- | Initialise Connexpay state. Log in, authenticate, and obtain bearer token.
20−initConnexpay
21− :: Logger
22− -> Manager
23− -> Config
24− -> IO Connexpay
25−initConnexpay logAction manager config = do
26− bearerToken <- newMVar Nothing
27− let env = Env{..}
28− refreshAsync <- async $ forever $
29− updateToken config env bearerToken 0 `catchAny` \err -> do
30− doLog env $
31− "Connexpay token update exception: " <> Text.pack (displayException err)
32− threadDelay 5_000_000
33− pure Connexpay{..}
34−
35−updateToken :: Config -> Env -> MVar (Maybe BearerToken) -> Natural -> IO ()
36−updateToken config env tokVar w =
37− threadDelay (fromIntegral w * 1_000_000) >> upd
38− where
39− upd = authenticate config env >>= \case
40− Authorized tok -> do
41− _ <- swapMVar tokVar (Just tok.token)
42− updateToken config env tokVar (tok.expiresIn - 5)
43− _ -> do
44− updateToken config env tokVar 5
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 })
4544
46−doLog :: Env -> Text -> IO ()
47−doLog env msg = env.logAction $ Lazy.Text.toStrict $ encodeToLazyText @Object $
48− "connexpay" .= ("auth" .= msg :: Object)
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
connexpay/src/Web/Connexpay/Payments.hs+119−66
@@ -1,81 +1,134 @@
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
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
2011
12+import Control.Monad (void)
13+import Control.Monad.Reader (asks)
14+import Control.Monad.Writer.Strict
2115import 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
2225
23−import Web.Connexpay.Http
24−import Web.Connexpay.Payments.Types
26+import Web.Connexpay.Data
2527import Web.Connexpay.Types
28+import Web.Connexpay.Utils
2629
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
2791
2892-- | Authorise a credit card payment.
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− }
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 ]
37104
38105-- | Void payment
39−voidPayment :: Connexpay -> Env -> VoidRequest -> IO (Response () ())
40−voidPayment connexpay env raw = doRequest_ connexpay env "void" RequestBody
41− { raw
42− , logMasker = id
43− }
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 ]
44120
45121-- | Capture payment, previously authorised through 'authorisePayment'.
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− }
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 ]
57127
58128-- | Cancel voided or captured payment.
59129-- In case of an authorised-only payment, voiding is performed.
60130-- Otherwise, a payment goes through a refund process.
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− }
131+cancelPayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
132+ -> ConnexpayM ()
133+cancelPayment pid = sendRequest_ "cancel" body
134+ where body = [ "SaleGuid" .= show pid ]
connexpay/src/Web/Connexpay/Payments/Types.hsdeleted−236
@@ -1,236 +0,0 @@
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+58−82
@@ -1,86 +1,62 @@
1+{-# LANGUAGE OverloadedStrings #-}
12module Web.Connexpay.Types where
23
4+import Web.Connexpay.Utils
5+
36import Control.Concurrent.Async
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)
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
811import Data.Text (Text)
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− }
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)
connexpay/src/Web/Connexpay/Utils.hs+8−15
@@ -1,22 +1,15 @@
11module Web.Connexpay.Utils where
22
3−import Data.Aeson.Types
4−import Data.Char
53import Data.Text (Text)
64import Data.Text qualified as Text
75
6+whenLeft :: Monad m => Either a b -> (a -> m ()) -> m ()
7+whenLeft (Left l) f = f l
8+whenLeft (Right _) _ = pure ()
89
9−starWords :: Text -> Text
10−starWords = Text.unwords . map toStars . Text.words
11− where toStars w = Text.replicate (Text.length w) "*"
10+whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
11+whenJust (Just x) f = f x
12+whenJust Nothing _ = pure ()
1213
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− }
14+tshow :: Show a => a -> Text
15+tshow = Text.pack . show
connexpay/tool/Main.hsdeleted−119
@@ -1,119 +0,0 @@
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+6−4
@@ -1,10 +1,12 @@
1−resolver: lts-22.36
1+resolver: lts-22.13
22
33packages:
4−- connexpay
5−- connexpay-optparse
4+- .
5+
6+extra-deps:
7+ - git: https://github.com/typeable/bucks.git
8+ commit: 9e378b675fe7fb88d5ddb3af068d82eb441f343c
69
710nix:
811 packages: [zlib]
9−
1012local-bin-path: bin