git.iko.soy/typeable/http-api-data
on master help sign in
swap
c80fefa148 ahead, 0 behind
.github/workflows/haskell-ci.ymlnew file+283
since splitsnapshots
unifiedsplit
@@ -0,0 +1,283 @@
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.15.20220609
12+#
13+# REGENDATA ("0.15.20220609",["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-20.04
27+ timeout-minutes:
28+ 60
29+ container:
30+ image: buildpack-deps:bionic
31+ continue-on-error: ${{ matrix.allow-failure }}
32+ strategy:
33+ matrix:
34+ include:
35+ - compiler: ghc-9.4.0.20220523
36+ compilerKind: ghc
37+ compilerVersion: 9.4.0.20220523
38+ setup-method: ghcup
39+ allow-failure: true
40+ - compiler: ghc-9.2.3
41+ compilerKind: ghc
42+ compilerVersion: 9.2.3
43+ setup-method: ghcup
44+ allow-failure: false
45+ - compiler: ghc-9.0.2
46+ compilerKind: ghc
47+ compilerVersion: 9.0.2
48+ setup-method: ghcup
49+ allow-failure: false
50+ - compiler: ghc-8.10.7
51+ compilerKind: ghc
52+ compilerVersion: 8.10.7
53+ setup-method: ghcup
54+ allow-failure: false
55+ - compiler: ghc-8.8.4
56+ compilerKind: ghc
57+ compilerVersion: 8.8.4
58+ setup-method: hvr-ppa
59+ allow-failure: false
60+ - compiler: ghc-8.6.5
61+ compilerKind: ghc
62+ compilerVersion: 8.6.5
63+ setup-method: hvr-ppa
64+ allow-failure: false
65+ - compiler: ghc-8.4.4
66+ compilerKind: ghc
67+ compilerVersion: 8.4.4
68+ setup-method: hvr-ppa
69+ allow-failure: false
70+ - compiler: ghc-8.2.2
71+ compilerKind: ghc
72+ compilerVersion: 8.2.2
73+ setup-method: hvr-ppa
74+ allow-failure: false
75+ - compiler: ghc-8.0.2
76+ compilerKind: ghc
77+ compilerVersion: 8.0.2
78+ setup-method: hvr-ppa
79+ allow-failure: false
80+ fail-fast: false
81+ steps:
82+ - name: apt
83+ run: |
84+ apt-get update
85+ apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
86+ if [ "${{ matrix.setup-method }}" = ghcup ]; then
87+ mkdir -p "$HOME/.ghcup/bin"
88+ curl -sL https://downloads.haskell.org/ghcup/0.1.17.8/x86_64-linux-ghcup-0.1.17.8 > "$HOME/.ghcup/bin/ghcup"
89+ chmod a+x "$HOME/.ghcup/bin/ghcup"
90+ if $HEADHACKAGE; then "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml; fi
91+ "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
92+ "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
93+ else
94+ apt-add-repository -y 'ppa:hvr/ghc'
95+ apt-get update
96+ apt-get install -y "$HCNAME"
97+ mkdir -p "$HOME/.ghcup/bin"
98+ curl -sL https://downloads.haskell.org/ghcup/0.1.17.8/x86_64-linux-ghcup-0.1.17.8 > "$HOME/.ghcup/bin/ghcup"
99+ chmod a+x "$HOME/.ghcup/bin/ghcup"
100+ "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
101+ fi
102+ env:
103+ HCKIND: ${{ matrix.compilerKind }}
104+ HCNAME: ${{ matrix.compiler }}
105+ HCVER: ${{ matrix.compilerVersion }}
106+ - name: Set PATH and environment variables
107+ run: |
108+ echo "$HOME/.cabal/bin" >> $GITHUB_PATH
109+ echo "LANG=C.UTF-8" >> "$GITHUB_ENV"
110+ echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV"
111+ echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV"
112+ HCDIR=/opt/$HCKIND/$HCVER
113+ if [ "${{ matrix.setup-method }}" = ghcup ]; then
114+ HC=$HOME/.ghcup/bin/$HCKIND-$HCVER
115+ echo "HC=$HC" >> "$GITHUB_ENV"
116+ echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV"
117+ echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV"
118+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
119+ else
120+ HC=$HCDIR/bin/$HCKIND
121+ echo "HC=$HC" >> "$GITHUB_ENV"
122+ echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
123+ echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
124+ echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
125+ fi
126+
127+ HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
128+ echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
129+ echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
130+ echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
131+ if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi
132+ echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
133+ echo "GHCJSARITH=0" >> "$GITHUB_ENV"
134+ env:
135+ HCKIND: ${{ matrix.compilerKind }}
136+ HCNAME: ${{ matrix.compiler }}
137+ HCVER: ${{ matrix.compilerVersion }}
138+ - name: env
139+ run: |
140+ env
141+ - name: write cabal config
142+ run: |
143+ mkdir -p $CABAL_DIR
144+ cat >> $CABAL_CONFIG <<EOF
145+ remote-build-reporting: anonymous
146+ write-ghc-environment-files: never
147+ remote-repo-cache: $CABAL_DIR/packages
148+ logs-dir: $CABAL_DIR/logs
149+ world-file: $CABAL_DIR/world
150+ extra-prog-path: $CABAL_DIR/bin
151+ symlink-bindir: $CABAL_DIR/bin
152+ installdir: $CABAL_DIR/bin
153+ build-summary: $CABAL_DIR/logs/build.log
154+ store-dir: $CABAL_DIR/store
155+ install-dirs user
156+ prefix: $CABAL_DIR
157+ repository hackage.haskell.org
158+ url: http://hackage.haskell.org/
159+ EOF
160+ if $HEADHACKAGE; then
161+ cat >> $CABAL_CONFIG <<EOF
162+ repository head.hackage.ghc.haskell.org
163+ url: https://ghc.gitlab.haskell.org/head.hackage/
164+ secure: True
165+ root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d
166+ 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329
167+ f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89
168+ key-threshold: 3
169+ active-repositories: hackage.haskell.org, head.hackage.ghc.haskell.org:override
170+ EOF
171+ fi
172+ cat >> $CABAL_CONFIG <<EOF
173+ program-default-options
174+ ghc-options: $GHCJOBS +RTS -M3G -RTS
175+ EOF
176+ cat $CABAL_CONFIG
177+ - name: versions
178+ run: |
179+ $HC --version || true
180+ $HC --print-project-git-commit-id || true
181+ $CABAL --version || true
182+ - name: update cabal index
183+ run: |
184+ $CABAL v2-update -v
185+ - name: cache (tools)
186+ uses: actions/cache@v2
187+ with:
188+ key: ${{ runner.os }}-${{ matrix.compiler }}-tools-445c2459
189+ path: ~/.haskell-ci-tools
190+ - name: install cabal-plan
191+ run: |
192+ mkdir -p $HOME/.cabal/bin
193+ curl -sL https://github.com/haskell-hvr/cabal-plan/releases/download/v0.6.2.0/cabal-plan-0.6.2.0-x86_64-linux.xz > cabal-plan.xz
194+ echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c -
195+ xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan
196+ rm -f cabal-plan.xz
197+ chmod a+x $HOME/.cabal/bin/cabal-plan
198+ cabal-plan --version
199+ - name: install doctest
200+ run: |
201+ if [ $((HCNUMVER < 90000)) -ne 0 ] ; then $CABAL --store-dir=$HOME/.haskell-ci-tools/store v2-install $ARG_COMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.20' ; fi
202+ if [ $((HCNUMVER < 90000)) -ne 0 ] ; then doctest --version ; fi
203+ - name: checkout
204+ uses: actions/checkout@v2
205+ with:
206+ path: source
207+ - name: initial cabal.project for sdist
208+ run: |
209+ touch cabal.project
210+ echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project
211+ cat cabal.project
212+ - name: sdist
213+ run: |
214+ mkdir -p sdist
215+ $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist
216+ - name: unpack
217+ run: |
218+ mkdir -p unpacked
219+ find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \;
220+ - name: generate cabal.project
221+ run: |
222+ PKGDIR_http_api_data="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/http-api-data-[0-9.]*')"
223+ echo "PKGDIR_http_api_data=${PKGDIR_http_api_data}" >> "$GITHUB_ENV"
224+ rm -f cabal.project cabal.project.local
225+ touch cabal.project
226+ touch cabal.project.local
227+ echo "packages: ${PKGDIR_http_api_data}" >> cabal.project
228+ if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package http-api-data" >> cabal.project ; fi
229+ if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi
230+ cat >> cabal.project <<EOF
231+ EOF
232+ if $HEADHACKAGE; then
233+ echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1,/g')" >> cabal.project
234+ fi
235+ $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(http-api-data)$/; }' >> cabal.project.local
236+ cat cabal.project
237+ cat cabal.project.local
238+ - name: dump install plan
239+ run: |
240+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all
241+ cabal-plan
242+ - name: cache
243+ uses: actions/cache@v2
244+ with:
245+ key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}
246+ path: ~/.cabal/store
247+ restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-
248+ - name: install dependencies
249+ run: |
250+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all
251+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all
252+ - name: build w/o tests
253+ run: |
254+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
255+ - name: build
256+ run: |
257+ $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always
258+ - name: tests
259+ run: |
260+ $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct
261+ - name: doctest
262+ run: |
263+ perl -i -e 'while (<ARGV>) { print unless /package-id\s+(base-compat)-\d+(\.\d+)*/; }' .ghc.environment.*
264+ if [ $((HCNUMVER < 90000)) -ne 0 ] ; then cd ${PKGDIR_http_api_data} || false ; fi
265+ if [ $((HCNUMVER < 90000)) -ne 0 ] ; then doctest -XHaskell2010 src/ ; fi
266+ - name: cabal check
267+ run: |
268+ cd ${PKGDIR_http_api_data} || false
269+ ${CABAL} -vnormal check
270+ - name: haddock
271+ run: |
272+ $CABAL v2-haddock --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all
273+ - name: unconstrained build
274+ run: |
275+ rm -f cabal.project.local
276+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
277+ - name: prepare for constraint sets
278+ run: |
279+ rm -f cabal.project.local
280+ - name: constraint set text-show
281+ run: |
282+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='http-api-data +use-text-show' --dependencies-only -j2 all
283+ $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='http-api-data +use-text-show' all
.gitignore+2
@@ -1,4 +1,6 @@
1/dist/
1/dist/
2+/dist-newstyle/
3+/.ghc.environment.*
2/.shelly/
4/.shelly/
3/tarballs/
5/tarballs/
4*.swp
6*.swp
.travis.ymldeleted−35
@@ -1,35 +0,0 @@
1−sudo: false
2−
3−addons:
4− apt:
5− sources:
6− - hvr-ghc
7− packages:
8− - happy-1.19.5
9− - libgmp-dev
10−
11−env:
12− - STACK_YAML=stack.yaml FLAGS="--flag http-api-data:use-text-show"
13− - STACK_YAML=stack-ghc-7.8.yaml FLAGS="--flag http-api-data:use-text-show"
14− - STACK_YAML=stack-ghc-7.10.yaml FLAGS="--flag http-api-data:use-text-show"
15− - STACK_YAML=stack.yaml FLAGS=
16− - STACK_YAML=stack-ghc-7.8.yaml FLAGS=
17− - STACK_YAML=stack-ghc-7.10.yaml FLAGS=
18−
19−before_install:
20− # Download and unpack the stack executable
21− - mkdir -p ~/.local/bin
22− - export PATH=$HOME/.local/bin:/opt/happy/1.19.5/bin:$PATH
23− - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
24− - export PATH=~/.local/bin:$PATH
25− - stack --version
26−
27−install:
28− - stack setup
29−
30−script:
31− - stack --no-terminal build --test $FLAGS
32−
33−cache:
34− directories:
35− - $HOME/.stack
CHANGELOG.md+136
@@ -1,3 +1,139 @@
1+0.5
2+---
3+
4+* Use `attoparsec-iso8601-1.1.0.0`.
5+ `Day` and `UTCTime` parsers require at least 4 digits now, which is a breaking change.
6+* Drop GHC-7.8 and GHC-7.10 support.
7+
8+0.4.3
9+-----
10+
11+* Add `Quarter`, `QuarterOfYear` and `Month` instances
12+* Support `bytestring-0.11`
13+
14+0.4.2
15+-----
16+
17+* Add instances for `Const` and `Identity`
18+
19+0.4.1.1
20+-------
21+
22+* Allow cookie <0.5
23+* Change to `build-type: Simple`
24+
25+0.4.1
26+-----
27+
28+* Use `time-compat` to provide instances for `DayOfWeek`.
29+
30+0.4
31+---
32+
33+* `NominalDiffTime` instances preserve precision (roundtrip)
34+* Add `Semigroup.Min`, `Max`, `First`, `Last` instances
35+* Add `Tagged b a` instances
36+
37+0.3.10
38+---
39+
40+* Fix 'SetCookie' instances
41+ (see [#86](https://github.com/fizruk/http-api-data/pull/86))
42+* Add support for `Fixed`
43+ (see [#78](https://github.com/fizruk/http-api-data/pull/87))
44+
45+0.3.9
46+---
47+
48+* GHC-8.6 support
49+* Remove dependency on `uri-bytestring` and use functions from `http-types` instead
50+ (see [#75](https://github.com/fizruk/http-api-data/pull/75))
51+* Add support for `SetCookie`
52+ (see [#74](https://github.com/fizruk/http-api-data/pull/74))
53+
54+0.3.8.1
55+---
56+
57+* GHC-8.4.1 support
58+
59+0.3.8
60+---
61+
62+* Minor changes:
63+ * Stable URL-encoding for `Form`s (see [#67](https://github.com/fizruk/http-api-data/pull/67)):
64+ * Introduce `urlEncodeParams` and `urlDecodeParams`;
65+ * Introduce `urlEncodeAsFormStable` and use stable encoding for doctests;
66+ * Add `toEntriesByKeyStable` and `toListStable`;
67+ * Add `Semigroup` instance for `Form` (see [#69](https://github.com/fizruk/http-api-data/pull/69));
68+ * Relax upper bound on Cabal (see [#73](https://github.com/fizruk/http-api-data/pull/73)).
69+
70+0.3.7.2
71+---
72+
73+* Allow http-types-0.12
74+* .cabal file adjustments
75+
76+0.3.7.1
77+---
78+
79+* GHC-8.2 support (see [#55](https://github.com/fizruk/http-api-data/pull/55)).
80+
81+0.3.7
82+---
83+
84+* Minor changes:
85+ * Use [`attoparsec-iso8601`](http://hackage.haskell.org/package/attoparsec-iso8601)
86+ for parsing of time types. Now the accepted formats are the same as by `aeson`,
87+ i.e. parsers are more lenient
88+ (see [#41](https://github.com/fizruk/http-api-data/pull/41));
89+ * Preserve fractions of a second in `ToHttpApiData` instances (see [#53](https://github.com/fizruk/http-api-data/pull/53));
90+ * Add `ToHttpApiData` and `FromHttpApiData` instances for `TimeOfDay` (see [#53](https://github.com/fizruk/http-api-data/pull/53)).
91+
92+0.3.6
93+---
94+
95+* Minor change:
96+ * Add `toEncodedUrlPiece` class method for URL-encoded path segments (see [#50](https://github.com/fizruk/http-api-data/pull/50)); use efficient encoding for types whose values don't need URL-encoding.
97+
98+0.3.5
99+---
100+
101+* Minor changes:
102+ * Add `LenientData` which always succeeds to parse (see [#45](https://github.com/fizruk/http-api-data/pull/45)).
103+
104+0.3.4
105+---
106+
107+* Minor changes:
108+ * Add support for GHC 8.2, drop support for GHC 7.6 (see [#44](https://github.com/fizruk/http-api-data/pull/44)).
109+
110+0.3.3
111+---
112+
113+* Minor changes:
114+ * Expose `Form` constructor from `Web.FromUrlEncoded` (see [#40](https://github.com/fizruk/http-api-data/pull/40));
115+ * Fix example in `FromForm` documentation (see [#39](https://github.com/fizruk/http-api-data/issues/39)).
116+
117+0.3.2
118+---
119+
120+* Minor change:
121+ * Export `Form` type from `Web.FormUrlEncoded` (see [#37](https://github.com/fizruk/http-api-data/pull/37)).
122+
123+0.3.1
124+---
125+
126+* Minor changes:
127+ * Add instances for `Data.UUID` (see [#34](https://github.com/fizruk/http-api-data/pull/34)).
128+
129+0.3
130+---
131+* Major changes:
132+ * Add `Web.FormUrlEncoded` to work with form data (see [#32](https://github.com/fizruk/http-api-data/pull/32)).
133+
134+* Minor changes:
135+ * Add instances for `Numeric.Natural` (see [`d944721`](https://github.com/fizruk/http-api-data/commit/d944721ac94929a7ed9e66f25e23221799c08d83)).
136+
10.2.4
1370.2.4
2---
138---
3* Make `parseHeader` total (instead of throwing exceptions on invalid Unicode, see [#30](https://github.com/fizruk/http-api-data/pull/30)).
139* Make `parseHeader` total (instead of throwing exceptions on invalid Unicode, see [#30](https://github.com/fizruk/http-api-data/pull/30)).
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
Setup.lhsdeleted−48
@@ -1,48 +0,0 @@
1−#!/usr/bin/runhaskell
2−\begin{code}
3−{-# OPTIONS_GHC -Wall #-}
4−module Main (main) where
5−
6−import Data.List ( nub )
7−import Data.Version ( showVersion )
8−import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )
9−import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )
10−import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
11−import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )
12−import Distribution.Simple.BuildPaths ( autogenModulesDir )
13−import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )
14−import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )
15−import Distribution.Verbosity ( Verbosity )
16−import System.FilePath ( (</>) )
17−
18−main :: IO ()
19−main = defaultMainWithHooks simpleUserHooks
20− { buildHook = \pkg lbi hooks flags -> do
21− generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi
22− buildHook simpleUserHooks pkg lbi hooks flags
23− }
24−
25−generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()
26−generateBuildModule verbosity pkg lbi = do
27− let dir = autogenModulesDir lbi
28− createDirectoryIfMissingVerbose verbosity True dir
29− withLibLBI pkg lbi $ \_ libcfg -> do
30− withTestLBI pkg lbi $ \suite suitecfg -> do
31− rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines
32− [ "module Build_" ++ testName suite ++ " where"
33− , ""
34− , "autogen_dir :: String"
35− , "autogen_dir = " ++ show dir
36− , ""
37− , "deps :: [String]"
38− , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))
39− ]
40− where
41− formatdeps = map (formatone . snd)
42− formatone p = case packageName p of
43− PackageName n -> n ++ "-" ++ showVersion (packageVersion p)
44−
45−testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]
46−testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
47−
48−\end{code}
cabal.haskell-cinew file+6
@@ -0,0 +1,6 @@
1+branches: master
2+doctest: <9
3+doctest-filter-packages: base-compat
4+
5+constraint-set text-show
6+ constraints: http-api-data +use-text-show
cabal.projectnew file+2
@@ -0,0 +1,2 @@
1+packages: .
2+tests: True
http-api-data.cabal+65−34
@@ -1,39 +1,72 @@
1+cabal-version: >= 1.10
1name: http-api-data
2name: http-api-data
2−version: 0.2.4
3+version: 0.5
4+
5+synopsis: Converting to/from HTTP API data like URL pieces, headers and query parameters.
6+category: Web
7+description:
8+ This package defines typeclasses used for converting Haskell data types to and from HTTP API data.
9+ .
10+ Please see README.md
11+
3license: BSD3
12license: BSD3
4license-file: LICENSE
13license-file: LICENSE
5author: Nickolay Kudasov <nickolay.kudasov@gmail.com>
14author: Nickolay Kudasov <nickolay.kudasov@gmail.com>
6maintainer: Nickolay Kudasov <nickolay.kudasov@gmail.com>
15maintainer: Nickolay Kudasov <nickolay.kudasov@gmail.com>
7−synopsis: Converting to/from HTTP API data like URL pieces, headers and query parameters.
8−description: Please see README.md
9homepage: http://github.com/fizruk/http-api-data
16homepage: http://github.com/fizruk/http-api-data
10−category: Web
11stability: unstable
17stability: unstable
12−cabal-version: >= 1.10
13−build-type: Custom
18+build-type: Simple
19+
14extra-source-files:
20extra-source-files:
21+ include/overlapping-compat.h
15 test/*.hs
22 test/*.hs
16 CHANGELOG.md
23 CHANGELOG.md
17 README.md
24 README.md
18
25
26+tested-with:
27+ GHC==8.0.2,
28+ GHC==8.2.2,
29+ GHC==8.4.4,
30+ GHC==8.6.5,
31+ GHC==8.8.4,
32+ GHC==8.10.7,
33+ GHC==9.0.2,
34+ GHC==9.2.3,
35+ GHC==9.4.1
36+
19flag use-text-show
37flag use-text-show
20 description: Use text-show library for efficient ToHttpApiData implementations.
38 description: Use text-show library for efficient ToHttpApiData implementations.
21 default: False
39 default: False
40+ manual: True
22
41
23library
42library
24 hs-source-dirs: src/
43 hs-source-dirs: src/
44+ include-dirs: include/
45+
46+ -- GHC bundled
25− build-depends: base >= 4.6 && < 4.10
47+ build-depends: base >= 4.9 && < 4.17
26− , bytestring
48+ , bytestring >= 0.10.8.1 && < 0.12
27− , containers
49+ , containers >= 0.5.7.1 && < 0.7
28− , hashable
29− , text >= 0.5
50+ , text >= 1.2.3.0 && < 1.3 || >=2.0 && <2.1
30− , time
51+ , transformers >= 0.5.2.0 && < 0.7
31− , time-locale-compat >=0.1.1.0 && <0.2
52+
53+ -- other-dependencies
54+ build-depends:
55+ attoparsec >= 0.13.2.2 && < 0.15
56+ , attoparsec-iso8601 >= 1.1.0.0 && < 1.2
57+ , base-compat >= 0.10.5 && < 0.13
58+ , cookie >= 0.4.3 && < 0.5
59+ , hashable >= 1.2.7.0 && < 1.5
60+ , http-types >= 0.12.3 && < 0.13
61+ , tagged >= 0.8.5 && < 0.9
62+ , time-compat >= 1.9.5 && < 1.10
32− , unordered-containers
63+ , unordered-containers >= 0.2.10.0 && < 0.3
33− , uri-bytestring
64+ , uuid-types >= 1.0.3 && < 1.1
65+
34 if flag(use-text-show)
66 if flag(use-text-show)
35 cpp-options: -DUSE_TEXT_SHOW
67 cpp-options: -DUSE_TEXT_SHOW
36− build-depends: text-show >= 2
68+ build-depends: text-show >= 3.8.2 && <3.10
69+
37 exposed-modules:
70 exposed-modules:
38 Web.HttpApiData
71 Web.HttpApiData
39 Web.FormUrlEncoded
72 Web.FormUrlEncoded
@@ -52,28 +85,26 @@ test-suite spec
52 hs-source-dirs: test
85 hs-source-dirs: test
53 ghc-options: -Wall
86 ghc-options: -Wall
54 default-language: Haskell2010
87 default-language: Haskell2010
55− build-depends: HUnit
88+ build-tool-depends: hspec-discover:hspec-discover >= 2.7.1 && <2.11
56− , hspec >= 1.3
89+ -- inherited depndencies
57− , base >= 4 && < 5
90+ build-depends:
91+ base
92+ , base-compat
58 , bytestring
93 , bytestring
59− , QuickCheck
94+ , cookie
60− , unordered-containers
61 , http-api-data
95 , http-api-data
62 , text
96 , text
63− , time
97+ , time-compat
64− , bytestring
98+ , unordered-containers
99+ , uuid-types
100+
101+ if !impl(ghc >= 7.10)
102+ build-depends: nats
65
103
66−test-suite doctest
67− ghc-options: -Wall
68− build-depends:
104+ build-depends: HUnit >= 1.6.0.0 && <1.7
69− base,
105+ , hspec >= 2.7.1 && <2.11
70− directory >= 1.0,
106+ , QuickCheck >= 2.13.1 && <2.15
71− doctest >= 0.11 && <0.12,
107+ , quickcheck-instances >= 0.3.25.2 && <0.4
72− filepath
73− default-language: Haskell2010
74− hs-source-dirs: test
75− main-is: DocTest.hs
76− type: exitcode-stdio-1.0
77
108
78source-repository head
109source-repository head
79 type: git
110 type: git
include/overlapping-compat.hnew file+8
@@ -0,0 +1,8 @@
1+#if __GLASGOW_HASKELL__ >= 710
2+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
3+#define OVERLAPPING_ {-# OVERLAPPING #-}
4+#else
5+{-# LANGUAGE OverlappingInstances #-}
6+#define OVERLAPPABLE_
7+#define OVERLAPPING_
8+#endif
src/Web/FormUrlEncoded.hs+17−1
@@ -9,27 +9,43 @@ module Web.FormUrlEncoded (
9 ToFormKey(..),
9 ToFormKey(..),
10 FromFormKey(..),
10 FromFormKey(..),
11
11
12+ -- * 'Form' type
13+ Form(..),
14+
12 -- * Encoding and decoding @'Form'@s
15 -- * Encoding and decoding @'Form'@s
13 urlEncodeAsForm,
16 urlEncodeAsForm,
17+ urlEncodeAsFormStable,
14 urlDecodeAsForm,
18 urlDecodeAsForm,
15
19
16 urlEncodeForm,
20 urlEncodeForm,
21+ urlEncodeFormStable,
17 urlDecodeForm,
22 urlDecodeForm,
18
23
19 -- * 'Generic's
24 -- * 'Generic's
20 genericToForm,
25 genericToForm,
21 genericFromForm,
26 genericFromForm,
22
27
28+ -- ** Encoding options
29+ FormOptions(..),
30+ defaultFormOptions,
31+
23 -- * Helpers
32 -- * Helpers
33+ toListStable,
24 toEntriesByKey,
34 toEntriesByKey,
35+ toEntriesByKeyStable,
25 fromEntriesByKey,
36 fromEntriesByKey,
26
37
27 lookupAll,
38 lookupAll,
39+ lookupMaybe,
28 lookupUnique,
40 lookupUnique,
29
41
30 parseAll,
42 parseAll,
43+ parseMaybe,
31 parseUnique,
44 parseUnique,
45+
46+ urlEncodeParams,
47+ urlDecodeParams,
32) where
48) where
33
49
34−import Web.Internal.FormUrlEncoded
50+import Web.Internal.FormUrlEncoded
35
51
src/Web/HttpApiData.hs+5−3
@@ -35,21 +35,23 @@ module Web.HttpApiData (
35 parseBoundedEnumOfI,
35 parseBoundedEnumOfI,
36 parseBoundedTextData,
36 parseBoundedTextData,
37
37
38+ -- * Lenient data
39+ LenientData (..),
40+
38 -- * Other helpers
41 -- * Other helpers
39 showTextData,
42 showTextData,
40 readTextData,
43 readTextData,
41) where
44) where
42
45
43−import Web.Internal.HttpApiData
46+import Web.Internal.HttpApiData
44
47
45-- $setup
48-- $setup
46--
49--
47-- >>> :set -XOverloadedStrings
50-- >>> :set -XOverloadedStrings
48-- >>> import Control.Applicative
51-- >>> import Control.Applicative
49−-- >>> import Data.Time
52+-- >>> import Data.Time.Compat
50-- >>> import Data.Int
53-- >>> import Data.Int
51-- >>> import Data.Text (Text)
54-- >>> import Data.Text (Text)
52−-- >>> import Data.Time (Day)
53-- >>> import Data.Version
55-- >>> import Data.Version
54
56
55-- $examples
57-- $examples
src/Web/Internal/FormUrlEncoded.hs+305−78
@@ -1,3 +1,4 @@
1+{-# LANGUAGE ConstraintKinds #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE DefaultSignatures #-}
@@ -13,56 +14,54 @@
13{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE UndecidableInstances #-}
16{-# LANGUAGE UndecidableInstances #-}
17+#include "overlapping-compat.h"
16module Web.Internal.FormUrlEncoded where
18module Web.Internal.FormUrlEncoded where
17
19
18−#if __GLASGOW_HASKELL__ < 710
20+import Prelude ()
19−import Control.Applicative
21+import Prelude.Compat
20−import Data.Traversable
21−#endif
22−
23−#if __GLASGOW_HASKELL__ < 800
24−import GHC.Exts (IsList (..))
25−#else
26−import GHC.Exts (IsList (..), Constraint)
27−import GHC.TypeLits
28−#endif
29
22
23+import Control.Applicative (Const(Const))
30import Control.Arrow ((***))
24import Control.Arrow ((***))
31import Control.Monad ((<=<))
25import Control.Monad ((<=<))
32−import Data.ByteString.Builder (toLazyByteString, shortByteString)
26+import Data.ByteString.Builder (shortByteString, toLazyByteString)
33import qualified Data.ByteString.Lazy as BSL
27import qualified Data.ByteString.Lazy as BSL
34import qualified Data.ByteString.Lazy.Char8 as BSL8
28import qualified Data.ByteString.Lazy.Char8 as BSL8
29+import Data.Coerce (coerce)
35import qualified Data.Foldable as F
30import qualified Data.Foldable as F
31+import Data.Functor.Identity (Identity(Identity))
36import Data.Hashable (Hashable)
32import Data.Hashable (Hashable)
37import Data.HashMap.Strict (HashMap)
33import Data.HashMap.Strict (HashMap)
38import qualified Data.HashMap.Strict as HashMap
34import qualified Data.HashMap.Strict as HashMap
39−import Data.Int
35+import Data.Int (Int16, Int32, Int64, Int8)
40import Data.IntMap (IntMap)
36import Data.IntMap (IntMap)
41import qualified Data.IntMap as IntMap
37import qualified Data.IntMap as IntMap
42−import Data.List (intersperse)
38+import Data.List (intersperse, sortBy)
43import Data.Map (Map)
39import Data.Map (Map)
44import qualified Data.Map as Map
40import qualified Data.Map as Map
45−import Data.Monoid
41+import Data.Monoid (All (..), Any (..), Dual (..),
46−
42+ Product (..), Sum (..))
43+import Data.Ord (comparing)
44+import Data.Proxy (Proxy (..))
45+import Data.Semigroup (Semigroup (..))
46+import qualified Data.Semigroup as Semi
47+import Data.Tagged (Tagged (..))
47import Data.Text (Text)
48import Data.Text (Text)
48import qualified Data.Text as Text
49import qualified Data.Text as Text
49−import qualified Data.Text.Lazy as Lazy
50+import qualified Data.Text.Encoding as Text
50−import Data.Text.Encoding as Text
51import Data.Text.Encoding.Error (lenientDecode)
51import Data.Text.Encoding.Error (lenientDecode)
52−
52+import qualified Data.Text.Lazy as Lazy
53+import Data.Time.Compat (Day, LocalTime, NominalDiffTime,
54+ UTCTime, ZonedTime)
55+import Data.Time.Calendar.Month.Compat (Month)
53−import Data.Time
56+import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..))
54−import Data.Proxy
57+import Data.Void (Void)
55−import Data.Word
58+import Data.Word (Word16, Word32, Word64, Word8)
56−
59+import GHC.Exts (Constraint, IsList (..))
57−#if MIN_VERSION_base(4,8,0)
58−import Data.Void
59−import Numeric.Natural
60−#endif
61−
62import GHC.Generics
60import GHC.Generics
63−import URI.ByteString (urlEncodeQuery, urlDecodeQuery)
61+import GHC.TypeLits
64−
62+import Network.HTTP.Types.URI (urlDecode, urlEncodeBuilder)
63+import Numeric.Natural (Natural)
65−import Web.Internal.HttpApiData
64+import Web.Internal.HttpApiData
66
65
67-- $setup
66-- $setup
68-- >>> :set -XDeriveGeneric
67-- >>> :set -XDeriveGeneric
@@ -71,11 +70,20 @@ import Web.Internal.HttpApiData
71-- >>> :set -XFlexibleContexts
70-- >>> :set -XFlexibleContexts
72-- >>> :set -XScopedTypeVariables
71-- >>> :set -XScopedTypeVariables
73-- >>> :set -XTypeFamilies
72-- >>> :set -XTypeFamilies
74−-- >>> import Data.Either (isLeft)
73+-- >>> import Data.Char (toLower)
75−-- >>> import Data.List (sort)
74+--
76-- >>> data Person = Person { name :: String, age :: Int } deriving (Show, Generic)
75-- >>> data Person = Person { name :: String, age :: Int } deriving (Show, Generic)
77-- >>> instance ToForm Person
76-- >>> instance ToForm Person
78-- >>> instance FromForm Person
77-- >>> instance FromForm Person
78+--
79+-- >>> data Post = Post { title :: String, subtitle :: Maybe String, comments :: [String]} deriving (Generic, Show)
80+-- >>> instance ToForm Post
81+-- >>> instance FromForm Post
82+--
83+-- >>> data Project = Project { projectName :: String, projectSize :: Int } deriving (Generic, Show)
84+-- >>> let myOptions = FormOptions { fieldLabelModifier = map toLower . drop (length ("project" :: String)) }
85+-- >>> instance ToForm Project where toForm = genericToForm myOptions
86+-- >>> instance FromForm Project where fromForm = genericFromForm myOptions
79
87
80-- | Typeclass for types that can be used as keys in a 'Form'-like container (like 'Map').
88-- | Typeclass for types that can be used as keys in a 'Form'-like container (like 'Map').
81class ToFormKey k where
89class ToFormKey k where
@@ -107,6 +115,9 @@ instance ToFormKey LocalTime where toFormKey = toQueryParam
107instance ToFormKey ZonedTime where toFormKey = toQueryParam
115instance ToFormKey ZonedTime where toFormKey = toQueryParam
108instance ToFormKey UTCTime where toFormKey = toQueryParam
116instance ToFormKey UTCTime where toFormKey = toQueryParam
109instance ToFormKey NominalDiffTime where toFormKey = toQueryParam
117instance ToFormKey NominalDiffTime where toFormKey = toQueryParam
118+instance ToFormKey Quarter where toFormKey = toQueryParam
119+instance ToFormKey QuarterOfYear where toFormKey = toQueryParam
120+instance ToFormKey Month where toFormKey = toQueryParam
110
121
111instance ToFormKey String where toFormKey = toQueryParam
122instance ToFormKey String where toFormKey = toQueryParam
112instance ToFormKey Text where toFormKey = toQueryParam
123instance ToFormKey Text where toFormKey = toQueryParam
@@ -115,14 +126,26 @@ instance ToFormKey Lazy.Text where toFormKey = toQueryParam
115instance ToFormKey All where toFormKey = toQueryParam
126instance ToFormKey All where toFormKey = toQueryParam
116instance ToFormKey Any where toFormKey = toQueryParam
127instance ToFormKey Any where toFormKey = toQueryParam
117
128
118−instance ToFormKey a => ToFormKey (Dual a) where toFormKey = toFormKey . getDual
129+instance ToFormKey a => ToFormKey (Dual a) where toFormKey = coerce (toFormKey :: a -> Text)
119−instance ToFormKey a => ToFormKey (Sum a) where toFormKey = toFormKey . getSum
130+instance ToFormKey a => ToFormKey (Sum a) where toFormKey = coerce (toFormKey :: a -> Text)
120−instance ToFormKey a => ToFormKey (Product a) where toFormKey = toFormKey . getProduct
131+instance ToFormKey a => ToFormKey (Product a) where toFormKey = coerce (toFormKey :: a -> Text)
132+
133+instance ToFormKey a => ToFormKey (Semi.Min a) where toFormKey = coerce (toFormKey :: a -> Text)
134+instance ToFormKey a => ToFormKey (Semi.Max a) where toFormKey = coerce (toFormKey :: a -> Text)
135+instance ToFormKey a => ToFormKey (Semi.First a) where toFormKey = coerce (toFormKey :: a -> Text)
136+instance ToFormKey a => ToFormKey (Semi.Last a) where toFormKey = coerce (toFormKey :: a -> Text)
137+
138+instance ToFormKey a => ToFormKey (Tagged b a) where toFormKey = coerce (toFormKey :: a -> Text)
139+
140+-- | @since 0.4.2
141+instance ToFormKey a => ToFormKey (Identity a) where toFormKey = coerce (toFormKey :: a -> Text)
142+
143+-- | @since 0.4.2
144+instance ToFormKey a => ToFormKey (Const a b) where
145+ toFormKey = coerce (toFormKey :: a -> Text)
121
146
122−#if MIN_VERSION_base(4,8,0)
123instance ToFormKey Void where toFormKey = toQueryParam
147instance ToFormKey Void where toFormKey = toQueryParam
124instance ToFormKey Natural where toFormKey = toQueryParam
148instance ToFormKey Natural where toFormKey = toQueryParam
125−#endif
126
149
127-- | Typeclass for types that can be parsed from keys of a 'Form'. This is the reverse of 'ToFormKey'.
150-- | Typeclass for types that can be parsed from keys of a 'Form'. This is the reverse of 'ToFormKey'.
128class FromFormKey k where
151class FromFormKey k where
@@ -154,6 +177,9 @@ instance FromFormKey LocalTime where parseFormKey = parseQueryParam
154instance FromFormKey ZonedTime where parseFormKey = parseQueryParam
177instance FromFormKey ZonedTime where parseFormKey = parseQueryParam
155instance FromFormKey UTCTime where parseFormKey = parseQueryParam
178instance FromFormKey UTCTime where parseFormKey = parseQueryParam
156instance FromFormKey NominalDiffTime where parseFormKey = parseQueryParam
179instance FromFormKey NominalDiffTime where parseFormKey = parseQueryParam
180+instance FromFormKey Quarter where parseFormKey = parseQueryParam
181+instance FromFormKey QuarterOfYear where parseFormKey = parseQueryParam
182+instance FromFormKey Month where parseFormKey = parseQueryParam
157
183
158instance FromFormKey String where parseFormKey = parseQueryParam
184instance FromFormKey String where parseFormKey = parseQueryParam
159instance FromFormKey Text where parseFormKey = parseQueryParam
185instance FromFormKey Text where parseFormKey = parseQueryParam
@@ -162,30 +188,48 @@ instance FromFormKey Lazy.Text where parseFormKey = parseQueryParam
162instance FromFormKey All where parseFormKey = parseQueryParam
188instance FromFormKey All where parseFormKey = parseQueryParam
163instance FromFormKey Any where parseFormKey = parseQueryParam
189instance FromFormKey Any where parseFormKey = parseQueryParam
164
190
165−instance FromFormKey a => FromFormKey (Dual a) where parseFormKey = fmap Dual . parseFormKey
191+instance FromFormKey a => FromFormKey (Dual a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
166−instance FromFormKey a => FromFormKey (Sum a) where parseFormKey = fmap Sum . parseFormKey
192+instance FromFormKey a => FromFormKey (Sum a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
193+instance FromFormKey a => FromFormKey (Product a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
194+
195+instance FromFormKey a => FromFormKey (Semi.Min a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
196+instance FromFormKey a => FromFormKey (Semi.Max a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
167−instance FromFormKey a => FromFormKey (Product a) where parseFormKey = fmap Product . parseFormKey
197+instance FromFormKey a => FromFormKey (Semi.First a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
198+instance FromFormKey a => FromFormKey (Semi.Last a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
199+
200+instance FromFormKey a => FromFormKey (Tagged b a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
201+
202+-- | @since 0.4.2
203+instance FromFormKey a => FromFormKey (Identity a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
204+
205+-- | @since 0.4.2
206+instance FromFormKey a => FromFormKey (Const a b) where
207+ parseFormKey = coerce (parseFormKey :: Text -> Either Text a)
168
208
169−#if MIN_VERSION_base(4,8,0)
170instance FromFormKey Void where parseFormKey = parseQueryParam
209instance FromFormKey Void where parseFormKey = parseQueryParam
171instance FromFormKey Natural where parseFormKey = parseQueryParam
210instance FromFormKey Natural where parseFormKey = parseQueryParam
172−#endif
173
211
174-- | The contents of a form, not yet URL-encoded.
212-- | The contents of a form, not yet URL-encoded.
175--
213--
176-- 'Form' can be URL-encoded with 'urlEncodeForm' and URL-decoded with 'urlDecodeForm'.
214-- 'Form' can be URL-encoded with 'urlEncodeForm' and URL-decoded with 'urlDecodeForm'.
177newtype Form = Form { unForm :: HashMap Text [Text] }
215newtype Form = Form { unForm :: HashMap Text [Text] }
178− deriving (Eq, Read, Generic, Monoid)
216+ deriving (Eq, Read, Generic, Semigroup, Monoid)
179
217
180instance Show Form where
218instance Show Form where
181 showsPrec d form = showParen (d > 10) $
219 showsPrec d form = showParen (d > 10) $
182− showString "fromList " . shows (toList form)
220+ showString "fromList " . shows (toListStable form)
183
221
222+-- | _NOTE:_ 'toList' is unstable and may result in different key order (but not values).
223+-- For a stable conversion use 'toListStable'.
184instance IsList Form where
224instance IsList Form where
185 type Item Form = (Text, Text)
225 type Item Form = (Text, Text)
186 fromList = Form . HashMap.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v]))
226 fromList = Form . HashMap.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v]))
187 toList = concatMap (\(k, vs) -> map ((,) k) vs) . HashMap.toList . unForm
227 toList = concatMap (\(k, vs) -> map ((,) k) vs) . HashMap.toList . unForm
188
228
229+-- | A stable version of 'toList'.
230+toListStable :: Form -> [(Text, Text)]
231+toListStable = sortOn fst . toList
232+
189-- | Convert a value into 'Form'.
233-- | Convert a value into 'Form'.
190--
234--
191-- An example type and instance:
235-- An example type and instance:
@@ -222,7 +266,6 @@ instance IsList Form where
222-- @
266-- @
223--
267--
224-- The default implementation of 'toForm' is 'genericToForm'.
268-- The default implementation of 'toForm' is 'genericToForm'.
225−-- It only works for records and it will use 'toQueryParam' for each field's value.
226class ToForm a where
269class ToForm a where
227 -- | Convert a value into 'Form'.
270 -- | Convert a value into 'Form'.
228 toForm :: a -> Form
271 toForm :: a -> Form
@@ -254,6 +297,8 @@ data Proxy3 a b c = Proxy3
254
297
255type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint where
298type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint where
256#if __GLASGOW_HASKELL__ < 800
299#if __GLASGOW_HASKELL__ < 800
300+ -- this is just a placeholder case for older GHCs to not freak out on an empty closed type family
301+ NotSupported cls a "this type family is actually empty" = ()
257#else
302#else
258 NotSupported cls a reason = TypeError
303 NotSupported cls a reason = TypeError
259 ( 'Text "Cannot derive a Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instance for " ':<>: 'ShowType a ':<>: 'Text "." ':$$:
304 ( 'Text "Cannot derive a Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instance for " ':<>: 'ShowType a ':<>: 'Text "." ':$$:
@@ -273,6 +318,30 @@ type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint
273-- , age :: Int
318-- , age :: Int
274-- } deriving ('Generic')
319-- } deriving ('Generic')
275-- @
320-- @
321+--
322+-- In this implementation each field's value gets encoded using `toQueryParam`.
323+-- Two field types are exceptions:
324+--
325+-- - for values of type @'Maybe' a@ an entry is added to the 'Form' only when it is @'Just' x@
326+-- and the encoded value is @'toQueryParam' x@; 'Nothing' values are omitted from the 'Form';
327+--
328+-- - for values of type @[a]@ (except @['Char']@) an entry is added for every item in the list;
329+-- if the list is empty no entries are added to the 'Form';
330+--
331+-- Here's an example:
332+--
333+-- @
334+-- data Post = Post
335+-- { title :: String
336+-- , subtitle :: Maybe String
337+-- , comments :: [String]
338+-- } deriving ('Generic', 'Show')
339+--
340+-- instance 'ToForm' Post
341+-- @
342+--
343+-- >>> urlEncodeAsFormStable Post { title = "Test", subtitle = Nothing, comments = ["Nice post!", "+1"] }
344+-- "comments=Nice%20post%21&comments=%2B1&title=Test"
276genericToForm :: forall a. (Generic a, GToForm a (Rep a)) => FormOptions -> a -> Form
345genericToForm :: forall a. (Generic a, GToForm a (Rep a)) => FormOptions -> a -> Form
277genericToForm opts = gToForm (Proxy :: Proxy a) opts . from
346genericToForm opts = gToForm (Proxy :: Proxy a) opts . from
278
347
@@ -288,7 +357,25 @@ instance (GToForm t f) => GToForm t (M1 D x f) where
288instance (GToForm t f) => GToForm t (M1 C x f) where
357instance (GToForm t f) => GToForm t (M1 C x f) where
289 gToForm p opts (M1 a) = gToForm p opts a
358 gToForm p opts (M1 a) = gToForm p opts a
290
359
360+instance OVERLAPPABLE_ (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i c)) where
361+ gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)]
362+ where
363+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
364+
291−instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i c)) where
365+instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i (Maybe c))) where
366+ gToForm _ opts (M1 (K1 c)) =
367+ case c of
368+ Nothing -> mempty
369+ Just x -> fromList [(key, toQueryParam x)]
370+ where
371+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
372+
373+instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i [c])) where
374+ gToForm _ opts (M1 (K1 cs)) = fromList (map (\c -> (key, toQueryParam c)) cs)
375+ where
376+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
377+
378+instance OVERLAPPING_ (Selector s) => GToForm t (M1 S s (K1 i String)) where
292 gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)]
379 gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)]
293 where
380 where
294 key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
381 key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
@@ -305,9 +392,9 @@ instance NotSupported ToForm t "is a sum type" => GToForm t (f :+: g) where gToF
305-- , age :: Int }
392-- , age :: Int }
306--
393--
307-- instance 'FromForm' Person where
394-- instance 'FromForm' Person where
308−-- 'fromForm' (Form m) = Person
395+-- 'fromForm' f = Person
309−-- '<$>' 'parseUnique' "name" m
396+-- '<$>' 'parseUnique' "name" f
310−-- '<*>' 'parseUnique' "age" m
397+-- '<*>' 'parseUnique' "age" f
311-- @
398-- @
312--
399--
313-- Instead of manually writing @'FromForm'@ instances you can
400-- Instead of manually writing @'FromForm'@ instances you can
@@ -338,6 +425,7 @@ class FromForm a where
338
425
339instance FromForm Form where fromForm = pure
426instance FromForm Form where fromForm = pure
340
427
428+-- | _NOTE:_ this conversion is unstable and may result in different key order (but not values).
341instance (FromFormKey k, FromHttpApiData v) => FromForm [(k, v)] where
429instance (FromFormKey k, FromHttpApiData v) => FromForm [(k, v)] where
342 fromForm = fmap (concatMap (\(k, vs) -> map ((,) k) vs)) . toEntriesByKey
430 fromForm = fmap (concatMap (\(k, vs) -> map ((,) k) vs)) . toEntriesByKey
343
431
@@ -352,13 +440,22 @@ instance FromHttpApiData v => FromForm (IntMap [v]) where
352
440
353-- | Parse a 'Form' into a list of entries groupped by key.
441-- | Parse a 'Form' into a list of entries groupped by key.
354--
442--
355−-- >>> toEntriesByKey [("name", "Nick"), ("color", "red"), ("color", "white")] :: Either Text [(Text, [Text])]
443+-- _NOTE:_ this conversion is unstable and may result in different key order
356−-- Right [("color",["red","white"]),("name",["Nick"])]
444+-- (but not values). For a stable encoding see 'toEntriesByKeyStable'.
357toEntriesByKey :: (FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])]
445toEntriesByKey :: (FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])]
358toEntriesByKey = traverse parseGroup . HashMap.toList . unForm
446toEntriesByKey = traverse parseGroup . HashMap.toList . unForm
359 where
447 where
360 parseGroup (k, vs) = (,) <$> parseFormKey k <*> traverse parseQueryParam vs
448 parseGroup (k, vs) = (,) <$> parseFormKey k <*> traverse parseQueryParam vs
361
449
450+-- | Parse a 'Form' into a list of entries groupped by key.
451+--
452+-- >>> toEntriesByKeyStable [("name", "Nick"), ("color", "red"), ("color", "white")] :: Either Text [(Text, [Text])]
453+-- Right [("color",["red","white"]),("name",["Nick"])]
454+--
455+-- For an unstable (but faster) conversion see 'toEntriesByKey'.
456+toEntriesByKeyStable :: (Ord k, FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])]
457+toEntriesByKeyStable = fmap (sortOn fst) . toEntriesByKey
458+
362-- | A 'Generic'-based implementation of 'fromForm'.
459-- | A 'Generic'-based implementation of 'fromForm'.
363-- This is used as a default implementation in 'FromForm'.
460-- This is used as a default implementation in 'FromForm'.
364--
461--
@@ -370,6 +467,29 @@ toEntriesByKey = traverse parseGroup . HashMap.toList . unForm
370-- , age :: Int
467-- , age :: Int
371-- } deriving ('Generic')
468-- } deriving ('Generic')
372-- @
469-- @
470+--
471+-- In this implementation each field's value gets decoded using `parseQueryParam`.
472+-- Two field types are exceptions:
473+--
474+-- - for values of type @'Maybe' a@ an entry is parsed if present in the 'Form'
475+-- and the is decoded with 'parseQueryParam'; if no entry is present result is 'Nothing';
476+--
477+-- - for values of type @[a]@ (except @['Char']@) all entries are parsed to produce a list of parsed values;
478+--
479+-- Here's an example:
480+--
481+-- @
482+-- data Post = Post
483+-- { title :: String
484+-- , subtitle :: Maybe String
485+-- , comments :: [String]
486+-- } deriving ('Generic', 'Show')
487+--
488+-- instance 'FromForm' Post
489+-- @
490+--
491+-- >>> urlDecodeAsForm "comments=Nice%20post%21&comments=%2B1&title=Test" :: Either Text Post
492+-- Right (Post {title = "Test", subtitle = Nothing, comments = ["Nice post!","+1"]})
373genericFromForm :: forall a. (Generic a, GFromForm a (Rep a)) => FormOptions -> Form -> Either Text a
493genericFromForm :: forall a. (Generic a, GFromForm a (Rep a)) => FormOptions -> Form -> Either Text a
374genericFromForm opts f = to <$> gFromForm (Proxy :: Proxy a) opts f
494genericFromForm opts f = to <$> gFromForm (Proxy :: Proxy a) opts f
375
495
@@ -379,54 +499,83 @@ class GFromForm t (f :: * -> *) where
379instance (GFromForm t f, GFromForm t g) => GFromForm t (f :*: g) where
499instance (GFromForm t f, GFromForm t g) => GFromForm t (f :*: g) where
380 gFromForm p opts f = (:*:) <$> gFromForm p opts f <*> gFromForm p opts f
500 gFromForm p opts f = (:*:) <$> gFromForm p opts f <*> gFromForm p opts f
381
501
382−instance (Selector s, FromHttpApiData f) => GFromForm t (M1 S s (K1 i f)) where
383− gFromForm _ opts form = M1 . K1 <$> parseUnique key form
384− where
385− key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
386−
387instance GFromForm t f => GFromForm t (M1 D x f) where
502instance GFromForm t f => GFromForm t (M1 D x f) where
388 gFromForm p opts f = M1 <$> gFromForm p opts f
503 gFromForm p opts f = M1 <$> gFromForm p opts f
389
504
390instance GFromForm t f => GFromForm t (M1 C x f) where
505instance GFromForm t f => GFromForm t (M1 C x f) where
391 gFromForm p opts f = M1 <$> gFromForm p opts f
506 gFromForm p opts f = M1 <$> gFromForm p opts f
392
507
508+instance OVERLAPPABLE_ (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i c)) where
509+ gFromForm _ opts form = M1 . K1 <$> parseUnique key form
510+ where
511+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
512+
513+instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i (Maybe c))) where
514+ gFromForm _ opts form = M1 . K1 <$> parseMaybe key form
515+ where
516+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
517+
518+instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i [c])) where
519+ gFromForm _ opts form = M1 . K1 <$> parseAll key form
520+ where
521+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
522+
523+instance OVERLAPPING_ (Selector s) => GFromForm t (M1 S s (K1 i String)) where
524+ gFromForm _ opts form = M1 . K1 <$> parseUnique key form
525+ where
526+ key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)
527+
393instance NotSupported FromForm t "is a sum type" => GFromForm t (f :+: g) where gFromForm = error "impossible"
528instance NotSupported FromForm t "is a sum type" => GFromForm t (f :+: g) where gFromForm = error "impossible"
394
529
395-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
530-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
396--
531--
532+-- _NOTE:_ this encoding is unstable and may result in different key order
533+-- (but not values). For a stable encoding see 'urlEncodeFormStable'.
534+urlEncodeForm :: Form -> BSL.ByteString
535+urlEncodeForm = urlEncodeParams . toList
536+
537+-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
538+--
539+-- For an unstable (but faster) encoding see 'urlEncodeForm'.
540+--
397-- Key-value pairs get encoded to @key=value@ and separated by @&@:
541-- Key-value pairs get encoded to @key=value@ and separated by @&@:
398--
542--
399−-- >>> urlEncodeForm [("name", "Julian"), ("lastname", "Arni")]
543+-- >>> urlEncodeFormStable [("name", "Julian"), ("lastname", "Arni")]
400-- "lastname=Arni&name=Julian"
544-- "lastname=Arni&name=Julian"
401--
545--
402-- Keys with empty values get encoded to just @key@ (without the @=@ sign):
546-- Keys with empty values get encoded to just @key@ (without the @=@ sign):
403--
547--
404−-- >>> urlEncodeForm [("is_test", "")]
548+-- >>> urlEncodeFormStable [("is_test", "")]
405-- "is_test"
549-- "is_test"
406--
550--
407-- Empty keys are allowed too:
551-- Empty keys are allowed too:
408--
552--
409−-- >>> urlEncodeForm [("", "foobar")]
553+-- >>> urlEncodeFormStable [("", "foobar")]
410-- "=foobar"
554-- "=foobar"
411--
555--
412−-- However, if not key and value are empty, the key-value pair is ignored.
556+-- However, if both key and value are empty, the key-value pair is ignored.
413−-- (This prevents @'urlDecodeForm' . 'urlEncodeForm'@ from being a true isomorphism).
557+-- (This prevents @'urlDecodeForm' . 'urlEncodeFormStable'@ from being a true isomorphism).
414--
558--
415−-- >>> urlEncodeForm [("", "")]
559+-- >>> urlEncodeFormStable [("", "")]
416-- ""
560-- ""
417--
561--
418-- Everything is escaped with @'escapeURIString' 'isUnreserved'@:
562-- Everything is escaped with @'escapeURIString' 'isUnreserved'@:
419--
563--
420−-- >>> urlEncodeForm [("fullname", "Andres Löh")]
564+-- >>> urlEncodeFormStable [("fullname", "Andres Löh")]
421-- "fullname=Andres%20L%C3%B6h"
565-- "fullname=Andres%20L%C3%B6h"
422−urlEncodeForm :: Form -> BSL.ByteString
566+urlEncodeFormStable :: Form -> BSL.ByteString
567+urlEncodeFormStable = urlEncodeParams . sortOn fst . toList
568+
569+-- | Encode a list of key-value pairs to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
570+--
571+-- See also 'urlEncodeFormStable'.
572+urlEncodeParams :: [(Text, Text)] -> BSL.ByteString
423−urlEncodeForm = toLazyByteString . mconcat . intersperse (shortByteString "&") . map encodePair . toList
573+urlEncodeParams = toLazyByteString . mconcat . intersperse (shortByteString "&") . map encodePair
424 where
574 where
425− escape = urlEncodeQuery . Text.encodeUtf8
575+ escape = urlEncodeBuilder True . Text.encodeUtf8
426
576
427 encodePair (k, "") = escape k
577 encodePair (k, "") = escape k
428− encodePair (k, v) = escape k <> shortByteString "=" <> escape v
578+ encodePair (k, v) = escape k <> shortByteString "=" <> escape v
429−
430
579
431-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a 'Form'.
580-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a 'Form'.
432--
581--
@@ -460,11 +609,17 @@ urlEncodeForm = toLazyByteString . mconcat . intersperse (shortByteString "&") .
460-- >>> urlDecodeForm "this=has=too=many=equals"
609-- >>> urlDecodeForm "this=has=too=many=equals"
461-- Left "not a valid pair: this=has=too=many=equals"
610-- Left "not a valid pair: this=has=too=many=equals"
462urlDecodeForm :: BSL.ByteString -> Either Text Form
611urlDecodeForm :: BSL.ByteString -> Either Text Form
612+urlDecodeForm = fmap toForm . urlDecodeParams
613+
614+-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a list of key-value pairs.
615+--
616+-- See also 'urlDecodeForm'.
617+urlDecodeParams :: BSL.ByteString -> Either Text [(Text, Text)]
463−urlDecodeForm bs = toForm <$> traverse parsePair pairs
618+urlDecodeParams bs = traverse parsePair pairs
464 where
619 where
465 pairs = map (BSL8.split '=') (BSL8.split '&' bs)
620 pairs = map (BSL8.split '=') (BSL8.split '&' bs)
466
621
467− unescape = Text.decodeUtf8With lenientDecode . urlDecodeQuery . BSL.toStrict
622+ unescape = Text.decodeUtf8With lenientDecode . urlDecode True . BSL.toStrict
468
623
469 parsePair p =
624 parsePair p =
470 case map unescape p of
625 case map unescape p of
@@ -472,6 +627,7 @@ urlDecodeForm bs = toForm <$> traverse parsePair pairs
472 [k] -> return (k, "")
627 [k] -> return (k, "")
473 xs -> Left $ "not a valid pair: " <> Text.intercalate "=" xs
628 xs -> Left $ "not a valid pair: " <> Text.intercalate "=" xs
474
629
630+
475-- | This is a convenience function for decoding a
631-- | This is a convenience function for decoding a
476-- @application/x-www-form-urlencoded@ 'BSL.ByteString' directly to a datatype
632-- @application/x-www-form-urlencoded@ 'BSL.ByteString' directly to a datatype
477-- that has an instance of 'FromForm'.
633-- that has an instance of 'FromForm'.
@@ -489,11 +645,22 @@ urlDecodeAsForm = fromForm <=< urlDecodeForm
489--
645--
490-- This is effectively @'urlEncodeForm' . 'toForm'@.
646-- This is effectively @'urlEncodeForm' . 'toForm'@.
491--
647--
492−-- >>> urlEncodeAsForm Person {name = "Dennis", age = 22}
648+-- _NOTE:_ this encoding is unstable and may result in different key order
493−-- "age=22&name=Dennis"
649+-- (but not values). For a stable encoding see 'urlEncodeAsFormStable'.
494urlEncodeAsForm :: ToForm a => a -> BSL.ByteString
650urlEncodeAsForm :: ToForm a => a -> BSL.ByteString
495urlEncodeAsForm = urlEncodeForm . toForm
651urlEncodeAsForm = urlEncodeForm . toForm
496
652
653+-- | This is a convenience function for encoding a datatype that has instance
654+-- of 'ToForm' directly to a @application/x-www-form-urlencoded@
655+-- 'BSL.ByteString'.
656+--
657+-- This is effectively @'urlEncodeFormStable' . 'toForm'@.
658+--
659+-- >>> urlEncodeAsFormStable Person {name = "Dennis", age = 22}
660+-- "age=22&name=Dennis"
661+urlEncodeAsFormStable :: ToForm a => a -> BSL.ByteString
662+urlEncodeAsFormStable = urlEncodeFormStable . toForm
663+
497-- | Find all values corresponding to a given key in a 'Form'.
664-- | Find all values corresponding to a given key in a 'Form'.
498--
665--
499-- >>> lookupAll "name" []
666-- >>> lookupAll "name" []
@@ -505,6 +672,22 @@ urlEncodeAsForm = urlEncodeForm . toForm
505lookupAll :: Text -> Form -> [Text]
672lookupAll :: Text -> Form -> [Text]
506lookupAll key = F.concat . HashMap.lookup key . unForm
673lookupAll key = F.concat . HashMap.lookup key . unForm
507
674
675+-- | Lookup an optional value for a key.
676+-- Fail if there is more than one value.
677+--
678+-- >>> lookupMaybe "name" []
679+-- Right Nothing
680+-- >>> lookupMaybe "name" [("name", "Oleg")]
681+-- Right (Just "Oleg")
682+-- >>> lookupMaybe "name" [("name", "Oleg"), ("name", "David")]
683+-- Left "Duplicate key \"name\""
684+lookupMaybe :: Text -> Form -> Either Text (Maybe Text)
685+lookupMaybe key form =
686+ case lookupAll key form of
687+ [] -> pure Nothing
688+ [v] -> pure (Just v)
689+ _ -> Left $ "Duplicate key " <> Text.pack (show key)
690+
508-- | Lookup a unique value for a key.
691-- | Lookup a unique value for a key.
509-- Fail if there is zero or more than one value.
692-- Fail if there is zero or more than one value.
510--
693--
@@ -515,11 +698,11 @@ lookupAll key = F.concat . HashMap.lookup key . unForm
515-- >>> lookupUnique "name" [("name", "Oleg"), ("name", "David")]
698-- >>> lookupUnique "name" [("name", "Oleg"), ("name", "David")]
516-- Left "Duplicate key \"name\""
699-- Left "Duplicate key \"name\""
517lookupUnique :: Text -> Form -> Either Text Text
700lookupUnique :: Text -> Form -> Either Text Text
518−lookupUnique key form =
701+lookupUnique key form = do
702+ mv <- lookupMaybe key form
519− case lookupAll key form of
703+ case mv of
520− [v] -> pure v
704+ Just v -> pure v
521− [] -> Left $ "Could not find key " <> Text.pack (show key)
705+ Nothing -> Left $ "Could not find key " <> Text.pack (show key)
522− _ -> Left $ "Duplicate key " <> Text.pack (show key)
523
706
524-- | Lookup all values for a given key in a 'Form' and parse them with 'parseQueryParams'.
707-- | Lookup all values for a given key in a 'Form' and parse them with 'parseQueryParams'.
525--
708--
@@ -534,6 +717,22 @@ lookupUnique key form =
534parseAll :: FromHttpApiData v => Text -> Form -> Either Text [v]
717parseAll :: FromHttpApiData v => Text -> Form -> Either Text [v]
535parseAll key = parseQueryParams . lookupAll key
718parseAll key = parseQueryParams . lookupAll key
536
719
720+-- | Lookup an optional value for a given key and parse it with 'parseQueryParam'.
721+-- Fail if there is more than one value for the key.
722+--
723+-- >>> parseMaybe "age" [] :: Either Text (Maybe Word8)
724+-- Right Nothing
725+-- >>> parseMaybe "age" [("age", "12"), ("age", "25")] :: Either Text (Maybe Word8)
726+-- Left "Duplicate key \"age\""
727+-- >>> parseMaybe "age" [("age", "seven")] :: Either Text (Maybe Word8)
728+-- Left "could not parse: `seven' (input does not start with a digit)"
729+-- >>> parseMaybe "age" [("age", "777")] :: Either Text (Maybe Word8)
730+-- Left "out of bounds: `777' (should be between 0 and 255)"
731+-- >>> parseMaybe "age" [("age", "7")] :: Either Text (Maybe Word8)
732+-- Right (Just 7)
733+parseMaybe :: FromHttpApiData v => Text -> Form -> Either Text (Maybe v)
734+parseMaybe key = parseQueryParams <=< lookupMaybe key
735+
537-- | Lookup a unique value for a given key and parse it with 'parseQueryParam'.
736-- | Lookup a unique value for a given key and parse it with 'parseQueryParam'.
538-- Fail if there is zero or more than one value for the key.
737-- Fail if there is zero or more than one value for the key.
539--
738--
@@ -551,6 +750,31 @@ parseUnique :: FromHttpApiData v => Text -> Form -> Either Text v
551parseUnique key form = lookupUnique key form >>= parseQueryParam
750parseUnique key form = lookupUnique key form >>= parseQueryParam
552
751
553-- | 'Generic'-based deriving options for 'ToForm' and 'FromForm'.
752-- | 'Generic'-based deriving options for 'ToForm' and 'FromForm'.
753+--
754+-- A common use case for non-default 'FormOptions'
755+-- is to strip a prefix off of field labels:
756+--
757+-- @
758+-- data Project = Project
759+-- { projectName :: String
760+-- , projectSize :: Int
761+-- } deriving ('Generic', 'Show')
762+--
763+-- myOptions :: 'FormOptions'
764+-- myOptions = 'FormOptions'
765+-- { 'fieldLabelModifier' = 'map' 'toLower' . 'drop' ('length' \"project\") }
766+--
767+-- instance 'ToForm' Project where
768+-- 'toForm' = 'genericToForm' myOptions
769+--
770+-- instance 'FromForm' Project where
771+-- 'fromForm' = 'genericFromForm' myOptions
772+-- @
773+--
774+-- >>> urlEncodeAsFormStable Project { projectName = "http-api-data", projectSize = 172 }
775+-- "name=http-api-data&size=172"
776+-- >>> urlDecodeAsForm "name=http-api-data&size=172" :: Either Text Project
777+-- Right (Project {projectName = "http-api-data", projectSize = 172})
554data FormOptions = FormOptions
778data FormOptions = FormOptions
555 { -- | Function applied to field labels. Handy for removing common record prefixes for example.
779 { -- | Function applied to field labels. Handy for removing common record prefixes for example.
556 fieldLabelModifier :: String -> String
780 fieldLabelModifier :: String -> String
@@ -567,3 +791,6 @@ defaultFormOptions :: FormOptions
567defaultFormOptions = FormOptions
791defaultFormOptions = FormOptions
568 { fieldLabelModifier = id
792 { fieldLabelModifier = id
569 }
793 }
794+
795+sortOn :: Ord b => (a -> b) -> [a] -> [a]
796+sortOn f = sortBy (comparing f)
src/Web/Internal/HttpApiData.hs+387−99
@@ -1,54 +1,86 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DefaultSignatures #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE DeriveFoldable #-}
5+{-# LANGUAGE DeriveFunctor #-}
6+{-# LANGUAGE DeriveTraversable #-}
3−{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE KindSignatures #-}
4−{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TypeSynonymInstances #-}
12{-# LANGUAGE TypeSynonymInstances #-}
7-- |
13-- |
8-- Convert Haskell values to and from HTTP API data
14-- Convert Haskell values to and from HTTP API data
9-- such as URL pieces, headers and query parameters.
15-- such as URL pieces, headers and query parameters.
10module Web.Internal.HttpApiData where
16module Web.Internal.HttpApiData where
11
17
12−#if __GLASGOW_HASKELL__ < 710
18+import Prelude ()
19+import Prelude.Compat
20+
13−import Control.Applicative
21+import Control.Applicative (Const(Const))
14−import Data.Traversable (Traversable(traverse))
15−#endif
16−
17−import Control.Arrow ((&&&), left)
22+import Control.Arrow (left, (&&&))
18−import Control.Monad ((<=<))
23+import Control.Monad ((<=<))
19−
24+import qualified Data.Attoparsec.Text as Atto
25+import qualified Data.Attoparsec.Time as Atto
26+import Data.ByteString (ByteString)
27+import qualified Data.ByteString as BS
28+import qualified Data.ByteString.Builder as BS
29+import qualified Data.ByteString.Lazy as LBS
30+import Data.Coerce (coerce)
31+import Data.Data (Data)
32+import qualified Data.Fixed as F
33+import Data.Functor.Identity (Identity(Identity))
34+import Data.Int (Int16, Int32, Int64, Int8)
35+import Data.Kind (Type)
36+import qualified Data.Map as Map
20−import Data.Monoid
37+import Data.Monoid (All (..), Any (..), Dual (..),
21−import Data.ByteString (ByteString)
38+ First (..), Last (..),
39+ Product (..), Sum (..))
40+import Data.Semigroup (Semigroup (..))
22−import qualified Data.ByteString as BS
41+import qualified Data.Semigroup as Semi
23−
24−import Data.Int
42+import Data.Tagged (Tagged (..))
25−import Data.Word
26−
27−import Data.Text (Text)
43+import Data.Text (Text)
44+import qualified Data.Text as T
28−import Data.Text.Encoding (encodeUtf8, decodeUtf8')
45+import Data.Text.Encoding (decodeUtf8', decodeUtf8With,
29−import Data.Text.Read (signed, decimal, rational, Reader)
46+ encodeUtf8)
30−import qualified Data.Text as T
47+import Data.Text.Encoding.Error (lenientDecode)
31−import qualified Data.Text.Lazy as L
48+import qualified Data.Text.Lazy as L
32−
49+import Data.Text.Read (Reader, decimal, rational,
33−import Data.Time.Locale.Compat
50+ signed)
51+import Data.Time.Compat (Day, FormatTime, LocalTime,
52+ NominalDiffTime, TimeOfDay,
53+ UTCTime, ZonedTime, formatTime,
54+ DayOfWeek (..),
55+ nominalDiffTimeToSeconds,
56+ secondsToNominalDiffTime)
57+import Data.Time.Format.Compat (defaultTimeLocale,
58+ iso8601DateFormat)
59+import Data.Time.Calendar.Month.Compat (Month)
60+import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..),
61+ toYearQuarter)
62+import Data.Typeable (Typeable)
34−import Data.Time
63+import qualified Data.UUID.Types as UUID
35−import Data.Version
64+import Data.Version (Version, parseVersion,
36−
65+ showVersion)
37−#if MIN_VERSION_base(4,8,0)
66+import Data.Void (Void, absurd)
38−import Data.Void
67+import Data.Word (Word16, Word32, Word64, Word8)
68+import qualified Network.HTTP.Types as H
39−import Numeric.Natural
69+import Numeric.Natural (Natural)
40−#endif
41−
42−import Text.Read (readMaybe)
43−import Text.ParserCombinators.ReadP (readP_to_S)
70+import Text.ParserCombinators.ReadP (readP_to_S)
71+import Text.Read (readMaybe)
72+import Web.Cookie (SetCookie, parseSetCookie,
73+ renderSetCookie)
44
74
45#if USE_TEXT_SHOW
75#if USE_TEXT_SHOW
46−import TextShow (TextShow, showt)
76+import TextShow (TextShow, showt)
47#endif
77#endif
48
78
49-- $setup
79-- $setup
50-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
80-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
51-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
81-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
82+-- >>> import Data.Time.Compat
83+-- >>> import Data.Version
52
84
53-- | Convert value to HTTP API data.
85-- | Convert value to HTTP API data.
54--
86--
@@ -60,6 +92,12 @@ class ToHttpApiData a where
60 toUrlPiece :: a -> Text
92 toUrlPiece :: a -> Text
61 toUrlPiece = toQueryParam
93 toUrlPiece = toQueryParam
62
94
95+ -- | Convert to a URL path piece, making sure to encode any special chars.
96+ -- The default definition uses 'H.encodePathSegmentsRelative',
97+ -- but this may be overriden with a more efficient version.
98+ toEncodedUrlPiece :: a -> BS.Builder
99+ toEncodedUrlPiece = H.urlEncodeBuilder True . encodeUtf8 . toUrlPiece
100+
63 -- | Convert to HTTP header value.
101 -- | Convert to HTTP header value.
64 toHeader :: a -> ByteString
102 toHeader :: a -> ByteString
65 toHeader = encodeUtf8 . toUrlPiece
103 toHeader = encodeUtf8 . toUrlPiece
@@ -300,7 +338,7 @@ lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])
300-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool
338-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool
301-- Right True
339-- Right True
302--
340--
303−-- For case sensitive parser see 'parseBoundedEnumOfI'.
341+-- For case insensitive parser see 'parseBoundedEnumOfI'.
304parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
342parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
305parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
343parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
306
344
@@ -345,7 +383,7 @@ parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of
345-- Right 1991-06-02
383-- Right 1991-06-02
346--
384--
347-- This parser is case sensitive and will not match @'showTextData'@
385-- This parser is case sensitive and will not match @'showTextData'@
348−-- in presense of letters:
386+-- in presence of letters:
349--
387--
350-- >>> readTextData (showTextData True) :: Either Text Bool
388-- >>> readTextData (showTextData True) :: Either Text Bool
351-- Left "could not parse: `true'"
389-- Left "could not parse: `true'"
@@ -377,79 +415,193 @@ parseBounded reader input = do
377 l = toInteger (minBound :: a)
415 l = toInteger (minBound :: a)
378 h = toInteger (maxBound :: a)
416 h = toInteger (maxBound :: a)
379
417
418+-- | Convert to a URL-encoded path piece using 'toUrlPiece'.
419+-- /Note/: this function does not check if the result contains unescaped characters!
420+-- This function can be used to override 'toEncodedUrlPiece' as a more efficient implementation
421+-- when the resulting URL piece /never/ has to be escaped.
422+unsafeToEncodedUrlPiece :: ToHttpApiData a => a -> BS.Builder
423+unsafeToEncodedUrlPiece = BS.byteString . encodeUtf8 . toUrlPiece
424+
380-- |
425-- |
381-- >>> toUrlPiece ()
426-- >>> toUrlPiece ()
382-- "_"
427-- "_"
383instance ToHttpApiData () where
428instance ToHttpApiData () where
384 toUrlPiece () = "_"
429 toUrlPiece () = "_"
430+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
385
431
386−instance ToHttpApiData Char where toUrlPiece = T.singleton
432+instance ToHttpApiData Char where
433+ toUrlPiece = T.singleton
387
434
388-- |
435-- |
389-- >>> toUrlPiece (Version [1, 2, 3] [])
436-- >>> toUrlPiece (Version [1, 2, 3] [])
390-- "1.2.3"
437-- "1.2.3"
391instance ToHttpApiData Version where
438instance ToHttpApiData Version where
392 toUrlPiece = T.pack . showVersion
439 toUrlPiece = T.pack . showVersion
440+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
393
441
394−#if MIN_VERSION_base(4,8,0)
395instance ToHttpApiData Void where toUrlPiece = absurd
442instance ToHttpApiData Void where toUrlPiece = absurd
396−instance ToHttpApiData Natural where toUrlPiece = showt
443+instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
397−#endif
444+
398−
399−instance ToHttpApiData Bool where toUrlPiece = showTextData
445+instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
400−instance ToHttpApiData Ordering where toUrlPiece = showTextData
446+instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
401−
447+
402−instance ToHttpApiData Double where toUrlPiece = showt
448+instance ToHttpApiData Double where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
403−instance ToHttpApiData Float where toUrlPiece = showt
449+instance ToHttpApiData Float where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
404−instance ToHttpApiData Int where toUrlPiece = showt
450+instance ToHttpApiData Int where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
405−instance ToHttpApiData Int8 where toUrlPiece = showt
451+instance ToHttpApiData Int8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
406−instance ToHttpApiData Int16 where toUrlPiece = showt
452+instance ToHttpApiData Int16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
407−instance ToHttpApiData Int32 where toUrlPiece = showt
453+instance ToHttpApiData Int32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
408−instance ToHttpApiData Int64 where toUrlPiece = showt
454+instance ToHttpApiData Int64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
409−instance ToHttpApiData Integer where toUrlPiece = showt
455+instance ToHttpApiData Integer where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
410−instance ToHttpApiData Word where toUrlPiece = showt
456+instance ToHttpApiData Word where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
411−instance ToHttpApiData Word8 where toUrlPiece = showt
457+instance ToHttpApiData Word8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
412−instance ToHttpApiData Word16 where toUrlPiece = showt
458+instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
413−instance ToHttpApiData Word32 where toUrlPiece = showt
459+instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
414−instance ToHttpApiData Word64 where toUrlPiece = showt
460+instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
461+
462+-- | Note: this instance is not polykinded
463+instance F.HasResolution a => ToHttpApiData (F.Fixed (a :: Type)) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
415
464
416-- |
465-- |
417-- >>> toUrlPiece (fromGregorian 2015 10 03)
466-- >>> toUrlPiece (fromGregorian 2015 10 03)
418-- "2015-10-03"
467-- "2015-10-03"
419−instance ToHttpApiData Day where toUrlPiece = T.pack . show
468+instance ToHttpApiData Day where
469+ toUrlPiece = T.pack . show
470+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
420
471
421timeToUrlPiece :: FormatTime t => String -> t -> Text
472timeToUrlPiece :: FormatTime t => String -> t -> Text
422timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt))
473timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt))
423
474
424-- |
475-- |
425−-- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 01)
476+-- >>> toUrlPiece $ TimeOfDay 14 55 23.1
426−-- "2015-10-03T14:55:01"
477+-- "14:55:23.1"
427−instance ToHttpApiData LocalTime where toUrlPiece = timeToUrlPiece "%H:%M:%S"
478+instance ToHttpApiData TimeOfDay where
479+ toUrlPiece = T.pack . formatTime defaultTimeLocale "%H:%M:%S%Q"
480+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
428
481
429-- |
482-- |
430−-- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 01)) utc
483+-- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 21.687)
431−-- "2015-10-03T14:55:01+0000"
484+-- "2015-10-03T14:55:21.687"
485+instance ToHttpApiData LocalTime where
432−instance ToHttpApiData ZonedTime where toUrlPiece = timeToUrlPiece "%H:%M:%S%z"
486+ toUrlPiece = timeToUrlPiece "%H:%M:%S%Q"
487+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
433
488
434-- |
489-- |
435−-- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864
490+-- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) utc
436−-- "2015-10-03T00:14:24Z"
491+-- "2015-10-03T14:55:51.001+0000"
492+instance ToHttpApiData ZonedTime where
437−instance ToHttpApiData UTCTime where toUrlPiece = timeToUrlPiece "%H:%M:%SZ"
493+ toUrlPiece = timeToUrlPiece "%H:%M:%S%Q%z"
494+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
438
495
496+-- |
497+-- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864.5
498+-- "2015-10-03T00:14:24.5Z"
499+instance ToHttpApiData UTCTime where
500+ toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ"
501+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
502+
503+-- |
504+-- >>> toUrlPiece Monday
505+-- "monday"
506+instance ToHttpApiData DayOfWeek where
507+ toUrlPiece Monday = "monday"
508+ toUrlPiece Tuesday = "tuesday"
509+ toUrlPiece Wednesday = "wednesday"
510+ toUrlPiece Thursday = "thursday"
511+ toUrlPiece Friday = "friday"
512+ toUrlPiece Saturday = "saturday"
513+ toUrlPiece Sunday = "sunday"
514+
515+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
516+
517+-- |
518+-- >>> toUrlPiece Q4
519+-- "q4"
439−instance ToHttpApiData NominalDiffTime where toUrlPiece = toUrlPiece . (floor :: NominalDiffTime -> Integer)
520+instance ToHttpApiData QuarterOfYear where
521+ toUrlPiece Q1 = "q1"
522+ toUrlPiece Q2 = "q2"
523+ toUrlPiece Q3 = "q3"
524+ toUrlPiece Q4 = "q4"
525+
526+-- |
527+-- >>> import Data.Time.Calendar.Quarter.Compat (Quarter (..))
528+-- >>> MkQuarter 8040
529+-- 2010-Q1
530+--
531+-- >>> toUrlPiece $ MkQuarter 8040
532+-- "2010-q1"
533+--
534+instance ToHttpApiData Quarter where
535+ toUrlPiece q = case toYearQuarter q of
536+ (y, qoy) -> T.pack (show y ++ "-" ++ f qoy)
537+ where
538+ f Q1 = "q1"
539+ f Q2 = "q2"
540+ f Q3 = "q3"
541+ f Q4 = "q4"
542+
543+-- |
544+-- >>> import Data.Time.Calendar.Month.Compat (Month (..))
545+-- >>> MkMonth 24482
546+-- 2040-03
547+--
548+-- >>> toUrlPiece $ MkMonth 24482
549+-- "2040-03"
550+--
551+instance ToHttpApiData Month where
552+ toUrlPiece = T.pack . formatTime defaultTimeLocale "%Y-%m"
553+
554+instance ToHttpApiData NominalDiffTime where
555+ toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds
556+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
440
557
441instance ToHttpApiData String where toUrlPiece = T.pack
558instance ToHttpApiData String where toUrlPiece = T.pack
442instance ToHttpApiData Text where toUrlPiece = id
559instance ToHttpApiData Text where toUrlPiece = id
443instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
560instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
444
561
445−instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll
562+instance ToHttpApiData All where
563+ toUrlPiece = coerce (toUrlPiece :: Bool -> Text)
564+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)
565+
446−instance ToHttpApiData Any where toUrlPiece = toUrlPiece . getAny
566+instance ToHttpApiData Any where
567+ toUrlPiece = coerce (toUrlPiece :: Bool -> Text)
568+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)
569+
570+instance ToHttpApiData a => ToHttpApiData (Dual a) where
571+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
572+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
573+
574+instance ToHttpApiData a => ToHttpApiData (Sum a) where
575+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
576+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
577+
578+instance ToHttpApiData a => ToHttpApiData (Product a) where
579+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
580+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
581+
582+instance ToHttpApiData a => ToHttpApiData (First a) where
583+ toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
584+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)
447
585
448−instance ToHttpApiData a => ToHttpApiData (Dual a) where toUrlPiece = toUrlPiece . getDual
586+instance ToHttpApiData a => ToHttpApiData (Last a) where
587+ toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
588+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)
589+
449−instance ToHttpApiData a => ToHttpApiData (Sum a) where toUrlPiece = toUrlPiece . getSum
590+instance ToHttpApiData a => ToHttpApiData (Semi.Min a) where
591+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
592+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
593+
450−instance ToHttpApiData a => ToHttpApiData (Product a) where toUrlPiece = toUrlPiece . getProduct
594+instance ToHttpApiData a => ToHttpApiData (Semi.Max a) where
595+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
596+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
597+
451−instance ToHttpApiData a => ToHttpApiData (First a) where toUrlPiece = toUrlPiece . getFirst
598+instance ToHttpApiData a => ToHttpApiData (Semi.First a) where
599+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
600+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
601+
452−instance ToHttpApiData a => ToHttpApiData (Last a) where toUrlPiece = toUrlPiece . getLast
602+instance ToHttpApiData a => ToHttpApiData (Semi.Last a) where
603+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
604+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
453
605
454-- |
606-- |
455-- >>> toUrlPiece (Just "Hello")
607-- >>> toUrlPiece (Just "Hello")
@@ -467,6 +619,41 @@ instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where
467 toUrlPiece (Left x) = "left " <> toUrlPiece x
619 toUrlPiece (Left x) = "left " <> toUrlPiece x
468 toUrlPiece (Right x) = "right " <> toUrlPiece x
620 toUrlPiece (Right x) = "right " <> toUrlPiece x
469
621
622+-- | /Note:/ this instance works correctly for alphanumeric name and value
623+--
624+-- >>> let Right c = parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie
625+-- >>> toUrlPiece c
626+-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120"
627+--
628+-- >>> toHeader c
629+-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120"
630+--
631+instance ToHttpApiData SetCookie where
632+ toUrlPiece = decodeUtf8With lenientDecode . toHeader
633+ toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
634+ -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.
635+
636+-- | Note: this instance is not polykinded
637+instance ToHttpApiData a => ToHttpApiData (Tagged (b :: Type) a) where
638+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
639+ toHeader = coerce (toHeader :: a -> ByteString)
640+ toQueryParam = coerce (toQueryParam :: a -> Text)
641+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
642+
643+-- | @since 0.4.2
644+instance ToHttpApiData a => ToHttpApiData (Const a b) where
645+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
646+ toHeader = coerce (toHeader :: a -> ByteString)
647+ toQueryParam = coerce (toQueryParam :: a -> Text)
648+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
649+
650+-- | @since 0.4.2
651+instance ToHttpApiData a => ToHttpApiData (Identity a) where
652+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
653+ toHeader = coerce (toHeader :: a -> ByteString)
654+ toQueryParam = coerce (toQueryParam :: a -> Text)
655+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
656+
470-- |
657-- |
471-- >>> parseUrlPiece "_" :: Either Text ()
658-- >>> parseUrlPiece "_" :: Either Text ()
472-- Right ()
659-- Right ()
@@ -478,7 +665,7 @@ instance FromHttpApiData Char where
478 parseUrlPiece s =
665 parseUrlPiece s =
479 case T.uncons s of
666 case T.uncons s of
480 Just (c, s') | T.null s' -> pure c
667 Just (c, s') | T.null s' -> pure c
481− _ -> defaultParseError s
668+ _ -> defaultParseError s
482
669
483-- |
670-- |
484-- >>> showVersion <$> parseUrlPiece "1.2.3"
671-- >>> showVersion <$> parseUrlPiece "1.2.3"
@@ -489,7 +676,6 @@ instance FromHttpApiData Version where
489 ((x, ""):_) -> pure x
676 ((x, ""):_) -> pure x
490 _ -> defaultParseError s
677 _ -> defaultParseError s
491
678
492−#if MIN_VERSION_base(4,8,0)
493-- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors.
679-- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors.
494instance FromHttpApiData Void where
680instance FromHttpApiData Void where
495 parseUrlPiece _ = Left "Void cannot be parsed!"
681 parseUrlPiece _ = Left "Void cannot be parsed!"
@@ -498,9 +684,8 @@ instance FromHttpApiData Natural where
498 parseUrlPiece s = do
684 parseUrlPiece s = do
499 n <- runReader (signed decimal) s
685 n <- runReader (signed decimal) s
500 if n < 0
686 if n < 0
501− then Left ("undeflow: " <> s <> " (should be a non-negative integer)")
687+ then Left ("underflow: " <> s <> " (should be a non-negative integer)")
502 else Right (fromInteger n)
688 else Right (fromInteger n)
503−#endif
504
689
505instance FromHttpApiData Bool where parseUrlPiece = parseBoundedUrlPiece
690instance FromHttpApiData Bool where parseUrlPiece = parseBoundedUrlPiece
506instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece
691instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece
@@ -521,41 +706,89 @@ instance FromHttpApiData String where parseUrlPiece = Right . T.unpack
521instance FromHttpApiData Text where parseUrlPiece = Right
706instance FromHttpApiData Text where parseUrlPiece = Right
522instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
707instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
523
708
709+-- | Note: this instance is not polykinded
710+instance F.HasResolution a => FromHttpApiData (F.Fixed (a :: Type)) where
711+ parseUrlPiece = runReader rational
712+
524-- |
713-- |
525-- >>> toGregorian <$> parseUrlPiece "2016-12-01"
714-- >>> toGregorian <$> parseUrlPiece "2016-12-01"
526-- Right (2016,12,1)
715-- Right (2016,12,1)
527−instance FromHttpApiData Day where parseUrlPiece = readTextData
716+instance FromHttpApiData Day where parseUrlPiece = runAtto Atto.day
528
717
529−timeParseUrlPiece :: ParseTime t => String -> Text -> Either Text t
718+-- |
530−timeParseUrlPiece fmt = parseMaybeTextData (timeParseUrlPieceMaybe . T.unpack)
719+-- >>> parseUrlPiece "14:55:01.333" :: Either Text TimeOfDay
531− where
720+-- Right 14:55:01.333
532− timeParseUrlPieceMaybe = parseTime defaultTimeLocale (iso8601DateFormat (Just fmt))
721+instance FromHttpApiData TimeOfDay where parseUrlPiece = runAtto Atto.timeOfDay
533
722
534-- |
723-- |
535-- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime
724-- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime
536-- Right 2015-10-03 14:55:01
725-- Right 2015-10-03 14:55:01
537−instance FromHttpApiData LocalTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S"
726+instance FromHttpApiData LocalTime where parseUrlPiece = runAtto Atto.localTime
538
727
539-- |
728-- |
540-- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime
729-- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime
541-- Right 2015-10-03 14:55:01 +0000
730-- Right 2015-10-03 14:55:01 +0000
731+--
732+-- >>> parseQueryParam "2016-12-31T01:00:00Z" :: Either Text ZonedTime
733+-- Right 2016-12-31 01:00:00 +0000
542−instance FromHttpApiData ZonedTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S%z"
734+instance FromHttpApiData ZonedTime where parseUrlPiece = runAtto Atto.zonedTime
543
735
544-- |
736-- |
545-- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime
737-- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime
546-- Right 2015-10-03 00:14:24 UTC
738-- Right 2015-10-03 00:14:24 UTC
547−instance FromHttpApiData UTCTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%SZ"
739+instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime
740+
741+-- |
742+-- >>> parseUrlPiece "Monday" :: Either Text DayOfWeek
743+-- Right Monday
744+instance FromHttpApiData DayOfWeek where
745+ parseUrlPiece t = case Map.lookup (T.toLower t) m of
746+ Just dow -> Right dow
747+ Nothing -> Left $ "Incorrect DayOfWeek: " <> T.take 10 t
748+ where
749+ m :: Map.Map Text DayOfWeek
750+ m = Map.fromList [ (toUrlPiece dow, dow) | dow <- [Monday .. Sunday] ]
751+
752+
753+instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secondsToNominalDiffTime . parseUrlPiece
548
754
755+-- |
756+-- >>> parseUrlPiece "2021-01" :: Either Text Month
757+-- Right 2021-01
549−instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap fromInteger . parseUrlPiece
758+instance FromHttpApiData Month where parseUrlPiece = runAtto Atto.month
550
759
551−instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece
760+-- |
761+-- >>> parseUrlPiece "2021-q1" :: Either Text Quarter
762+-- Right 2021-Q1
552−instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece
763+instance FromHttpApiData Quarter where parseUrlPiece = runAtto Atto.quarter
553
764
765+-- |
766+-- >>> parseUrlPiece "q2" :: Either Text QuarterOfYear
767+-- Right Q2
768+--
769+-- >>> parseUrlPiece "Q3" :: Either Text QuarterOfYear
770+-- Right Q3
771+instance FromHttpApiData QuarterOfYear where
772+ parseUrlPiece t = case T.toLower t of
773+ "q1" -> return Q1
774+ "q2" -> return Q2
775+ "q3" -> return Q3
776+ "q4" -> return Q4
777+ _ -> Left "Invalid quarter of year"
778+
779+instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
780+instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
781+
554−instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = fmap Dual . parseUrlPiece
782+instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
555−instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = fmap Sum . parseUrlPiece
783+instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
556−instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = fmap Product . parseUrlPiece
784+instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
557−instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = fmap First . parseUrlPiece
785+instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a))
558−instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = fmap Last . parseUrlPiece
786+instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a))
787+
788+instance FromHttpApiData a => FromHttpApiData (Semi.Min a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
789+instance FromHttpApiData a => FromHttpApiData (Semi.Max a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
790+instance FromHttpApiData a => FromHttpApiData (Semi.First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
791+instance FromHttpApiData a => FromHttpApiData (Semi.Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
559
792
560-- |
793-- |
561-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
794-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
@@ -577,3 +810,58 @@ instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b)
577 Left _ <!> y = y
810 Left _ <!> y = y
578 x <!> _ = x
811 x <!> _ = x
579
812
813+instance ToHttpApiData UUID.UUID where
814+ toUrlPiece = UUID.toText
815+ toHeader = UUID.toASCIIBytes
816+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
817+
818+instance FromHttpApiData UUID.UUID where
819+ parseUrlPiece = maybe (Left "invalid UUID") Right . UUID.fromText
820+ parseHeader = maybe (Left "invalid UUID") Right . UUID.fromASCIIBytes
821+
822+
823+-- | Lenient parameters. 'FromHttpApiData' combinators always return `Right`.
824+--
825+-- @since 0.3.5
826+newtype LenientData a = LenientData { getLenientData :: Either Text a }
827+ deriving (Eq, Ord, Show, Read, Typeable, Data, Functor, Foldable, Traversable)
828+
829+instance FromHttpApiData a => FromHttpApiData (LenientData a) where
830+ parseUrlPiece = Right . LenientData . parseUrlPiece
831+ parseHeader = Right . LenientData . parseHeader
832+ parseQueryParam = Right . LenientData . parseQueryParam
833+
834+-- | /Note:/ this instance works correctly for alphanumeric name and value
835+--
836+-- >>> parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie
837+-- Right (SetCookie {setCookieName = "SESSID", setCookieValue = "r2t5uvjq435r4q7ib3vtdjq120", setCookiePath = Nothing, setCookieExpires = Nothing, setCookieMaxAge = Nothing, setCookieDomain = Nothing, setCookieHttpOnly = False, setCookieSecure = False, setCookieSameSite = Nothing})
838+instance FromHttpApiData SetCookie where
839+ parseUrlPiece = parseHeader . encodeUtf8
840+ parseHeader = Right . parseSetCookie
841+
842+-- | Note: this instance is not polykinded
843+instance FromHttpApiData a => FromHttpApiData (Tagged (b :: Type) a) where
844+ parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
845+ parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
846+ parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
847+
848+-- | @since 0.4.2
849+instance FromHttpApiData a => FromHttpApiData (Const a b) where
850+ parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
851+ parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
852+ parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
853+
854+-- | @since 0.4.2
855+instance FromHttpApiData a => FromHttpApiData (Identity a) where
856+ parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
857+ parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
858+ parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
859+
860+-------------------------------------------------------------------------------
861+-- Attoparsec helpers
862+-------------------------------------------------------------------------------
863+
864+runAtto :: Atto.Parser a -> Text -> Either Text a
865+runAtto p t = case Atto.parseOnly (p <* Atto.endOfInput) t of
866+ Left err -> Left (T.pack err)
867+ Right x -> Right x
stack-ghc-7.10.yamldeleted−11
@@ -1,11 +0,0 @@
1−resolver: lts-6.8
2−
3−packages:
4−- '.'
5−
6−flags:
7− http-api-data:
8− use-text-show: false
9−
10−extra-deps: []
11−extra-package-dbs: []
stack-ghc-7.8.yamldeleted−23
@@ -1,23 +0,0 @@
1−resolver: lts-2.22
2−
3−packages:
4−- '.'
5−
6−flags:
7− http-api-data:
8− use-text-show: false
9−
10−extra-deps:
11−- time-locale-compat-0.1.1.3
12−- uri-bytestring-0.2.2.0
13−# below are dependencies necessary for use-text-show=true
14−- text-show-2.1.2
15−- base-compat-0.9.1
16−- bifunctors-5.2
17−- semigroups-0.16.2.2
18−- th-lift-0.7.6
19−- transformers-compat-0.4.0.4
20−- base-orphans-0.5.4
21−- generic-deriving-1.9.0
22−- doctest-0.11.0
23−extra-package-dbs: []
stack.yaml+1−6
@@ -1,11 +1,6 @@
1−resolver: nightly-2016-07-19
1+resolver: lts-12.10
2−
3packages:
2packages:
4- '.'
3- '.'
5−
6flags:
4flags:
7 http-api-data:
5 http-api-data:
8 use-text-show: false
6 use-text-show: false
9−
10−extra-deps: []
11−extra-package-dbs: []
test/DocTest.hsdeleted−30
@@ -1,30 +0,0 @@
1−module Main where
2−
3−import Build_doctest (autogen_dir, deps)
4−import Control.Applicative
5−import Control.Monad
6−import Data.List
7−import System.Directory
8−import System.FilePath
9−import Test.DocTest
10−
11−main :: IO ()
12−main = getSources >>= \sources -> doctest $
13− "-isrc"
14− : ("-i" ++ autogen_dir)
15− : "-optP-include"
16− : ("-optP" ++ autogen_dir ++ "/cabal_macros.h")
17− : "-hide-all-packages"
18− : map ("-package="++) deps ++ sources
19−
20−getSources :: IO [FilePath]
21−getSources = filter (isSuffixOf ".hs") <$> go "src"
22− where
23− go dir = do
24− (dirs, files) <- getFilesAndDirectories dir
25− (files ++) . concat <$> mapM go dirs
26−
27−getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])
28−getFilesAndDirectories dir = do
29− c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir
30− (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
test/Web/Internal/HttpApiDataSpec.hs+70−23
@@ -1,34 +1,61 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE ScopedTypeVariables #-}
1{-# LANGUAGE ScopedTypeVariables #-}
3module Web.Internal.HttpApiDataSpec (spec) where
2module Web.Internal.HttpApiDataSpec (spec) where
4
3
5−import Data.Int
6−import Data.Word
7−import Data.Time
8−import qualified Data.Text as T
9−import qualified Data.Text.Lazy as L
10−import qualified Data.ByteString as BS
11−import Data.Version
12
4
13−import Data.Proxy
5+import Prelude ()
6+import Prelude.Compat
14
7
15−#if MIN_VERSION_base(4,8,0)
8+import qualified Data.ByteString as BS
16−import Numeric.Natural
9+import Data.ByteString.Builder (toLazyByteString)
17−#endif
10+import Data.Char
11+import qualified Data.Fixed as F
12+import Data.Int
13+import qualified Data.Text as T
14+import qualified Data.Text.Encoding as TE
15+import qualified Data.Text.Lazy as L
16+import Data.Time.Compat
17+import Data.Time.Calendar.Month.Compat (Month)
18+import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..))
19+import qualified Data.UUID.Types as UUID
20+import Data.Version
21+import Data.Word
22+import Web.Cookie (SetCookie, defaultSetCookie,
23+ setCookieName, setCookieValue)
18
24
19−import Test.Hspec
25+import Data.Proxy
20−import Test.Hspec.QuickCheck(prop)
21−import Test.QuickCheck
22
26
23−import Web.Internal.HttpApiData
27+import Numeric.Natural
24
28
25−import Web.Internal.TestInstances
29+import Test.Hspec
30+import Test.Hspec.QuickCheck (prop)
31+import Test.QuickCheck
26
32
27−(<=>) :: Eq a => (a -> b) -> (b -> Either T.Text a) -> a -> Bool
33+import Web.Internal.HttpApiData
28−(f <=> g) x = g (f x) == Right x
29
34
35+import Web.Internal.TestInstances
36+
37+(<=>) :: forall a b. (Show a, Show b, Eq a) => (a -> b) -> (b -> Either T.Text a) -> a -> Property
38+(f <=> g) x = counterexample
39+ (show lhs' ++ " : " ++ show lhs ++ " /= " ++ show rhs)
40+ (lhs == rhs)
41+ where
42+ lhs' = f x
43+ lhs = g lhs' :: Either T.Text a
44+ rhs = Right x :: Either T.Text a
45+
46+encodedUrlPieceProp :: ToHttpApiData a => a -> Property
47+encodedUrlPieceProp x = toLazyByteString (toEncodedUrlPiece (toUrlPiece x)) === toLazyByteString (toEncodedUrlPiece x)
48+
49+-- | Check 'ToHttpApiData' and 'FromHttpApiData' compatibility
30checkUrlPiece :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a, Arbitrary a) => Proxy a -> String -> Spec
50checkUrlPiece :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a, Arbitrary a) => Proxy a -> String -> Spec
51+checkUrlPiece _ = checkUrlPiece' (arbitrary :: Gen a)
52+
53+checkUrlPiece' :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a) => Gen a -> String -> Spec
54+checkUrlPiece' gen name = describe name $ do
31−checkUrlPiece _ name = prop name (toUrlPiece <=> parseUrlPiece :: a -> Bool)
55+ prop "toUrlPiece <=> parseUrlPiece" $ forAll gen (toUrlPiece <=> parseUrlPiece :: a -> Property)
56+ prop "toQueryParam <=> parseQueryParam" $ forAll gen (toQueryParam <=> parseQueryParam :: a -> Property)
57+ prop "toHeader <=> parseHeader" $ forAll gen (toHeader <=> parseHeader :: a -> Property)
58+ prop "toEncodedUrlPiece encodes correctly" $ forAll gen encodedUrlPieceProp
32
59
33-- | Check case insensitivity for @parseUrlPiece@.
60-- | Check case insensitivity for @parseUrlPiece@.
34checkUrlPieceI :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Arbitrary a) => Proxy a -> String -> Spec
61checkUrlPieceI :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Arbitrary a) => Proxy a -> String -> Spec
@@ -36,7 +63,7 @@ checkUrlPieceI _ = checkUrlPiece (Proxy :: Proxy (RandomCase a))
36
63
37spec :: Spec
64spec :: Spec
38spec = do
65spec = do
39− describe "toUrlPiece <=> parseUrlPiece" $ do
66+ describe "Instances" $ do
40 checkUrlPiece (Proxy :: Proxy ()) "()"
67 checkUrlPiece (Proxy :: Proxy ()) "()"
41 checkUrlPiece (Proxy :: Proxy Char) "Char"
68 checkUrlPiece (Proxy :: Proxy Char) "Char"
42 checkUrlPieceI (Proxy :: Proxy Bool) "Bool"
69 checkUrlPieceI (Proxy :: Proxy Bool) "Bool"
@@ -56,20 +83,34 @@ spec = do
56 checkUrlPiece (Proxy :: Proxy T.Text) "Text.Strict"
83 checkUrlPiece (Proxy :: Proxy T.Text) "Text.Strict"
57 checkUrlPiece (Proxy :: Proxy L.Text) "Text.Lazy"
84 checkUrlPiece (Proxy :: Proxy L.Text) "Text.Lazy"
58 checkUrlPiece (Proxy :: Proxy Day) "Day"
85 checkUrlPiece (Proxy :: Proxy Day) "Day"
86+ checkUrlPiece (Proxy :: Proxy TimeOfDay) "TimeOfDay"
59 checkUrlPiece (Proxy :: Proxy LocalTime) "LocalTime"
87 checkUrlPiece (Proxy :: Proxy LocalTime) "LocalTime"
60 checkUrlPiece (Proxy :: Proxy ZonedTime) "ZonedTime"
88 checkUrlPiece (Proxy :: Proxy ZonedTime) "ZonedTime"
61 checkUrlPiece (Proxy :: Proxy UTCTime) "UTCTime"
89 checkUrlPiece (Proxy :: Proxy UTCTime) "UTCTime"
62 checkUrlPiece (Proxy :: Proxy NominalDiffTime) "NominalDiffTime"
90 checkUrlPiece (Proxy :: Proxy NominalDiffTime) "NominalDiffTime"
91+ checkUrlPiece (Proxy :: Proxy DayOfWeek) "DayOfWeek"
92+ checkUrlPiece (Proxy :: Proxy Quarter) "Quarter"
93+ checkUrlPiece (Proxy :: Proxy QuarterOfYear) "QuarterOfYear"
94+ checkUrlPiece (Proxy :: Proxy Month) "Month"
95+ checkUrlPiece (Proxy :: Proxy DayOfWeek) "DayOfWeek"
63 checkUrlPiece (Proxy :: Proxy Version) "Version"
96 checkUrlPiece (Proxy :: Proxy Version) "Version"
97+ checkUrlPiece (Proxy :: Proxy UUID.UUID) "UUID"
98+ checkUrlPiece' setCookieGen "Cookie"
99+
100+ checkUrlPiece (Proxy :: Proxy F.Uni) "Uni"
101+ checkUrlPiece (Proxy :: Proxy F.Deci) "Deci"
102+ checkUrlPiece (Proxy :: Proxy F.Centi) "Centi"
103+ checkUrlPiece (Proxy :: Proxy F.Milli) "Milli"
104+ checkUrlPiece (Proxy :: Proxy F.Micro) "Micro"
105+ checkUrlPiece (Proxy :: Proxy F.Nano) "Nano"
106+ checkUrlPiece (Proxy :: Proxy F.Pico) "Pico"
64
107
65 checkUrlPiece (Proxy :: Proxy (Maybe String)) "Maybe String"
108 checkUrlPiece (Proxy :: Proxy (Maybe String)) "Maybe String"
66 checkUrlPieceI (Proxy :: Proxy (Maybe Integer)) "Maybe Integer"
109 checkUrlPieceI (Proxy :: Proxy (Maybe Integer)) "Maybe Integer"
67 checkUrlPiece (Proxy :: Proxy (Either Integer T.Text)) "Either Integer Text"
110 checkUrlPiece (Proxy :: Proxy (Either Integer T.Text)) "Either Integer Text"
68 checkUrlPieceI (Proxy :: Proxy (Either Version Day)) "Either Version Day"
111 checkUrlPieceI (Proxy :: Proxy (Either Version Day)) "Either Version Day"
69
112
70−#if MIN_VERSION_base(4,8,0)
71 checkUrlPiece (Proxy :: Proxy Natural) "Natural"
113 checkUrlPiece (Proxy :: Proxy Natural) "Natural"
72−#endif
73
114
74 it "bad integers are rejected" $ do
115 it "bad integers are rejected" $ do
75 parseUrlPieceMaybe (T.pack "123hello") `shouldBe` (Nothing :: Maybe Int)
116 parseUrlPieceMaybe (T.pack "123hello") `shouldBe` (Nothing :: Maybe Int)
@@ -80,3 +121,9 @@ spec = do
80
121
81 it "invalid utf8 is handled" $ do
122 it "invalid utf8 is handled" $ do
82 parseHeaderMaybe (BS.pack [128]) `shouldBe` (Nothing :: Maybe T.Text)
123 parseHeaderMaybe (BS.pack [128]) `shouldBe` (Nothing :: Maybe T.Text)
124+
125+setCookieGen :: Gen SetCookie
126+setCookieGen = do
127+ n <- TE.encodeUtf8 . T.pack . filter isAlphaNum <$> arbitrary
128+ v <- TE.encodeUtf8 . T.pack . filter isAlphaNum <$> arbitrary
129+ return $ defaultSetCookie { setCookieName = n, setCookieValue = v }
test/Web/Internal/TestInstances.hs+2−38
@@ -9,58 +9,22 @@ module Web.Internal.TestInstances
9 ) where
9 ) where
10
10
11import Control.Applicative
11import Control.Applicative
12−import qualified Data.ByteString.Lazy.Char8 as BSL
13import Data.Char
12import Data.Char
14import qualified Data.HashMap.Strict as HashMap
13import qualified Data.HashMap.Strict as HashMap
15import qualified Data.Text as T
14import qualified Data.Text as T
16−import qualified Data.Text.Lazy as L
17−import Data.Time
15+import Data.Time.Compat
18−import Data.Version
19import GHC.Exts (fromList)
16import GHC.Exts (fromList)
20import GHC.Generics
17import GHC.Generics
21
18
22import Test.QuickCheck
19import Test.QuickCheck
20+import Test.QuickCheck.Instances ()
23
21
24import Web.Internal.FormUrlEncoded
22import Web.Internal.FormUrlEncoded
25import Web.Internal.HttpApiData
23import Web.Internal.HttpApiData
26
24
27−instance Arbitrary T.Text where
28− arbitrary = T.pack <$> arbitrary
29−
30−instance Arbitrary L.Text where
31− arbitrary = L.pack <$> arbitrary
32−
33−instance Arbitrary BSL.ByteString where
34− arbitrary = BSL.pack <$> arbitrary
35−
36−instance Arbitrary Day where
37− arbitrary = liftA3 fromGregorian (fmap abs arbitrary) arbitrary arbitrary
38−
39−instance Arbitrary LocalTime where
40− arbitrary = LocalTime
41− <$> arbitrary
42− <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))
43−
44instance Eq ZonedTime where
25instance Eq ZonedTime where
45 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
26 ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y
46
27
47−instance Arbitrary ZonedTime where
48− arbitrary = ZonedTime
49− <$> arbitrary
50− <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))
51−
52−instance Arbitrary UTCTime where
53− arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))
54−
55−instance Arbitrary NominalDiffTime where
56− arbitrary = fromInteger <$> arbitrary
57−
58−instance Arbitrary Version where
59− arbitrary = (version . map abs) <$> nonempty
60− where
61− version branch = Version branch []
62− nonempty = liftA2 (:) arbitrary arbitrary
63−
64instance Arbitrary Form where
28instance Arbitrary Form where
65 arbitrary = fromList <$> arbitrary
29 arbitrary = fromList <$> arbitrary
66
30