git.iko.soy/typeable/connexpay
on abfd81b help sign in
92e8e52
swap
0 ahead, 25 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
README.org−27
@@ -28,33 +28,6 @@ NOTE:
28'PaymentError' type isn't used yet, but it will after more testing.
28'PaymentError' type isn't used yet, but it will after more testing.
29Connexpay test environment doesn't seem to report errors adequately.
29Connexpay test environment doesn't seem to report errors adequately.
30
30
31−* The tool
32−
33−This repo provides a command line tool to quickly test the API. You can run it with ~stack run~.
34−Examples:
35−
36− - ~stack run -- -c ./config.yaml auth CARDNUMBER "NAME" MMYY CVV SUM~
37− - ~stack run -- -c ./config.yaml capture SALEGUID~
38− - ~stack run -- -c ./config.yaml void-auth AUTHONLYGUID~
39− - ~stack run -- -c ./config.yaml void-sale SALEGUID~
40− - ~stack run -- -c ./config.yaml void-sale SALEGUID SUM~
41− - ~stack run -- -c ./config.yaml cancel SALEGUID~
42− - ~stack run -- -c ./config.yaml return SALEGUID~
43− - ~stack run -- -c ./config.yaml return SALEGUID SUM~
44−
45−Configuration file must include the values provided to you by Connexpay:
46−
47−#+begin_src
48−login: <login>
49−password: <password>
50−device_guid: <device guid>
51−host: <hostname>
52−
53−use_tls: true # Whether or not to use TLS connection
54−proxy_host: 127.0.0.1 # Optional, if you want to proxy your requests for debugging purposes
55−proxy_port: 8080
56−#+end_src
57−
58* Links
31* Links
59
32
60Credit card sales API: https://docs.connexpay.com/reference/credit-card-sales
33Credit 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/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+47−38
@@ -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
6−homepage: https://github.com/typeable/connexpay
5+homepage: https://github.com/downtowntravel/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+88
@@ -0,0 +1,88 @@
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+ | VoidSale SaleGuid
37+ | CaptureSale SaleGuid
38+ | CancelSale SaleGuid
39+ | TestAuth
40+
41+data CmdLine = CmdLine { configPath :: FilePath
42+ , operation :: Command
43+ }
44+
45+cmdParser :: Parser CmdLine
46+cmdParser = CmdLine <$> strOption (short 'c' <> metavar "FILE" <> help "Configuration file path")
47+ <*> subparser operation
48+ where operation = command "auth" (info (AuthSale <$> cc <*> amt) (progDesc "Authorise payment"))
49+ <> command "void" (info (VoidSale <$> guid) (progDesc "Void payment"))
50+ <> command "capture" (info (CaptureSale <$> guid) (progDesc "Capture payment"))
51+ <> command "cancel" (info (CancelSale <$> guid) (progDesc "Cancel payment"))
52+ <> command "test-auth" (info (pure TestAuth) (progDesc "Test token authorisation"))
53+ amt = argument auto (metavar "Payment amount")
54+ cc = CreditCard <$> argument str mempty
55+ <*> fmap pure (argument str mempty)
56+ <*> argument expdate mempty
57+ <*> fmap pure (argument str mempty)
58+ expdate = do s <- str
59+ guard (length s == 4)
60+ pure (read (take 2 s), read (drop 2 s))
61+ guid = argument auto (metavar "Payment UUID")
62+
63+writeLog :: Text -> IO ()
64+writeLog msg = Text.putStrLn ("Connexpay log: " <> msg)
65+
66+main :: IO ()
67+main = do cmdLine <- execParser (info cmdParser mempty)
68+ cnf :: Config <- decodeFileThrow cmdLine.configPath
69+ mgr <- fromMaybe newTlsManager
70+ $ do host <- cnf.proxy_host
71+ port <- cnf.proxy_port
72+ let proxy = useProxy (Proxy (Text.encodeUtf8 host) (fromIntegral port))
73+ s = managerSetProxy proxy defaultManagerSettings
74+ return (newManager s)
75+ res <- initConnexpay writeLog mgr cnf.device_guid cnf.host cnf.use_tls cnf.login cnf.password
76+ case res of
77+ Left err -> putStrLn ("Error: " <> show err)
78+ Right cpi -> print =<< runConnexpay cpi (doThing cmdLine.operation)
79+
80+doThing :: Command -> ConnexpayM ()
81+doThing (AuthSale cc amt) = liftIO . print =<< authorisePayment cc usd pnr vendor
82+ where usd = Money amt
83+ pnr = Just "PNRPNR"
84+ vendor = Just "Typeable payment"
85+doThing (VoidSale guid) = liftIO . print =<< voidPayment guid Nothing
86+doThing (CaptureSale guid) = liftIO . print =<< capturePayment guid
87+doThing (CancelSale guid) = liftIO . print =<< cancelPayment guid
88+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+89
@@ -0,0 +1,89 @@
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+ | LocalTransaction -- ^ Special case for transactions that were registered but did't go through somehow.
50+ deriving (Eq, Show)
51+
52+describeFailure :: PaymentFailure -> Text
53+describeFailure CVVFailed = "CVV authorisation failure"
54+describeFailure CardInvalid = "Invalid credit card details"
55+describeFailure InvalidAmount = "Invalid amount of money requested"
56+describeFailure LocalTransaction = "Transaction registered but not processed. Consult with payment processor."
57+
58+-- | Guess failure type from HTTP code and supplied error string.
59+guessFailure :: Int -> Text -> Maybe PaymentFailure
60+guessFailure 422 "Error code D2020. CVV2 verification failed." = Just CVVFailed
61+guessFailure 422 "Error code D2005. Invalid Card." = Just CardInvalid
62+guessFailure 422 "Amount field don't allow a value greater than $999,999.99" = Just InvalidAmount
63+guessFailure _ _ = Nothing
64+
65+-- | Error response from Connexpay
66+data ErrorMessage = ErrorMessage { message :: Text
67+ , errorId :: Text }
68+
69+instance FromJSON ErrorMessage where
70+ parseJSON (Object o) = ErrorMessage <$> o .: "message"
71+ <*> o .: "errorId"
72+ parseJSON v = typeMismatch "ErrorMessage" v
73+
74+data ConnectionError = ParseError String
75+ | InvalidUrl String String
76+ | HttpFailure HttpExceptionContent
77+ deriving Show
78+
79+-- | Error type for Connexpay.
80+-- There are two possible cases here:
81+-- * Connection failure means the payment may or may not have gotten through.
82+-- This would be typically thrown as an exception in an application.
83+-- * Payment failure means Connexpay returned an error and the payment wasn't authorised.
84+-- No exception here, this must be handled as usual.
85+data ConnexpayError = ConnectionError ConnectionError
86+ | PaymentFailure PaymentFailure
87+ deriving (Show)
88+
89+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+50−39
@@ -1,48 +1,59 @@
1+{-# LANGUAGE OverloadedStrings #-}
1−module Web.Connexpay.Init (initConnexpay) where
2+module Web.Connexpay.Init where
3+
4+import Web.Connexpay.Auth
5+import Web.Connexpay.Data
6+import Web.Connexpay.Types
7+import Web.Connexpay.Utils
2
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 <- newEmptyMVar
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
34−
37+ , login = login
35−updateToken :: Config -> Env -> MVar (Maybe BearerToken) -> Natural -> IO ()
38+ , password = password
36−updateToken config env tokVar w =
39+ }
37− threadDelay (fromIntegral w * 1_000_000) >> upd
40+ runConnexpay env $ do
38− where
41+ (tok, ts) <- authenticate
39− upd = authenticate config env >>= \case
42+ a <- liftIO $ do logf "Connexpay authentication success"
40− Authorized tok -> do
43+ putMVar v tok
41− _ <- swapMVar tokVar (Just tok.token)
44+ async (runConnexpay_ env $ updateToken ts)
42− updateToken config env tokVar (tok.expiresIn - 5)
45+ pure (env { refreshAsync = Just a })
43− _ -> do
44− updateToken config env tokVar 5
45
46
46−doLog :: Env -> Text -> IO ()
47+updateToken :: Natural -> ConnexpayM ()
47−doLog env msg = env.logAction $ Lazy.Text.toStrict $ encodeToLazyText @Object $
48+updateToken w = liftIO (threadDelay w') >> upd
48− "connexpay" .= ("auth" .= msg :: Object)
49+ where w' = fromIntegral w * 1000000
50+ upd = do (tok, ts) <- authenticate
51+ logf <- asks (.logAction)
52+ tokVar <- asks (.bearerToken)
53+ liftIO (void $ swapMVar tokVar tok)
54+ liftIO (logf "Connexpay token update success")
55+ updateToken (ts - 5)
56+ `catchError` \err -> do
57+ logf <- asks (.logAction)
58+ liftIO (logf ("Connexpay token update failure: " <> tshow err))
59+ updateToken 5
connexpay/src/Web/Connexpay/Payments.hs+138−66
@@ -1,81 +1,153 @@
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(..)
13− , voidPayment
7+ , voidPayment
14− , CaptureResponse(..)
15− , Sale(..)
16− , capturePayment
8+ , capturePayment
17− , cancelPayment
9+ , cancelPayment
18− , returnPayment
19− ) where
10+ ) where
20
11
12+import Control.Monad (when,void)
13+import Control.Monad.Except (throwError)
14+import Control.Monad.Reader (asks)
15+import Control.Monad.Writer.Strict
21import Data.Aeson
16import Data.Aeson
17+import Data.Aeson.KeyMap qualified as KeyMap
18+import Data.Aeson.Types (Pair, typeMismatch)
19+import Data.Int (Int32)
20+import Data.Money
21+import Data.Proxy
22+import Data.Text (Text)
23+import Data.Text qualified as Text
24+import Data.Text.Encoding qualified as Text
25+import GHC.TypeError as TypeError
26+import Network.HTTP.Req
22
27
23−import Web.Connexpay.Http
28+import Web.Connexpay.Data
24−import Web.Connexpay.Payments.Types
25import Web.Connexpay.Types
29import Web.Connexpay.Types
30+import Web.Connexpay.Utils
26
31
32+-- | Credit card info
33+-- No 'Show' instance should be made for this type
34+-- in order to avoid sensitive data leaks.
35+data CreditCard = CreditCard { number :: Text -- ^ Credit card number, as 'Text'.
36+ , cardholder :: Maybe Text -- ^ Cardholder name, optional.
37+ , expiration :: (Word, Word) -- ^ Expiration date (month,year).
38+ , cvv :: Maybe Text -- ^ CVC/CVV code.
39+ }
40+
41+type ShowError = TypeError.Text "CreditCard must not be shown in order to avoid leaking sensitive data"
42+
43+instance TypeError ShowError => Show CreditCard where
44+ show = error "UNREACHABLE"
45+
46+instance ToJSON CreditCard where
47+ toJSON cc = object
48+ $ execWriter
49+ $ do tell ["CardNumber" .= cc.number]
50+ whenJust cc.cardholder $ \name ->
51+ tell ["CardHolderName" .= name]
52+ whenJust cc.cvv $ \cvv ->
53+ tell ["Cvv2" .= cvv]
54+ let expDate = padDate (tshow (snd cc.expiration)) <> padDate (tshow (fst cc.expiration))
55+ tell ["ExpirationDate" .= expDate]
56+
57+padDate :: Text -> Text
58+padDate t | Text.length t == 1 = "0" <> t
59+ | otherwise = t
60+
61+sendRequest' :: HttpResponse resp => Proxy resp -> Text -> [Pair] -> ConnexpayM resp
62+sendRequest' resp endpoint body =
63+ do tok <- bearerToken
64+ host <- asks (.url)
65+ tls <- asks (.useTLS)
66+ let auth = header "Authorization" ("Bearer " <> Text.encodeUtf8 tok)
67+ url s = s host /: "api" /: "v1" /: endpoint
68+ jbody <- ReqBodyJson . object <$> addGuid body
69+ if tls
70+ then req POST (url https) jbody resp auth
71+ else req POST (url http) jbody resp auth
72+ where addGuid b = do guid <- asks (.deviceGuid)
73+ return (b <> [ "DeviceGuid" .= show guid ])
74+
75+sendRequestJson :: FromJSON a => Text -> [Pair] -> ConnexpayM (JsonResponse a)
76+sendRequestJson = sendRequest' jsonResponse
77+
78+sendRequest_ :: Text -> [Pair] -> ConnexpayM ()
79+sendRequest_ ep = void . sendRequest' ignoreResponse ep
80+
81+data AuthResponse = AuthResponse { paymentGuid :: SaleGuid
82+ , status :: TransactionStatus
83+ , processorStatusCode :: Maybe Text
84+ , processorMessage :: Maybe Text
85+ } deriving (Show)
86+
87+instance FromJSON AuthResponse where
88+ parseJSON (Object o) = AuthResponse <$> o .: "guid"
89+ <*> o .: "status"
90+ <*> o .:? "processorStatusCode"
91+ <*> o .:? "processorResponseMessage"
92+ parseJSON v = typeMismatch "AuthReponse" v
27
93
28-- | Authorise a credit card payment.
94-- | Authorise a credit card payment.
29−authorisePayment
95+authorisePayment :: CreditCard -- ^ Credit card details (see 'CreditCard')
30− :: Connexpay -> Env -> AuthRequest -> IO (Response AuthError AuthorizeResult)
96+ -> Money USD -- ^ Amount to charge, USD
31−authorisePayment connexpay env raw =
97+ -> Maybe Text -- ^ Invoice description
32− bimapResponse (guessErrorType guessAuthError) postProcessAuthResponse <$>
98+ -> Maybe Text -- ^ Merchant description that will appear in a customer's statement.
33− doRequest connexpay env "authonlys" RequestBody
99+ -> ConnexpayM AuthResponse
34− { raw
100+authorisePayment cc amt invoice vendor =
35− , logMasker = maskAuthRequest
101+ do resp <- sendRequestJson "authonlys" body
36− }
102+ let rbody = responseBody resp
103+ -- Special case for Connexpay local transaction
104+ -- This status means that the transaction was registered,
105+ -- but Connexpay stopped its processing and it won't be
106+ -- moved any further.
107+ -- Also, when I asked Ken from Connexpay about this,
108+ -- he told me he had never seen this status before.
109+ when (rbody.status == TransactionCreatedLocal) $
110+ throwError (PaymentFailure LocalTransaction)
111+ pure rbody
112+ where body = execWriter $
113+ do tell [ "Card" .= cc ]
114+ tell [ "Amount" .= getAmount amt ]
115+ whenJust invoice $ \i ->
116+ tell [ "OrderNumber" .= i ]
117+ whenJust vendor $ \v ->
118+ tell [ "StatementDescription" .= v ]
119+ -- We are supposed to pass RiskData, but it still
120+ -- can be an empty object. Consider population this
121+ -- should the need arise.
122+ tell [ "RiskData" .= KeyMap.empty @() ]
37
123
38-- | Void payment
124-- | Void payment
39−voidPayment :: Connexpay -> Env -> VoidRequest -> IO (Response () ())
125+voidPayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
40−voidPayment connexpay env raw = doRequest_ connexpay env "void" RequestBody
126+ -> Maybe (Money USD) -- ^ Optionally, you may only void a partial sum, with the rest being subsequently charged.
41− { raw
127+ -> ConnexpayM ()
42− , logMasker = id
128+voidPayment pid amt = sendRequest_ "void" body
43− }
129+ where body = execWriter $
130+ do tell [ "AuthOnlyGuid" .= show pid ]
131+ whenJust amt $ \m ->
132+ tell [ "Amount" .= getAmount m ]
133+
134+-- | Internal data type for Capture requests.
135+data CPTransaction = CPTransaction { expectedPayments :: Int32 }
136+
137+instance ToJSON CPTransaction where
138+ toJSON t = object [ "ExpectedPayments" .= t.expectedPayments ]
44
139
45-- | Capture payment, previously authorised through 'authorisePayment'.
140-- | Capture payment, previously authorised through 'authorisePayment'.
46−capturePayment :: Connexpay
47− -> Env
48− -> AuthOnlyGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
141+capturePayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
49− -> IO (Response () CaptureResponse)
142+ -> ConnexpayM ()
50−capturePayment connexpay env pid = doRequest connexpay env "Captures" RequestBody
143+capturePayment pid = sendRequest_ "Captures" body
51− { raw = object
52− [ "AuthOnlyGuid" .= pid
144+ where body = [ "AuthOnlyGuid" .= show pid
53− , "ConnexPayTransaction" .= CPTransaction 1
145+ , "ConnexPayTransaction" .= CPTransaction 1 ]
54− ]
55− , logMasker = id
56− }
57
146
58-- | Cancel voided or captured payment.
147-- | Cancel voided or captured payment.
59-- In case of an authorised-only payment, voiding is performed.
148-- In case of an authorised-only payment, voiding is performed.
60-- Otherwise, a payment goes through a refund process.
149-- Otherwise, a payment goes through a refund process.
61−cancelPayment :: Connexpay
62− -> Env
63− -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
150+cancelPayment :: SaleGuid -- ^ Sales GUID, obtained from 'authorisePayment'.
64− -> IO (Response () ())
151+ -> ConnexpayM ()
65−cancelPayment connexpay env pid = doRequest_ connexpay env "cancel" RequestBody
152+cancelPayment pid = sendRequest_ "cancel" body
66− { raw = object [ "SaleGuid" .= pid ]
153+ where body = [ "SaleGuid" .= show pid ]
67− , logMasker = id
68− }
69−
70−returnPayment :: Connexpay
71− -> Env
72− -> SaleGuid -- ^ Sales GUID, obtained from 'capturePayment'.
73− -> USD
74− -> IO (Response () ())
75−returnPayment connexpay env pid amt = doRequest_ connexpay env "returns" RequestBody
76− { raw = object
77− [ "SaleGuid" .= pid
78− , "Amount" .= amt
79− ]
80− , logMasker = id
81− }
connexpay/src/Web/Connexpay/Payments/Types.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+57−82
@@ -1,86 +1,61 @@
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
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
17− { unAuthOnlyGuid :: Text
18− } deriving newtype (Show, FromJSON, ToJSON)
19−
20−newtype SaleGuid = SaleGuid
22+type SaleGuid = UUID
21− { unSaleGuid :: Text
23+
22− } deriving newtype (Show, FromJSON, ToJSON)
24+data Connexpay = Connexpay { logAction :: Text -> IO ()
23−
25+ , manager :: Manager
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)
26+ , bearerToken :: MVar BearerToken
41− , refreshAsync :: Async ()
27+ , refreshAsync :: Maybe (Async ())
42− }
28+ , deviceGuid :: DeviceGuid
43−
29+ , url :: Text
44−data Env = Env
30+ , useTLS :: Bool
45− { logAction :: Logger
31+ , login :: Text
46− , manager :: Manager
32+ , password :: Text
47− }
33+ }
48−
34+
49−data Response e a
35+newtype ConnexpayM a = ConnexpayM (ReaderT Connexpay (ExceptT ConnexpayError IO) a)
50− = ResponseSuccess a
36+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader Connexpay, MonadError ConnexpayError)
51− | ResponseError (Error e)
37+
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
38+instance MonadHttp ConnexpayM where
60− bimap f = bimapResponse (fmap f)
39+ handleHttpException (JsonHttpException e) = throwError (ConnectionError $ ParseError e)
61−
40+ handleHttpException (VanillaHttpException (InvalidUrlException url why)) = throwError (ConnectionError $ InvalidUrl url why)
62−bimapResponse
41+ handleHttpException (VanillaHttpException (HttpExceptionRequest _ (StatusCodeException resp bs)))
63− :: (Error e -> Error e') -> (a -> b) -> Response e a -> Response e' b
42+ | Just err <- decodeStrict @ErrorMessage bs
64−bimapResponse f g = \case
43+ , Just f <- guessFailure (statusCode $ responseStatus resp) err.message = throwError (PaymentFailure f)
65− ResponseSuccess a -> ResponseSuccess (g a)
44+ handleHttpException (VanillaHttpException (HttpExceptionRequest _ c)) = throwError (ConnectionError $ HttpFailure c)
66− ResponseError e -> ResponseError (f e)
45+
67− BadRequest body -> BadRequest body
46+ getHttpConfig = do mgr <- asks (.manager)
68− MissingOrExpiredToken -> MissingOrExpiredToken
47+ pure (defaultHttpConfig { httpConfigAltManager = Just mgr })
69−
48+
70−guessErrorType :: (Error () -> e) -> Error () -> Error e
49+
71−guessErrorType mkErr e = e { errorType = mkErr e }
50+runConnexpay :: Connexpay -> ConnexpayM a -> IO (Either ConnexpayError a)
72−
51+runConnexpay cp (ConnexpayM a) = runExceptT (runReaderT a cp)
73−data Error e = Error
52+
74− { message :: Text
53+runConnexpay_ :: Connexpay -> ConnexpayM a -> IO ()
75− , errorId :: Text
54+runConnexpay_ cp m =
76− , errorType :: e
55+ do r <- runConnexpay cp m
77− } deriving stock (Show, Functor)
56+ whenLeft r $ \err ->
78−
57+ cp.logAction ("Uncaught Connexpay error: " <> Text.pack (show err))
79−instance FromJSON (Error ()) where
58+
80− parseJSON = withObject "Error" \o -> do
59+bearerToken :: ConnexpayM BearerToken
81− message <- o .: "message"
60+bearerToken = do v <- asks (.bearerToken)
82− errorId <- o .: "errorId"
61+ liftIO (readMVar v)
83− pure Error
84− { errorType = ()
85− , ..
86− }
connexpay/src/Web/Connexpay/Utils.hs+8−15
@@ -1,22 +1,15 @@
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
7
5
6+whenLeft :: Monad m => Either a b -> (a -> m ()) -> m ()
7+whenLeft (Left l) f = f l
8+whenLeft (Right _) _ = pure ()
8
9
9−starWords :: Text -> Text
10+whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
10−starWords = Text.unwords . map toStars . Text.words
11+whenJust (Just x) f = f x
11− where toStars w = Text.replicate (Text.length w) "*"
12+whenJust Nothing _ = pure ()
12
13
13−capitalize :: String -> String
14+tshow :: Show a => a -> Text
14−capitalize [] = []
15+tshow = Text.pack . show
15−capitalize (x : xs) = toUpper x : xs
16−
17−aesonOptions :: Options
18−aesonOptions = defaultOptions
19− { fieldLabelModifier = capitalize
20− , tagSingleConstructors = True
21− , omitNothingFields = True
22− }
connexpay/tool/Main.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+5−2
@@ -1,10 +1,13 @@
1−resolver: lts-22.36
1+resolver: lts-22.24
2
2
3packages:
3packages:
4- connexpay
4- connexpay
5- connexpay-optparse
5- connexpay-optparse
6
6
7+extra-deps:
8+ - git: https://github.com/typeable/bucks.git
9+ commit: 9e378b675fe7fb88d5ddb3af068d82eb441f343c
10+
7nix:
11nix:
8 packages: [zlib]
12 packages: [zlib]
9−
10local-bin-path: bin
13local-bin-path: bin