git.iko.soy/typeable/connexpay
on d17fb07 help sign in
92e8e52
swap
0 ahead, 11 behind
.github/workflows/haskell-ci.ymldeleted−215
since splitsnapshots
unifiedsplit
@@ -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
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/connexpay-optparse.cabal+5−23
@@ -1,6 +1,5 @@
1cabal-version: 3.0
1cabal-version: 3.0
2name: connexpay-optparse
2name: connexpay-optparse
3−description: Parsing CLI arguments for connexpay
4version: 0.1
3version: 0.1
5synopsis: Optparse Applicative combinators for Connexpay
4synopsis: Optparse Applicative combinators for Connexpay
6license: MIT
5license: MIT
@@ -11,32 +10,15 @@ copyright: Antorica LLC
11category: System
10category: System
12build-type: Simple
11build-type: Simple
13
12
14−
15−tested-with: GHC ==9.8.4 || ==9.6.6
16−
17−common common
13+common warnings
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:
14+ ghc-options: -Wall
32− -Wall -Wmissing-deriving-strategies -Wprepositive-qualified-module
33− -Wunused-packages -Wredundant-constraints
34
15
35library
16library
36− import: common
17+ import: warnings
37 exposed-modules: Web.Connexpay.Cli
18 exposed-modules: Web.Connexpay.Cli
38 build-depends: base >=4.14 && < 5.0
19 build-depends: base >=4.14 && < 5.0
39− , connexpay
40 , optparse-applicative
20 , optparse-applicative
21+ , text
22+ , uuid
41 hs-source-dirs: src
23 hs-source-dirs: src
42 default-language: Haskell2010
24 default-language: Haskell2010
connexpay-optparse/src/Web/Connexpay/Cli.hs+13−14
@@ -1,19 +1,18 @@
1−{-# LANGUAGE ApplicativeDo #-}
2−
3module Web.Connexpay.Cli where
1module Web.Connexpay.Cli where
4
2
3+import Data.UUID
4+import Data.Text (Text)
5import Options.Applicative
5import Options.Applicative
6−import Web.Connexpay.Types
7
6
7+data ConnexpayCli = ConnexpayCli { login :: Text
8+ , password :: Text
9+ , deviceGuid :: UUID
10+ , endpoint :: Text
11+ } deriving Show
8
12
9−connexpayOpts :: Parser Config
13+connexpayOpts :: Parser ConnexpayCli
10−connexpayOpts = do
14+connexpayOpts =
11− host <- option str (long "connexpay-endpoint" <> metavar "URL")
12− login <- option str (long "connexpay-login" <> metavar "LOGIN")
15+ ConnexpayCli <$> option str (long "connexpay-login" <> metavar "LOGIN")
13− password <- option str (long "connexpay-password" <> metavar "PASSWORD")
16+ <*> option str (long "connexpay-password" <> metavar "PASSWORD")
14− deviceGuid <- option str (long "connexpay-devguid" <> metavar "GUID")
17+ <*> option auto (long "connexpay-devguid" <> metavar "GUID")
15− useHttp <- switch (long "use-http" <> help "Use plain HTTP. Insecure!")
18+ <*> option str (long "connexpay-endpoint" <> metavar "URL")
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+46−37
@@ -1,68 +1,77 @@
1cabal-version: 3.0
1cabal-version: 3.0
2name: connexpay
2name: connexpay
3−description: Interacting with Connexpay API
4version: 0.1
3version: 0.1
5synopsis: ConnexPay library for Haskell
4synopsis: ConnexPay library for Haskell
6homepage: https://github.com/typeable/connexpay
5homepage: https://github.com/typeable/connexpay
7−license: MIT
6+license: NONE
8author: Nick
7author: Nick
9maintainer: nick@typeable.io
8maintainer: nick@typeable.io
10copyright: Typeable.io
9copyright: Typeable.io
11category: Web
10category: Web
12build-type: Simple
11build-type: Simple
12+-- extra-source-files:
13
13
14−
15−tested-with: GHC ==9.8.4 || ==9.6.6
16−
17−common common
14+common warnings
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:
15+ ghc-options: -Wall
32− -Wall -Wmissing-deriving-strategies -Wprepositive-qualified-module
33− -Wunused-packages -Wredundant-constraints
34
16
35library
17library
36− import: common
18+ import: warnings
37− exposed-modules:
19+ exposed-modules: Web.Connexpay
20+ Web.Connexpay.Auth
21+ Web.Connexpay.Data
38− Web.Connexpay.Init
22+ Web.Connexpay.Init
39− Web.Connexpay.Payments
23+ Web.Connexpay.Payments
40− Web.Connexpay.Types
41− other-modules:
42− Web.Connexpay.Auth
43− Web.Connexpay.Http
44− Web.Connexpay.Payments.Types
24+ Web.Connexpay.Types
45− Web.Connexpay.Utils
25+ Web.Connexpay.Utils
26+ default-extensions: DuplicateRecordFields
27+ OverloadedLabels
28+ OverloadedRecordDot
29+ NoFieldSelectors
30+ -- other-modules:
31+ -- other-extensions:
46 build-depends: base >=4.14 && < 5.0
32 build-depends: base >=4.14 && < 5.0
47 , aeson
33 , aeson
48 , async
34 , async
35+ , bucks
49 , bytestring
36 , bytestring
50 , http-api-data
37 , http-api-data
51 , http-client
38 , http-client
52 , http-types
39 , http-types
53− , safe-exceptions
40+ , mtl
41+ , req
54 , text
42 , text
43+ , uuid
55 hs-source-dirs: src
44 hs-source-dirs: src
45+ default-language: GHC2021
56
46
57executable connexpay-tool
47executable connexpay-tool
58− import: common
48+ import: warnings
49+ default-extensions: DuplicateRecordFields
50+ OverloadedLabels
51+ OverloadedRecordDot
52+ NoFieldSelectors
59 build-depends: base >= 4.17
53 build-depends: base >= 4.17
60 , aeson
54 , aeson
61− , connexpay
55+ , async
56+ , bucks
57+ , bytestring
58+ , http-api-data
62 , http-client
59 , http-client
63 , http-client-tls
60 , http-client-tls
61+ , http-types
62+ , mtl
64 , optparse-applicative
63 , optparse-applicative
64+ , req
65 , text
65 , text
66+ , uuid
66 , yaml
67 , yaml
67− hs-source-dirs: tool
68+ hs-source-dirs: src
69+ other-modules: Web.Connexpay
70+ Web.Connexpay.Auth
71+ Web.Connexpay.Data
72+ Web.Connexpay.Init
73+ Web.Connexpay.Payments
74+ Web.Connexpay.Types
75+ Web.Connexpay.Utils
68− main-is: Main.hs
76+ main-is: Tool.hs
77+ default-language: GHC2021
connexpay/src/Tool.hsnew file+94
@@ -0,0 +1,94 @@
1+{-# LANGUAGE ApplicativeDo #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Main where
4+
5+import Control.Concurrent (yield)
6+import Control.Monad
7+import Control.Monad.IO.Class
8+import Data.Aeson
9+import Data.Fixed
10+import Data.Maybe (fromMaybe)
11+import Data.Money
12+import Data.Text (Text)
13+import Data.Text.Encoding qualified as Text
14+import Data.Text.IO qualified as Text
15+import Data.UUID
16+import Data.Yaml (decodeFileThrow)
17+import GHC.Generics
18+import Network.HTTP.Client
19+import Network.HTTP.Client.TLS
20+import Options.Applicative
21+import Web.Connexpay
22+import Web.Connexpay.Types
23+
24+data Config = Config { login :: Text
25+ , password :: Text
26+ , host :: Text
27+ , device_guid :: UUID
28+ , use_tls :: Bool
29+ , proxy_host :: Maybe Text
30+ , proxy_port :: Maybe Word
31+ } deriving Generic
32+
33+instance FromJSON Config
34+
35+data Command = AuthSale CreditCard Centi
36+ | VoidAuth AuthOnlyGuid
37+ | VoidSale SaleGuid (Maybe Centi)
38+ | CaptureSale AuthOnlyGuid
39+ | CancelSale SaleGuid
40+ | ReturnSale SaleGuid (Maybe Centi)
41+ | TestAuth
42+
43+data CmdLine = CmdLine { configPath :: FilePath
44+ , operation :: Command
45+ }
46+
47+cmdParser :: Parser CmdLine
48+cmdParser = CmdLine <$> strOption (short 'c' <> metavar "FILE" <> help "Configuration file path")
49+ <*> subparser operation
50+ where operation = command "auth" (info (AuthSale <$> cc <*> amt) (progDesc "Authorise payment"))
51+ <> command "void-auth" (info (VoidAuth <$> guid) (progDesc "Void payment"))
52+ <> command "void-sale" (info (VoidSale <$> guid <*> optional amt) (progDesc "Void payment"))
53+ <> command "capture" (info (CaptureSale <$> guid) (progDesc "Capture payment"))
54+ <> command "cancel" (info (CancelSale <$> guid) (progDesc "Cancel payment"))
55+ <> command "return" (info (ReturnSale <$> guid <*> optional amt) (progDesc "return payment"))
56+ <> command "test-auth" (info (pure TestAuth) (progDesc "Test token authorisation"))
57+ amt = argument auto (metavar "Payment amount")
58+ cc = CreditCard <$> argument str mempty
59+ <*> fmap pure (argument str mempty)
60+ <*> argument expdate mempty
61+ <*> fmap pure (argument str mempty)
62+ expdate = do s <- str
63+ guard (length s == 4)
64+ pure (read (take 2 s), read (drop 2 s))
65+ guid = argument auto (metavar "Payment UUID")
66+
67+writeLog :: Text -> IO ()
68+writeLog msg = Text.putStrLn ("Connexpay log: " <> msg)
69+
70+main :: IO ()
71+main = do cmdLine <- execParser (info (cmdParser <**> helper) mempty)
72+ cnf :: Config <- decodeFileThrow cmdLine.configPath
73+ mgr <- fromMaybe newTlsManager
74+ $ do host <- cnf.proxy_host
75+ port <- cnf.proxy_port
76+ let proxy = useProxy (Proxy (Text.encodeUtf8 host) (fromIntegral port))
77+ s = managerSetProxy proxy defaultManagerSettings
78+ return (newManager s)
79+ res <- initConnexpay writeLog mgr cnf.device_guid cnf.host cnf.use_tls cnf.login cnf.password
80+ case res of
81+ Left err -> putStrLn ("Error: " <> show err)
82+ Right cpi -> print =<< runConnexpay cpi (doThing cmdLine.operation)
83+
84+doThing :: Command -> ConnexpayM ()
85+doThing (AuthSale cc amt) = liftIO . print =<< authorisePayment cc usd pnr vendor
86+ where usd = Money amt
87+ pnr = Just "PNRPNR"
88+ vendor = Just "Typeable payment"
89+doThing (VoidAuth guid) = liftIO . print =<< voidPayment (VoidAuthorized guid)
90+doThing (VoidSale guid amt) = liftIO . print =<< voidPayment (VoidCaptured guid (Money <$> amt))
91+doThing (CaptureSale guid) = liftIO . print =<< capturePayment guid
92+doThing (CancelSale guid) = liftIO . print =<< cancelPayment guid
93+doThing (ReturnSale guid amt) = liftIO . print =<< returnPayment guid (Money <$> amt)
94+doThing TestAuth = liftIO (forever yield)
connexpay/src/Web/Connexpay.hsnew file+16
@@ -0,0 +1,16 @@
1+module Web.Connexpay ( module Payments
2+ , initConnexpay
3+ , Connexpay(..)
4+ , ConnexpayM
5+ , PaymentFailure(..)
6+ , ConnectionError(..)
7+ , ConnexpayError(..)
8+ , TransactionStatus(..)
9+ , describeFailure
10+ , runConnexpay
11+ ) where
12+
13+import Web.Connexpay.Data
14+import Web.Connexpay.Init
15+import Web.Connexpay.Payments as Payments
16+import Web.Connexpay.Types
connexpay/src/Web/Connexpay/Auth.hs+23−59
@@ -1,31 +1,22 @@
1{-# LANGUAGE OverloadedLists #-}
1{-# LANGUAGE OverloadedLists #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Web.Connexpay.Auth (authenticate) where
2
4
3−module Web.Connexpay.Auth
5+import Web.Connexpay.Types
4− ( AuthReply(..)
5− , TokenReply(..)
6− , authenticate
7− ) where
8
6
9import Control.Monad
7import Control.Monad
8+import Control.Monad.Reader
10import Data.Aeson
9import Data.Aeson
11import Data.Aeson.Types
10import Data.Aeson.Types
12import Data.ByteString (ByteString)
11import Data.ByteString (ByteString)
13import Data.ByteString qualified as ByteString
12import Data.ByteString qualified as ByteString
14−import Data.ByteString.Lazy qualified as Lazy
15−import Data.ByteString.Lazy qualified as Lazy.ByteString
16import Data.Text (Text)
13import Data.Text (Text)
17import Data.Text qualified as Text
14import Data.Text qualified as Text
18−import Data.Text.Encoding qualified as Text
15+import Network.HTTP.Req
19−import Network.HTTP.Client qualified as HTTP
20−import Network.HTTP.Types
21import Numeric.Natural
16import Numeric.Natural
22import Web.FormUrlEncoded
17import Web.FormUrlEncoded
23import Web.HttpApiData
18import Web.HttpApiData
24
19
25−import Web.Connexpay.Http
26−import Web.Connexpay.Types
27−
28−
29data AuthForm = AuthForm { login :: Text
20data AuthForm = AuthForm { login :: Text
30 , password :: Text
21 , password :: Text
31 }
22 }
@@ -36,19 +27,13 @@ instance ToForm AuthForm where
36 , ("password", toQueryParam auth.password)
27 , ("password", toQueryParam auth.password)
37 ]
28 ]
38
29
39−mkAuthForm :: Config -> ByteString
30+mkAuthForm :: Text -> Text -> ByteString
40−mkAuthForm cfg = ByteString.toStrict (urlEncodeAsForm form)
31+mkAuthForm login passwd = ByteString.toStrict (urlEncodeAsForm form)
41− where form = AuthForm cfg.login cfg.password
32+ where form = AuthForm login passwd
42−
43−data AuthReply
44− = Authorized TokenReply
45− | Unauthorized (HTTP.Response Lazy.ByteString)
46− | AuthParseError String
47− deriving stock (Show)
48
33
49data TokenReply = TokenReply { token :: BearerToken
34data TokenReply = TokenReply { token :: BearerToken
50− , expiresIn :: Natural
35+ , expires_in :: Natural
51− } deriving stock (Show)
36+ } deriving (Show)
52
37
53instance FromJSON TokenReply where
38instance FromJSON TokenReply where
54 parseJSON (Object v) = do typ <- v .: "token_type"
39 parseJSON (Object v) = do typ <- v .: "token_type"
@@ -58,37 +43,16 @@ instance FromJSON TokenReply where
58 <*> v .: "expires_in"
43 <*> v .: "expires_in"
59 parseJSON v = typeMismatch "TokenReply" v
44 parseJSON v = typeMismatch "TokenReply" v
60
45
61−authenticate :: Config -> Env -> IO AuthReply
46+authenticate :: ConnexpayM (BearerToken, Natural)
62−authenticate config env = do
47+authenticate = do login <- asks (.login)
63− let
48+ password <- asks (.password)
64− req = HTTP.defaultRequest
49+ host <- asks (.url)
65− { HTTP.method = "POST"
50+ tls <- asks (.useTLS)
66− , HTTP.host = Text.encodeUtf8 config.host
51+ let body = ReqBodyBs (mkAuthForm login password)
67− , HTTP.port = if config.useTLS then 443 else 80
68− , HTTP.secure = config.useTLS
69− , HTTP.path = "api/v1/token"
52+ url s = s host /: "api" /: "v1" /: "token"
70− , HTTP.requestHeaders =
53+ resp <-
71− [ ("Accept", "application/json")
54+ if tls
72− , ("Accept-Encoding", "gzip")
55+ then req POST (url https) body jsonResponse mempty
73− ]
56+ else req POST (url http) body jsonResponse mempty
74− , HTTP.requestBody = HTTP.RequestBodyBS $ mkAuthForm config
57+ let TokenReply tok ts = responseBody resp
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
58+ pure (tok, ts)
connexpay/src/Web/Connexpay/Data.hsnew file+96
@@ -0,0 +1,96 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module Web.Connexpay.Data ( TransactionStatus(..)
3+ , PaymentFailure(..)
4+ , ConnectionError(..)
5+ , ConnexpayError(..)
6+ , describeFailure
7+ , guessFailure
8+ , ErrorMessage(..)
9+ ) where
10+
11+import Control.Exception
12+import Data.Aeson
13+import Data.Aeson.Types
14+import Data.Maybe (fromMaybe)
15+import Data.Text (Text)
16+import Network.HTTP.Client
17+
18+-- | Transaction status in Connexpay
19+-- The list is taken from https://docs.connexpay.com/reference/search-sales
20+data TransactionStatus = TransactionApproved -- ^ Obvious
21+ | TransactionDeclined -- ^ Also obvious
22+ | TransactionCreatedLocal -- ^ Seems to only exist in a test environment, indicates success.
23+ | TransactionCreatedProcNotReached -- ^ Communication error between Connexpay and Card Processor
24+ | TransactionCreatedProcError -- ^ Processor errored out
25+ | TransactionApprovedWarning -- ^ Wut 0__o FIXME: figure out what this is
26+ | TransactionOther Text -- ^ In case they return something unexpected
27+ deriving (Eq, Ord, Show)
28+
29+statuses :: [(Text, TransactionStatus)]
30+statuses = [ ( "Transaction - Approved", TransactionApproved )
31+ , ( "Transaction - Declined", TransactionDeclined )
32+ , ( "Transaction - CreatedLocal", TransactionCreatedLocal )
33+ , ( "Transaction - Created - Error: Processor not reached", TransactionCreatedProcNotReached )
34+ , ( "Transaction - Processor Error", TransactionCreatedProcError )
35+ , ( "Transaction - Approved - Warning", TransactionApprovedWarning )
36+ ]
37+
38+instance FromJSON TransactionStatus where
39+ parseJSON (String s) = pure (fromMaybe (TransactionOther s) (lookup s statuses))
40+ parseJSON v = typeMismatch "TransactionStatus" v
41+
42+-- | Payment failure types.
43+-- This type describes failures that related to either credit card being invalid,
44+-- client account having insufficient funds, and other non-technical conditions.
45+-- FIXME: this list is not exhaustive. Add more values whenever we encounter them.
46+data PaymentFailure = CVVFailed -- ^ CVV verification failure
47+ | CardInvalid -- ^ Credit card details are invalid
48+ | InvalidAmount -- ^ Money amount is invalid
49+ | GeneralDecline -- ^ They just decline
50+ | LocalTransaction -- ^ Special case for transactions that were registered but did't go through somehow.
51+ | OtherProcessingError Text -- ^ Some other processing error with 422 code
52+ deriving (Eq, Show)
53+
54+describeFailure :: PaymentFailure -> Text
55+describeFailure CVVFailed = "CVV authorisation failure"
56+describeFailure CardInvalid = "Invalid credit card details"
57+describeFailure InvalidAmount = "Invalid amount of money requested"
58+describeFailure GeneralDecline = "General card decine"
59+describeFailure LocalTransaction = "Transaction registered but not processed. Consult with payment processor."
60+describeFailure (OtherProcessingError txt) = "Transaction declined due to other error: " <> txt
61+
62+-- | Guess failure type from HTTP code and supplied error string.
63+guessFailure :: Int -> Text -> Maybe PaymentFailure
64+guessFailure 422 "Error code D2020. CVV2 verification failed." = Just CVVFailed
65+guessFailure 422 "Error code D2005. Invalid Card." = Just CardInvalid
66+guessFailure 422 "Amount field don't allow a value greater than $999,999.99" = Just InvalidAmount
67+guessFailure 422 "Error code D2999. General CardAuth Decline." = Just GeneralDecline
68+guessFailure 422 txt = Just (OtherProcessingError txt)
69+guessFailure _ _ = Nothing
70+
71+-- | Error response from Connexpay
72+data ErrorMessage = ErrorMessage { message :: Text
73+ , errorId :: Text }
74+
75+instance FromJSON ErrorMessage where
76+ parseJSON (Object o) = ErrorMessage <$> o .: "message"
77+ <*> o .: "errorId"
78+ parseJSON v = typeMismatch "ErrorMessage" v
79+
80+data ConnectionError = ParseError String
81+ | InvalidUrl String String
82+ | HttpFailure HttpExceptionContent
83+ | TokenError String
84+ deriving Show
85+
86+-- | Error type for Connexpay.
87+-- There are two possible cases here:
88+-- * Connection failure means the payment may or may not have gotten through.
89+-- This would be typically thrown as an exception in an application.
90+-- * Payment failure means Connexpay returned an error and the payment wasn't authorised.
91+-- No exception here, this must be handled as usual.
92+data ConnexpayError = ConnectionError ConnectionError
93+ | PaymentFailure PaymentFailure
94+ deriving (Show)
95+
96+instance Exception ConnexpayError
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+59−37
@@ -1,48 +1,70 @@
1+{-# LANGUAGE OverloadedStrings #-}
1module Web.Connexpay.Init (initConnexpay) where
2module Web.Connexpay.Init (initConnexpay) where
2
3
4+import Web.Connexpay.Auth
5+import Web.Connexpay.Data
6+import Web.Connexpay.Types
7+import Web.Connexpay.Utils
8+
3import Control.Concurrent
9import Control.Concurrent
4import Control.Concurrent.Async
10import Control.Concurrent.Async
5−import Control.Exception.Safe
11+import Control.Monad (void)
6−import Control.Monad
12+import Control.Monad.Except (catchError)
7−import Data.Aeson
13+import Control.Monad.IO.Class
8−import Data.Aeson.Text
14+import Control.Monad.Reader (asks)
9import Data.Text (Text)
15import Data.Text (Text)
10−import Data.Text qualified as Text
11−import Data.Text.Lazy qualified as Lazy.Text
12import Network.HTTP.Client (Manager)
16import Network.HTTP.Client (Manager)
13import Numeric.Natural
17import Numeric.Natural
14
18
15−import Web.Connexpay.Auth
16−import Web.Connexpay.Types
17−
18−
19-- | Initialise Connexpay state. Log in, authenticate, and obtain bearer token.
19-- | Initialise Connexpay state. Log in, authenticate, and obtain bearer token.
20−initConnexpay
20+initConnexpay :: (Text -> IO ()) -- ^ Logging function
21− :: Logger
22− -> Manager
21+ -> Manager -- ^ HTTP client manager
23− -> Config
22+ -> DeviceGuid -- ^ Device GUID. You must obtain this from ConnexPay
23+ -> Text -- ^ Connexpay host to connect with
24+ -> Bool -- ^ Whether to use TLS. If unsure, say True.
25+ -> Text -- ^ Login name.
26+ -> Text -- ^ Password.
24− -> IO Connexpay
27+ -> IO (Either ConnexpayError Connexpay)
25−initConnexpay logAction manager config = do
28+initConnexpay logf mgr devguid url tls login password =
26− bearerToken <- newMVar Nothing
29+ do v <- newMVar Nothing
27− let env = Env{..}
30+ let env = Connexpay { logAction = logf
28− refreshAsync <- async $ forever $
31+ , manager = mgr
29− updateToken config env bearerToken 0 `catchAny` \err -> do
32+ , bearerToken = v
30− doLog env $
33+ , refreshAsync = Nothing
31− "Connexpay token update exception: " <> Text.pack (displayException err)
34+ , deviceGuid = devguid
32− threadDelay 5_000_000
35+ , url = url
33− pure Connexpay{..}
36+ , useTLS = tls
37+ , login = login
38+ , password = password
39+ }
40+ runConnexpay env $ do
41+ ts <- initialAuth v logf
42+ a <- liftIO (async (runConnexpay_ env $ updateToken ts))
43+ pure (env { refreshAsync = Just a })
44+
45+initialAuth :: MVar (Maybe BearerToken) -> (Text -> IO ()) -> ConnexpayM Natural
46+initialAuth v logf =
47+ do (tok, ts) <- authenticate
48+ liftIO $ do logf "Connexpay authentication success"
49+ void (swapMVar v (Just tok))
50+ return ts
51+ `catchError` \err -> do
52+ liftIO (logf ("Initial connexpay authentication failed: " <> tshow err))
53+ -- if initial authentication failed, wait 1 second?
54+ -- there isn't much else to do, really.
55+ return 1
34
56
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
45
57
46−doLog :: Env -> Text -> IO ()
58+updateToken :: Natural -> ConnexpayM ()
47−doLog env msg = env.logAction $ Lazy.Text.toStrict $ encodeToLazyText @Object $
59+updateToken w = liftIO (threadDelay w') >> upd
48− "connexpay" .= ("auth" .= msg :: Object)
60+ where w' = fromIntegral w * 1000000
61+ upd = do (tok, ts) <- authenticate
62+ logf <- asks (.logAction)
63+ tokVar <- asks (.bearerToken)
64+ liftIO (void $ swapMVar tokVar (Just tok))
65+ liftIO (logf "Connexpay token update success")
66+ updateToken (ts - 5)
67+ `catchError` \err -> do
68+ logf <- asks (.logAction)
69+ liftIO (logf ("Connexpay token update failure: " <> tshow err))
70+ updateToken 5
connexpay/src/Web/Connexpay/Payments.hs+203−66
@@ -1,81 +1,218 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE UndecidableInstances #-}
1−module Web.Connexpay.Payments
4+module Web.Connexpay.Payments ( CreditCard(..)
2− ( AuthRequest(..)
3− , USD(..)
4− , CreditCard(..)
5− , ExpirationDate(..)
6− , Customer(..)
7− , RiskData(..)
8− , AuthorizeResult(..)
9− , AuthResponse(..)
5+ , AuthResponse(..)
10− , TransactionStatus(..)
11− , authorisePayment
6+ , authorisePayment
12− , VoidRequest(..)
7+ , VoidRequest(..)
13− , voidPayment
8+ , voidPayment
14− , CaptureResponse(..)
9+ , CaptureResponse(..)
15− , Sale(..)
16− , capturePayment
10+ , capturePayment
17− , cancelPayment
11+ , cancelPayment
18− , returnPayment
12+ , returnPayment
19− ) where
13+ ) where
20
14
15+import Control.Monad (when,void)
16+import Control.Monad.Except (throwError)
17+import Control.Monad.Reader (asks)
18+import Control.Monad.Writer.Strict
21import Data.Aeson
19import Data.Aeson
20+import Data.Aeson.KeyMap qualified as KeyMap
21+import Data.Aeson.Types (Pair, typeMismatch)
22+import Data.ByteString.Lazy qualified as ByteString
23+import Data.Int (Int32)
24+import Data.Money
25+import Data.Proxy
26+import Data.Text (Text)
27+import Data.Text qualified as Text
28+import Data.Text.Encoding qualified as Text
29+import GHC.TypeError as TypeError
30+import Network.HTTP.Req
22
31
23−import Web.Connexpay.Http
32+import Web.Connexpay.Data
24−import Web.Connexpay.Payments.Types
25import Web.Connexpay.Types
33import Web.Connexpay.Types
34+import Web.Connexpay.Utils
26
35
36+-- | Credit card info
37+-- No 'Show' instance should be made for this type
38+-- in order to avoid sensitive data leaks.
39+data CreditCard = CreditCard { number :: Text -- ^ Credit card number, as 'Text'.
40+ , cardholder :: Maybe Text -- ^ Cardholder name, optional.
41+ , expiration :: (Word, Word) -- ^ Expiration date (month,year).
42+ , cvv :: Maybe Text -- ^ CVC/CVV code.
43+ }
44+
45+type ShowError = TypeError.Text "CreditCard must not be shown in order to avoid leaking sensitive data"
46+
47+instance TypeError ShowError => Show CreditCard where
48+ show = error "UNREACHABLE"
49+
50+instance ToJSON CreditCard where
51+ toJSON cc = object
52+ $ execWriter
53+ $ do tell ["CardNumber" .= cc.number]
54+ whenJust cc.cardholder $ \name ->
55+ tell ["CardHolderName" .= name]
56+ whenJust cc.cvv $ \cvv ->
57+ tell ["Cvv2" .= cvv]
58+ let expDate = padDate (tshow (snd cc.expiration)) <> padDate (tshow (fst cc.expiration))
59+ tell ["ExpirationDate" .= expDate]
60+
61+padDate :: Text -> Text
62+padDate t | Text.length t == 1 = "0" <> t
63+ | otherwise = t
64+
65+sendRequest' :: HttpResponse resp => Proxy resp -> Text -> [Pair] -> ConnexpayM resp
66+sendRequest' resp endpoint body =
67+ do mtok <- bearerToken
68+ tok <- case mtok of
69+ Just t -> pure t
70+ Nothing -> throwError (ConnectionError $ TokenError "No authentication token available. Check connection parameters?")
71+ host <- asks (.url)
72+ tls <- asks (.useTLS)
73+ let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)
74+ url s = s host /: "api" /: "v1" /: endpoint
75+ obj <- object <$> addGuid body
76+ let jbody = ReqBodyJson obj
77+ r <- if tls
78+ then reqCb POST (url https) jbody resp auth (logRequest obj)
79+ else reqCb POST (url http) jbody resp auth (logRequest obj)
80+ logResponse r
81+ pure r
82+ where
83+ addGuid b =
84+ do guid <- asks (.deviceGuid)
85+ return (b <> [ "DeviceGuid" .= show guid ])
86+ logRequest v r =
87+ do log_ <- asks (.logAction)
88+ -- Remove card info from logs
89+ let v' = case v of
90+ Object obj
91+ | Just c <- KeyMap.lookup "Card" obj -> Object (KeyMap.insert "Card" (replaceCard c) obj)
92+ other -> other
93+ msg = Text.unlines [ "Connexpay request:"
94+ , tshow r
95+ , Text.decodeUtf8 (ByteString.toStrict $ encode v')
96+ ]
97+ _ <- liftIO (log_ msg)
98+ return r
99+ replaceCard (Object c) =
100+ Object
101+ $ KeyMap.insert "CardNumber" (String "<REDACTED>")
102+ $ KeyMap.insert "Cvv2" (String "<REDACTED>")
103+ $ c
104+ replaceCard v = v
105+
106+sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a)
107+sendRequestJson = sendRequest' jsonResponse
108+
109+sendRequest_ :: Text -> [Pair] -> ConnexpayM ()
110+sendRequest_ ep = void . sendRequest' ignoreResponse ep
111+
112+data AuthResponse = AuthResponse { paymentGuid :: AuthOnlyGuid
113+ , status :: TransactionStatus
114+ , processorStatusCode :: Maybe Text
115+ , processorMessage :: Maybe Text
116+ , addressVerificationCode :: Maybe Text
117+ , cvvVerificationCode :: Maybe Text
118+ } deriving (Show)
119+
120+instance FromJSON AuthResponse where
121+ parseJSON (Object o) = AuthResponse <$> o .: "guid"
122+ <*> o .: "status"
123+ <*> o .:? "processorStatusCode"
124+ <*> o .:? "processorResponseMessage"
125+ <*> o .:? "addressVerificationCode"
126+ <*> o .:? "cvvVerificationCode"
127+ parseJSON v = typeMismatch "AuthReponse" v
27
128
28-- | Authorise a credit card payment.
129-- | Authorise a credit card payment.
29−authorisePayment
130+authorisePayment :: CreditCard -- ^ Credit card details (see 'CreditCard')
30− :: Connexpay -> Env -> AuthRequest -> IO (Response AuthError AuthorizeResult)
131+ -> Money USD -- ^ Amount to charge, USD
31−authorisePayment connexpay env raw =
132+ -> Maybe Text -- ^ Invoice description
32− bimapResponse (guessErrorType guessAuthError) postProcessAuthResponse <$>
133+ -> Maybe Text -- ^ Merchant description that will appear in a customer's statement.
33− doRequest connexpay env "authonlys" RequestBody
134+ -> ConnexpayM AuthResponse
34− { raw
135+authorisePayment cc amt invoice vendor =
35− , logMasker = maskAuthRequest
136+ do resp <- sendRequestJson "authonlys" body
36− }
137+ let rbody = responseBody resp
138+ -- Special case for Connexpay local transaction
139+ -- This status means that the transaction was registered,
140+ -- but Connexpay stopped its processing and it won't be
141+ -- moved any further.
142+ -- Also, when I asked Ken from Connexpay about this,
143+ -- he told me he had never seen this status before.
144+ when (rbody.status == TransactionCreatedLocal) $
145+ throwError (PaymentFailure LocalTransaction)
146+ pure rbody
147+ where body = execWriter $
148+ do tell [ "Card" .= cc ]
149+ tell [ "Amount" .= getAmount amt ]
150+ whenJust invoice $ \i ->
151+ tell [ "OrderNumber" .= i ]
152+ whenJust vendor $ \v ->
153+ tell [ "StatementDescription" .= v ]
154+ -- We are supposed to pass RiskData, but it still
155+ -- can be an empty object. Consider population this
156+ -- should the need arise.
157+ tell [ "RiskData" .= KeyMap.empty @() ]
158+
159+data VoidRequest = VoidAuthorized AuthOnlyGuid | VoidCaptured SaleGuid (Maybe (Money USD))
37
160
38-- | Void payment
161-- | Void payment
39−voidPayment :: Connexpay -> Env -> VoidRequest -> IO (Response () ())
162+voidPayment :: VoidRequest
40−voidPayment connexpay env raw = doRequest_ connexpay env "void" RequestBody
163+ -> ConnexpayM ()
41− { raw
164+voidPayment (VoidAuthorized pid) = sendRequest_ "void" body
42− , logMasker = id
165+ where body = [ "AuthOnlyGuid" .= show pid ]
43− }
166+voidPayment (VoidCaptured pid amt) = sendRequest_ "void" body
167+ where body = execWriter $
168+ do tell [ "SaleGuid" .= show pid ]
169+ whenJust amt $ \m ->
170+ tell [ "Amount" .= getAmount m ]
171+
172+-- | Internal data type for Capture requests.
173+data CPTransaction = CPTransaction { expectedPayments :: Int32 }
174+
175+instance ToJSON CPTransaction where
176+ toJSON t = object [ "ExpectedPayments" .= t.expectedPayments ]
177+
178+-- | Response for the payment capture request
179+data CaptureResponse = CaptureResponse { captureGuid :: CaptureGuid
180+ , saleGuid :: SaleGuid
181+ , saleStatus :: TransactionStatus
182+ } deriving (Show)
183+
184+instance FromJSON CaptureResponse where
185+ parseJSON (Object o) =
186+ do cguid <- o .: "guid"
187+ sale <- o .: "sale"
188+ saleGuid <- sale .: "guid"
189+ status <- sale .: "status"
190+ pure (CaptureResponse cguid saleGuid status)
191+ parseJSON v = typeMismatch "CaptureResponse" v
44
192
45-- | Capture payment, previously authorised through 'authorisePayment'.
193-- | Capture payment, previously authorised through 'authorisePayment'.
46−capturePayment :: Connexpay
47− -> Env
48− -> AuthOnlyGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
194+capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
49− -> IO (Response () CaptureResponse)
195+ -> ConnexpayM CaptureResponse
50−capturePayment connexpay env pid = doRequest connexpay env "Captures" RequestBody
196+capturePayment pid =
51− { raw = object
197+ do resp <- sendRequestJson "Captures" body
198+ let rbody = responseBody resp
199+ pure rbody
52− [ "AuthOnlyGuid" .= pid
200+ where body = [ "AuthOnlyGuid" .= show pid
53− , "ConnexPayTransaction" .= CPTransaction 1
201+ , "ConnexPayTransaction" .= CPTransaction 1 ]
54− ]
55− , logMasker = id
56− }
57
202
58-- | Cancel voided or captured payment.
203-- | Cancel voided or captured payment.
59-- In case of an authorised-only payment, voiding is performed.
204-- In case of an authorised-only payment, voiding is performed.
60-- Otherwise, a payment goes through a refund process.
205-- Otherwise, a payment goes through a refund process.
61−cancelPayment :: Connexpay
62− -> Env
63− -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
206+cancelPayment :: SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
64− -> IO (Response () ())
207+ -> ConnexpayM ()
65−cancelPayment connexpay env pid = doRequest_ connexpay env "cancel" RequestBody
208+cancelPayment pid = sendRequest_ "cancel" body
66− { raw = object [ "SaleGuid" .= pid ]
209+ where body = [ "SaleGuid" .= show pid ]
67− , logMasker = id
210+
68− }
69−
70−returnPayment :: Connexpay
71− -> Env
72− -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
211+returnPayment :: SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
73− -> USD
212+ -> Maybe (Money USD)
74− -> IO (Response () ())
213+ -> ConnexpayM ()
75−returnPayment connexpay env pid amt = doRequest_ connexpay env "returns" RequestBody
214+returnPayment pid amt = sendRequest_ "returns" body
76− { raw = object
215+ where body = execWriter $
77− [ "SaleGuid" .= pid
216+ do tell [ "SaleGuid" .= show pid ]
217+ whenJust amt $ \m ->
78− , "Amount" .= amt
218+ tell [ "Amount" .= getAmount m ]
79− ]
80− , logMasker = id
81− }
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+68−82
@@ -1,86 +1,72 @@
1+{-# LANGUAGE OverloadedStrings #-}
1module Web.Connexpay.Types where
2module Web.Connexpay.Types where
2
3
4+import Web.Connexpay.Data
5+import Web.Connexpay.Utils
6+
3import Control.Concurrent.Async
7import Control.Concurrent.Async
4−import Control.Concurrent.MVar (MVar)
8+import Control.Concurrent.MVar (MVar, readMVar)
9+import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError)
10+import Control.Monad.IO.Class
11+import Control.Monad.Reader
5−import Data.Aeson hiding (Error)
12+import Data.Aeson
6−import Data.Bifunctor
7−import Data.ByteString.Lazy qualified as Lazy (ByteString)
8import Data.Text (Text)
13import Data.Text (Text)
14+import Data.Text qualified as Text
15+import Data.UUID (UUID)
9−import Network.HTTP.Client (Manager)
16+import Network.HTTP.Client hiding (responseHeaders)
10−
17+import Network.HTTP.Req
11−
18+import Network.HTTP.Types
19+
12−newtype BearerToken = BearerToken
20+type BearerToken = Text
13− { unBearerToken :: Text
21+type DeviceGuid = UUID
14− } deriving newtype (Show, FromJSON, ToJSON)
15−
16−newtype AuthOnlyGuid = AuthOnlyGuid
22+type AuthOnlyGuid = UUID
17− { unAuthOnlyGuid :: Text
23+type SaleGuid = UUID
18− } deriving newtype (Show, FromJSON, ToJSON)
24+type CaptureGuid = UUID
19−
25+
20−newtype SaleGuid = SaleGuid
26+data Connexpay = Connexpay { logAction :: Text -> IO ()
21− { unSaleGuid :: Text
27+ , manager :: Manager
22− } deriving newtype (Show, FromJSON, ToJSON)
28+ , bearerToken :: MVar (Maybe BearerToken)
23−
29+ , refreshAsync :: Maybe (Async ())
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
30+ , deviceGuid :: DeviceGuid
31+ , url :: Text
35− , useTLS :: Bool
32+ , useTLS :: Bool
33+ , login :: Text
34+ , password :: Text
36− }
35+ }
37−
36+
38−data Connexpay = Connexpay
37+newtype ConnexpayM a = ConnexpayM (ReaderT Connexpay (ExceptT ConnexpayError IO) a)
39− { config :: Config
38+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader Connexpay, MonadError ConnexpayError)
40− , bearerToken :: MVar (Maybe BearerToken)
39+
41− , refreshAsync :: Async ()
40+instance MonadHttp ConnexpayM where
42− }
41+ handleHttpException (JsonHttpException e) = throwError (ConnectionError $ ParseError e)
43−
42+ handleHttpException (VanillaHttpException (InvalidUrlException url why)) = throwError (ConnectionError $ InvalidUrl url why)
44−data Env = Env
43+ handleHttpException (VanillaHttpException (HttpExceptionRequest _ (StatusCodeException resp bs)))
45− { logAction :: Logger
44+ | Just err <- decodeStrict @ErrorMessage bs
46− , manager :: Manager
45+ , Just f <- guessFailure (statusCode $ responseStatus resp) err.message = throwError (PaymentFailure f)
47− }
46+ handleHttpException (VanillaHttpException (HttpExceptionRequest _ c)) = throwError (ConnectionError $ HttpFailure c)
48−
47+
49−data Response e a
48+ getHttpConfig = do mgr <- asks (.manager)
50− = ResponseSuccess a
49+ pure (defaultHttpConfig { httpConfigAltManager = Just mgr })
51− | ResponseError (Error e)
50+
52− -- ^ Response structured error (422 status code) is received
51+
53− | BadRequest Lazy.ByteString
52+runConnexpay :: Connexpay -> ConnexpayM a -> IO (Either ConnexpayError a)
54− | MissingOrExpiredToken
53+runConnexpay cp (ConnexpayM a) = runExceptT (runReaderT a cp)
55− -- ^ Most likely invalid credentials/URL are passed during initialization.
54+
56− -- No request is even sent to Connexpay.
55+runConnexpay_ :: Connexpay -> ConnexpayM a -> IO ()
57− deriving stock (Show, Functor)
56+runConnexpay_ cp m =
58−
57+ do r <- runConnexpay cp m
59−instance Bifunctor Response where
58+ whenLeft r $ \err ->
60− bimap f = bimapResponse (fmap f)
59+ cp.logAction ("Uncaught Connexpay error: " <> Text.pack (show err))
61−
60+
62−bimapResponse
61+bearerToken :: ConnexpayM (Maybe BearerToken)
63− :: (Error e -> Error e') -> (a -> b) -> Response e a -> Response e' b
62+bearerToken = do v <- asks (.bearerToken)
64−bimapResponse f g = \case
63+ liftIO (readMVar v)
65− ResponseSuccess a -> ResponseSuccess (g a)
64+
66− ResponseError e -> ResponseError (f e)
65+logResponse :: HttpResponse r => r -> ConnexpayM ()
67− BadRequest body -> BadRequest body
66+logResponse r =
68− MissingOrExpiredToken -> MissingOrExpiredToken
67+ do log_ <- asks (.logAction)
69−
68+ liftIO (log_ msg)
70−guessErrorType :: (Error () -> e) -> Error () -> Error e
69+ where msg = Text.unlines [ "Connexpay response:"
71−guessErrorType mkErr e = e { errorType = mkErr e }
70+ , "HTTP code: " <> tshow (responseCode r)
72−
71+ , "Headers: " <> tshow (responseHeaders r)
73−data Error e = Error
72+ ]
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+17−14
@@ -1,22 +1,25 @@
1module Web.Connexpay.Utils where
1module Web.Connexpay.Utils where
2
2
3−import Data.Aeson.Types
4−import Data.Char
5import Data.Text (Text)
3import Data.Text (Text)
6import Data.Text qualified as Text
4import Data.Text qualified as Text
5+import Network.HTTP.Client qualified as Client
6+import Network.HTTP.Req
7+import Network.HTTP.Types
7
8
9+whenLeft :: Monad m => Either a b -> (a -> m ()) -> m ()
10+whenLeft (Left l) f = f l
11+whenLeft (Right _) _ = pure ()
8
12
9−starWords :: Text -> Text
13+whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
10−starWords = Text.unwords . map toStars . Text.words
14+whenJust (Just x) f = f x
11− where toStars w = Text.replicate (Text.length w) "*"
15+whenJust Nothing _ = pure ()
12
16
13−capitalize :: String -> String
17+tshow :: Show a => a -> Text
14−capitalize [] = []
18+tshow = Text.pack . show
15−capitalize (x : xs) = toUpper x : xs
19+
20+responseHeaders :: HttpResponse response => response -> [Header]
21+responseHeaders = Client.responseHeaders . toVanillaResponse
22+
23+responseCode :: HttpResponse response => response -> Int
24+responseCode = statusCode . Client.responseStatus . toVanillaResponse
16
25
17−aesonOptions :: Options
18−aesonOptions = defaultOptions
19− { fieldLabelModifier = capitalize
20− , tagSingleConstructors = True
21− , omitNothingFields = True
22− }
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+4−1
@@ -4,7 +4,10 @@ packages:
4- connexpay
4- connexpay
5- connexpay-optparse
5- connexpay-optparse
6
6
7+extra-deps:
8+ - git: https://github.com/typeable/bucks.git
9+ commit: 9e378b675fe7fb88d5ddb3af068d82eb441f343c
10+
7nix:
11nix:
8 packages: [zlib]
12 packages: [zlib]
9−
10local-bin-path: bin
13local-bin-path: bin