on 09de487 help sign in
32 files changed+642−555
since splitsnapshots
unifiedsplit
.gitignore−2 .gitmodules+12 .travis.yml+56−12 README.md+33−70 build.sh+3 ChangeLog.md → changelog.md+1−14 default.nix−21 deps/http-api-data+1 deps/reflex-platform+1 deps/servant+1 deps/servant-snap+1 exec/Example.hs+2−2 nix/nix.conf−3 nix/reflex-platform.nix−7 nix/servant-snap.nix−7 nix/testresults.nix−17 nix/testserver.nix−9 overrides-ghc.nix+11 overrides.nix+9 servant-reflex.cabal+19−24 shell.nix−1 src/Servant/Common/BaseUrl.hs+5−4 src/Servant/Common/Req.hs+69−46 src/Servant/Reflex.hs+207−124 src/Servant/Reflex/Multi.hs+165−36 testdriver/test/Servant/ReflexSpec.hs+1−2 testserver/API.hs+1−69 testserver/Main.hs+3−10 testserver/run-wd-tests.sh+5 testserver/testserver.cabal+4−5 testserver/tr.nix+32 travis.nix−70
.gitignore−2
@@ -7,5 +7,3 @@ log
77*.stats
88out
99/.stack-work/
10−TAGS
11−dist-newstyle
.gitmodules+12
@@ -0,0 +1,12 @@
1+[submodule "deps/http-api-data"]
2+ path = deps/http-api-data
3+ url = https://github.com/fizruk/http-api-data
4+[submodule "deps/servant"]
5+ path = deps/servant
6+ url = https://github.com/haskell-servant/servant
7+[submodule "deps/servant-snap"]
8+ path = deps/servant-snap
9+ url = https://github.com/haskell-servant/servant-snap
10+[submodule "deps/reflex-platform"]
11+ path = deps/reflex-platform
12+ url = https://github.com/reflex-frp/reflex-platform
.travis.yml+56−12
@@ -1,17 +1,61 @@
1−language: nix
2−nix: 2.3.6
3−sudo: require
1+sudo: required
2+
3+before_cache:
4+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
5+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
6+
7+addons:
8+ apt:
9+ - phantomjs
10+
11+matrix:
12+ include:
13+ - env: CABALVER=1.24 GHCVER=7.10.3
14+ compiler: ": #GHC 7.10.3"
15+ addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3], sources: [hvr-ghc]}}
16+ - env: CABALVER=1.24 GHCVER=8.0.1
17+ compiler: ": #GHC 8.0.1"
18+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
19+
20+
421
522before_install:
6− - sudo cp -rT $TRAVIS_BUILD_DIR/nix /etc/nix
23+ - unset CC
24+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
25+ - git submodule update --init --recursive
726
8−before_script:
9− - sudo systemctl restart nix-daemon.service
10− - git config --global user.email "travis-ci@example.com"
11− - git config --global user.name "Travis-CI"
27+install:
28+ - cabal --version
29+ - BENCH=${BENCH---enable-benchmarks}
30+ - TEST=${TEST---enable-tests}
31+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
32+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
33+ then
34+ zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
35+ $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
36+ fi
37+ - travis_retry cabal update -v
38+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
39+ - deps/reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal configure -fExample && cabal build"
40+ - deps/reflex-platform/work-on ghc ./testdriver --command "cd testdriver && cabal configure && cabal build"
41+ - cd testserver && dist/build/back/back -p 8000 &
42+ - sleep 3
43+ - phantomjs --webdriver=127.0.0.1:4444 &
44+ - sleep 3
1245
1346script:
14− - nix-build travis.nix -A build
15− - nix-build travis.nix -A buildGhc
16− - nix-build travis.nix -A testserver
17− - nix-build travis.nix -A testresults
47+ - git config --global user.email "travis-ci@example.com"
48+ - git config --global user.name "Travis-CI"
49+ - ./build.sh
50+ # - testdriver/dist/build/spec/spec
51+
52+cache:
53+ directories:
54+ - /nix
55+ - $HOME/.cabal/packages
56+ - $HOME/.cabal/store
57+
58+env:
59+ global:
60+ - ENCRYPTION_LABEL: "3c89d919c82e"
61+ - COMMIT_AUTHOR_EMAIL: "imalsogreg@gmail.com"
README.md+33−70
@@ -4,19 +4,14 @@
44
55## `servant-reflex` lets you share your `servant` APIs with the frontend
66
7−Keeping your frontend in sync with your API server can be difficult - when the
8−API changes its input parameters or return type, XHR requests from the
9−frontend will fail at runtime. If your API is defined by
10−[servant](https://haskell-servant.readthedocs.io) combinators, you can use
11−`servant-reflex` to share the API between the server and frontend.
12−Syncronization between is checked at compile time, and rather than building XHR
13−requests by hand, API endpoints are available behind `reflex`'s FRP semantics.
7+Keeping your frontend in sync with your API server can be difficult - when the API changes its input parameters or return type, XHR requests from the frontend will fail at runtime. If your API is defined by [servant](haskell-servant.readthedocs.io) combinators, you can use `servant-reflex` to share the API between the server and frontend.
8+Syncronization between is checked at compile time, and rather than building XHR requests by hand, API endpoints are available behind `reflex`'s FRP semantics.
9+
1410
1511
1612## Example
1713
18−We have a webservice API defined in a module where both the server (compiled
19−with ghc) and the frontend (compiled with ghcjs) can see it:
14+We have a webservice API defined in a module where both the server (compiled with ghc) and the frontend (compiled with ghcjs) can see it:
2015
2116```haskell
2217type API = "getint" :> Get '[JSON] Int
@@ -29,8 +24,7 @@ type API = "getint" :> Get '[JSON] Int
2924 :<|> Raw
3025```
3126
32−`servant-reflex` then computes client functions that can query the API through
33−an `XhrRequest`.
27+`servant-reflex` then computes client functions that can query the API through an `XhrRequest`.
3428
3529```haskell
3630
@@ -43,16 +37,7 @@ an `XhrRequest`.
4337 (constDyn (BasePath "/"))
4438```
4539
46−These client functions are computed from your API type. They manage
47−serialization, `XhrRequest` generation, and deserialization for you. `a`
48−parameters used in URL captures become `Dynamic t (Either Text a)` parameters
49−in the client functions. `QueryFlag`, `QueryParams` and `QueryParam` API
50−parameters map to `Dynamic t Bool`, `Dynamic t [a]` and `Dynamic t (QParam a)`
51−respectively. These parameters to the client function are wrapped with failure
52−possibility to allow you to indicate at any time whether input validation for
53−that parameter has failed and no valid XHR request can be generated. The final
54−parameter is a trigger event for the XHR request. The return value
55−`Event t (ReqResult a)` contains responses from the API server.
40+These client functions are computed from your API type. They manage serialization, `XhrRequest` generation, and deserialization for you. `a` parameters used in URL captures become `Dynamic t (Either Text a)` parameters in the client functions. `QueryFlag`, `QueryParams` and `QueryParam` API parameters map to `Dynamic t Bool`, `Dynamic t [a]` and `Dynamic t (QParam a)` respectively. These parameters to the client function are wrapped with failure possibility to allow you to indicate at any time whether input validation for that parameter has failed and no valid XHR request can be generated. The final parameter is a trigger event for the XHR request. The return value `Event t (ReqResult a)` contains responses from the API server.
5641
5742```haskell
5843 -- No need to write these functions. servant-reflex creates them for you!
@@ -77,13 +62,7 @@ parameter is a trigger event for the XHR request. The return value
7762 -> m (Event t (ReqResult () Double))
7863```
7964
80−`ReqResult tag a` is defined in
81−[`Servant.Common.Req`](https://github.com/imalsogreg/servant-reflex/blob/6d866e338edb9bf6fd8f8d5083ff0187b4d8c0d2/src/Servant/Common/Req.hs#L40-L42)
82−and reports whether or not your request was sent (if validation fails, the
83−request won't be sent), and how decoding of the response went. You can pattern
84−match on these explicitly, but usually you'll want to use
85−`fmapMaybe :: (a -> Maybe b) -> Event t a -> Event t b` and one of the
86−elimination functions to filter the result type you care about, like this:
65+`ReqResult tag a` is defined in [`Servant.Common.Req`](https://github.com/imalsogreg/servant-reflex/blob/6d866e338edb9bf6fd8f8d5083ff0187b4d8c0d2/src/Servant/Common/Req.hs#L40-L42) and reports whether or not your request was sent (if validation fails, the request won't be sent), and how decoding of the response went. You can pattern match on these explicitly, but usually you'll want to use `fmapMaybe :: (a -> Maybe b) -> Event t a -> Event t b` and one of the elimination functions to filter the result type you care about, like this:
8766
8867```haskell
8968 -- ... continued ...
@@ -101,8 +80,7 @@ elimination functions to filter the result type you care about, like this:
10180 dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])
10281```
10382
104−This example builds some input fields to enter API parameters, buttons to
105−trigger the API calls, and text elements to show the results:
83+This example builds some input fields to enter API parameters, buttons to trigger the API calls, and text elements to show the results:
10684
10785```haskell
10886 elClass "div" "int-demo" $ do
@@ -125,53 +103,47 @@ trigger the API calls, and text elements to show the results:
125103 display =<< holdDyn Nothing outputDouble
126104```
127105
128−For a great introduction to recative DOM building, see the
129−[README](https://github.com/reflex-frp/reflex-platform) for the
130−`reflex-platform`. For more information about servant, see their
131−[documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to
132−the respective authors of these fabulous libraries.
106+For a great introduction to recative DOM building, see the [README](https://github.com/reflex-frp/reflex-platform) for the `reflex-platform`. For more information about servant, see their [documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to the respective authors of these fabulous libraries.
133107
134108
135109## Building the library and test server
136110
137−This repository comes with a small example of an API shared between a
138−ghcjs-compiled frontend
139−([exec/](https://github.com/imalsogreg/servant-reflex/tree/master/exec)) and a
140−ghc-compiled backend
141−([testserver/](https://github.com/imalsogreg/servant-reflex/tree/master/testserver).
142−To build these components, we will use the nix packages for the testserver. It
143−manages the frontend build as a dependency.
111+This repository comes with a small example of an API shared between a ghcjs-compiled frontend ([exec/](https://github.com/imalsogreg/servant-reflex/tree/master/exec)) and a ghc-compiled backend ([testserver/](https://github.com/imalsogreg/servant-reflex/tree/master/testserver). To build these components:
112+
113+
114+First build the library:
144115
145116```
146−nix build -f travis.nix testserver -o server
117+git submodule update --init --recursive
118+./build.sh
147119```
148120
149−Point it at the static directory and run it:
121+Then build the test server:
122+
123+```
124+deps/reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal build"
125+```
126+
127+
128+## Running the example site
129+
130+The server must be run from the directory where static assets live:
150131
151132```
152−STATIC_DIR=server/static server/back -p 8000
133+cd testserver
134+dist/build/back/back -p 8001
153135```
154136
155−Browse to [http://localhost:8000](http://localhost:8000) and click around.
156−Open the firefox or chrome developer tools and examine the XHR activity
157−under the Network tab.
137+And simply browse to `localhost:8001`
158138
159−**For a larger example of a project that shares types between backend and
160−frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
139+**For a larger example of a project that shares types between backend and frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
161140
162141
163142## Tagging requests
164143
165−The input and the return type of a client function like `getDouble` are both
166−event streams. The individual input events and responses occur at different
167−times and aren't automatically paired up, but you can recover the
168−relationship by tagging the requests.
144+The input and the return type of a client function like `getDouble` are both event streams. The individual input events and responses occur at different times and aren't automatically paired up, but you can recover the relationship by tagging the requests.
169145
170−So far we have used an `Event t ()` to trigger sending a request. If we choose
171−e.g. `Double` for the third `Proxy` argument to `client`, then `Event t Double`
172−will be used to trigger requests, and each `ReqResult` will carry the tag of
173−its request. Imagine we wanted to display not just the last "double" from
174−`doubleIt`, but a whole table of valid inputs and their doubled responses:
146+So far we have used an `Event t ()` to trigger sending a request. If we choose e.g. `Double` for the third `Proxy` argument to `client`, then `Event t Double` will be used to trigger requests, and each `ReqResult` will carry the tag of its request. Imagine we wanted to display not just the last "double" from `doubleIt`, but a whole table of valid inputs and their doubled responses:
175147
176148```haskell
177149 ...
@@ -201,10 +173,7 @@ its request. Imagine we wanted to display not just the last "double" from
201173
202174## Simultaneous requests
203175
204−`Servant.Reflex.Multi` provides an alternative client-generation function
205−called `clientA` (client applicative). Choose a container type that has both
206−`Applicative` and `Traversable` instances, and pass it to `clientA` through
207−another `Proxy`. Our `sayHi` client function will then have this type:
176+`Servant.Reflex.Multi` provides an alternative client-generation function called `clientA` (client applicative). Choose a container type that has both `Applicative` and `Traversable` instances, and pass it to `clientA` through another `Proxy`. Our `sayHi` client function will then have this type:
208177
209178```haskell
210179sayHi
@@ -215,10 +184,4 @@ sayHi
215184 -> m (Event t (f (ReqResult tag Text)))
216185```
217186
218−The dynamic params are each wrapped in `f`. For every firing of the trigger
219−event `tag`, all of these parameters will be combined according to `f`'s
220−`Applicative` instance (when `f` is `[]`, you will get all combinations of
221−all parameters taken together as a request; when `f` is `ZipList`, the Nth
222−elemens of each parameters list will be taken together as a request). Using
223−this interface, you can trigger many XHR's from a single event occurence, and
224−expect the responses to be structured the same way as the requests.
187+The dynamic params are each wrapped in `f`. For every firing of the trigger event `tag`, all of these parameters will be combined according to `f`'s `Applicative` instance (when `f` is `[]`, you will get all combinations of all parameters taken together as a request; when `f` is `ZipList`, the Nth elemens of each parameters list will be taken together as a request). Using this interface, you can trigger many XHR's from a single event occurence, and expect the responses to be structured the same way as the requests.
build.shnew file+3
@@ -0,0 +1,3 @@
1+#!/usr/bin/env bash
2+
3+deps/reflex-platform/work-on ./overrides.nix ./. --run "cabal configure --ghcjs -f Example && cabal build && exec/toSite.sh"
ChangeLog.md → changelog.mdrenamed+1−14
@@ -1,20 +1,7 @@
1−0.3.5
2−-----
3−
4− - Require reflex-dom-core >= 0.6 (for internal handling of case-insensitive headers)
5− - Require servant >= 0.16
6− - Eliminate use of deprecated widgets from reflex-dom-core
7− - Bump the version of reflex-platform used in nix-shell and test suite
8−
9−0.3.4
10−-----
11−
12−Add selenium-based test suite
13−
1410.3.3
152-----
163
17−- Fix encoding issue: Explicitly escape reserved characters from path pieces and query parameters
4+Explicitly escape reserved characters from path pieces and query parameters
185
196
2070.3.2
default.nixdeleted−21
@@ -1,21 +0,0 @@
1−{ mkDerivation, base, bytestring, case-insensitive, containers
2−, data-default, exceptions, ghcjs-dom, http-api-data, http-media
3−, jsaddle, mtl, network-uri, reflex, reflex-dom, reflex-dom-core
4−, safe, servant, servant-auth, stdenv, string-conversions, text
5−, transformers
6−}:
7−mkDerivation {
8− pname = "servant-reflex";
9− version = "0.3.6";
10− src = ./.;
11− isLibrary = true;
12− isExecutable = true;
13− libraryHaskellDepends = [
14− base bytestring case-insensitive containers data-default exceptions
15− ghcjs-dom http-api-data http-media jsaddle mtl network-uri reflex
16− reflex-dom reflex-dom-core safe servant servant-auth string-conversions
17− text transformers
18− ];
19− description = "servant API generator for reflex apps";
20− license = stdenv.lib.licenses.bsd3;
21−}
deps/http-api-datanew file+1

Submodule changed.

deps/reflex-platformnew file+1

Submodule changed.

deps/servantnew file+1

Submodule changed.

deps/servant-snapnew file+1

Submodule changed.

exec/Example.hs+2−2
@@ -21,8 +21,7 @@ import Servant.API
2121import API
2222import Data.Proxy
2323import Text.Read (readMaybe)
24−import Reflex.Dom.Core hiding (run, mainWidget)
25−import Reflex.Dom (mainWidget)
24+import Reflex.Dom hiding (run)
2625------------------------------------------------------------------------------
2726import Servant.Reflex
2827import Servant.Reflex.Multi
@@ -98,6 +97,7 @@ run = mdo
9897
9998 -- Name the computed API client functions
10099 let tweakRequest = ClientOptions $ \r -> do
100+ putStrLn ("Got req: " ++ show r)
101101 return $ r & withCredentials .~ True
102102 let (getUnit :<|> getInt :<|> sayhi :<|> dbl
103103 :<|> multi :<|> qna :<|> secret :<|> doRaw) =
nix/nix.confdeleted−3
@@ -1,3 +0,0 @@
1−substituters = https://cache.nixos.org/ https://nixcache.reflex-frp.org/
2−trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=
3−trusted-users = travis
nix/reflex-platform.nixdeleted−7
@@ -1,7 +0,0 @@
1−let
2− rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;
3−in import (builtins.fetchTarball
4− {
5− url = "https://github.com/reflex-frp/reflex-platform/archive/${rev}.tar.gz";
6− sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;
7− }) {}
nix/servant-snap.nixdeleted−7
@@ -1,7 +0,0 @@
1−# Servant-snap is marked broken in nixpkgs
2−{ nixpkgs ? import <nixpkgs> {}}: self: super:
3−self.callCabal2nix "servant-snap" (nixpkgs.fetchgit {
4− url = "https://github.com/haskell-servant/servant-snap.git";
5− rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";
6− sha256 = "sha256-fzzQGwG8Ko72OO/kwLMG52eNZSt3F2dxhNgM9gaO4yQ=";
7−}) {}
nix/testresults.nixdeleted−17
@@ -1,17 +0,0 @@
1−{ curl, reflexPlatform, testdriver, testserver, phantomjs }:
2−
3−reflexPlatform.nixpkgs.pkgs.runCommand "runWebdriveTest.sh" {} ''
4− echo About to phantom
5− ${phantomjs}/bin/phantomjs --webdriver=127.0.0.1:4444 &
6− sleep 3
7− echo About to Server
8− STATIC_DIR=${testserver}/static ${testserver}/back -q --no-access-log --no-error-log -p 8000 &
9− sleep 3
10− ${curl}/bin/curl localhost:8000
11− ${curl}/bin/curl localhost:8000/runmain.js
12− echo About to testdrive
13− ${testdriver}/bin/spec > $out 2>&1
14− echo Done
15− trap "exit" INT TERM
16− trap "kill 0" EXIT
17− ''
nix/testserver.nixdeleted−9
@@ -1,9 +0,0 @@
1−servant-reflex: self: super:
2−
3−(self.callCabal2nix "testserver" ../testserver {}).overrideDerivation (drv: {
4− postInstall = ''
5− cp dist/build/back/back $out/back
6− mkdir $out/static
7− cp ${servant-reflex}/bin/example.jsexe/* $out/static/
8− '';
9−})
overrides-ghc.nixnew file+11
@@ -0,0 +1,11 @@
1+{ reflex-platform, ... }:
2+let
3+ c2n = reflex-platform.cabal2nixResult;
4+ dc = reflex-platform.lib.dontCheck;
5+in reflex-platform.ghc.override {
6+ overrides = self: super: {
7+ servant-snap = dc (self.callPackage (c2n deps/servant-snap) {});
8+ heist = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});
9+ xmlhtml = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
10+ };
11+}
overrides.nixnew file+9
@@ -0,0 +1,9 @@
1+{ reflex-platform, ... }:
2+let
3+ dc = reflex-platform.lib.dontCheck;
4+ c2n = reflex-platform.cabal2nixResult;
5+in
6+reflex-platform.ghcjs.override {
7+ overrides = self: super: {
8+ };
9+}
servant-reflex.cabal+19−24
@@ -1,7 +1,7 @@
11Name: servant-reflex
2−Version: 0.3.6
3−Synopsis: servant API generator for reflex apps
4−Description: Generate reflex-compatible client functions from servant API descriptions
2+Version: 0.3.3
3+Synopsis: Servant reflex API generator
4+Description: Servant reflex API generator
55License: BSD3
66License-file: LICENSE.md
77Author: Greg Hale, Doug Beardsley
@@ -17,35 +17,39 @@ Flag Example
1717
1818library
1919 exposed-modules:
20− Servant.Common.BaseUrl
21− Servant.Common.Req
2220 Servant.Reflex
2321 Servant.Reflex.Multi
2422
23+ other-modules:
24+ Servant.Common.BaseUrl
25+ Servant.Common.Req
26+
2527 hs-source-dirs: src
2628 build-depends:
27− base >= 4.8 && < 5,
29+ base >= 4.8 && < 4.10,
30+ aeson >= 0.11 && < 1.3,
2831 bytestring >= 0.10 && < 0.11,
2932 case-insensitive >= 1.2.0.4 && < 1.3,
30− containers >= 0.5.6 && < 0.7,
33+ containers >= 0.5.6 && < 0.6,
3134 data-default >= 0.5 && < 0.8,
32− exceptions >= 0.8 && < 0.11,
35+ exceptions >= 0.8 && < 0.9,
3336 ghcjs-dom >= 0.2 && < 0.10,
34− http-api-data >= 0.3.6 && < 0.5,
35− http-media >= 0.6 && < 0.9,
37+ http-api-data >= 0.3.6 && < 0.4,
38+ http-media >= 0.6 && < 0.7,
3639 jsaddle >= 0.8 && < 0.10,
3740 mtl >= 2.2.1 && < 2.3,
3841 network-uri >= 2.6 && < 2.7,
39− reflex >= 0.5 && < 0.9,
40− reflex-dom-core >= 0.6 && < 0.7,
42+ reflex >= 0.5 && < 0.6,
43+ reflex-dom-core == 0.4 && < 0.5,
4144 safe >= 0.3.9 && < 0.4,
42− servant >= 0.16 && < 0.18,
45+ servant >= 0.13 && < 0.14,
46+ servant-checked-exceptions >= 1.1.0.0 && < 1.2,
4347 servant-auth >= 0.2.1 && < 0.4,
4448 string-conversions >= 0.4 && < 0.5,
4549 text >= 1.2 && < 1.3,
4650 transformers >= 0.4 && < 0.6
4751
48− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
52+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
4953
5054 default-language: Haskell2010
5155
@@ -54,16 +58,7 @@ executable example
5458 buildable: True
5559 else
5660 buildable: False
57− build-depends:
58− aeson,
59− reflex,
60− servant-reflex,
61− base,
62− scientific,
63− servant,
64− reflex-dom,
65− reflex-dom-core,
66− text
61+ build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text
6762 default-language: Haskell2010
6863 main-is: Example.hs
6964 other-modules: API
shell.nixdeleted−1
@@ -1 +0,0 @@
1−(import ./travis.nix {nativeCompiler = "ghc";}).ghcPkgs.servant-reflex.env
src/Servant/Common/BaseUrl.hs+5−4
@@ -85,14 +85,15 @@ baseUrlWidget = elClass "div" "base-url" $ do
8585 where pathWidget :: m (Dynamic t BaseUrl)
8686 pathWidget = do
8787 text "Url base path"
88− t <- inputElement def
88+ t <- textInput (def {_textInputConfig_attributes =
89+ constDyn ("placeholder" =: "/a/b")})
8990 return $ BasePath <$> value t
9091 fullUrlWidget :: m (Dynamic t BaseUrl)
9192 fullUrlWidget = do
9293 schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def
93− srv <- inputElement def
94+ srv <- textInput def {_textInputConfig_attributes = constDyn $ "placeholder" =: "example.com"}
9495 text ":"
95− prt <- inputElement def
96+ prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}
9697 port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))
97− path <- inputElement def
98+ path <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "a/b" }
9899 return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path
src/Servant/Common/Req.hs+69−46
@@ -8,18 +8,21 @@
88{-# LANGUAGE ScopedTypeVariables #-}
99{-# LANGUAGE TupleSections #-}
1010
11+{-# LANGUAGE MultiParamTypeClasses #-}
12+{-# LANGUAGE FlexibleInstances #-}
1113module Servant.Common.Req where
1214
1315-------------------------------------------------------------------------------
1416import Control.Applicative (liftA2, liftA3)
15−import Control.Arrow ((&&&))
1617import Control.Concurrent
1718import Control.Monad (join)
1819import Control.Monad.IO.Class (MonadIO, liftIO)
20+import Data.Aeson
1921import Data.Bifunctor (first)
20−import qualified Data.ByteString.Builder as Builder
22+import qualified Data.ByteString.Builder as BB
23+import qualified Data.ByteString as BS
24+import Data.ByteString.Lazy (ByteString)
2125import qualified Data.ByteString.Lazy.Char8 as BL
22−import Data.ByteString (ByteString)
2326import qualified Data.Map as Map
2427import Data.Maybe (catMaybes, fromMaybe)
2528import Data.Functor.Compose
@@ -27,17 +30,24 @@ import Data.Monoid ((<>))
2730import Data.Proxy (Proxy(..))
2831import Data.Text (Text)
2932import qualified Data.Text as T
30−import qualified Data.Text.Encoding as TE
33+import qualified Data.Text.Lazy as TL
34+import qualified Data.Text.Encoding as T
3135import Data.Traversable (forM)
3236import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
37+import qualified Language.Javascript.JSaddle as JS
38+import qualified Data.JSString.Text as JS (lazyTextFromJSString)
3339import qualified Network.URI as N
3440import Reflex.Dom.Core hiding (tag)
3541import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
3642 SupportsServantReflex)
37−import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
43+import Servant.API.ContentTypes ( NoContent(..), Accept, JSON
44+ , OctetStream, PlainText
45+ , FormUrlEncoded)
3846import Web.HttpApiData (ToHttpApiData(..))
47+import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)
3948-------------------------------------------------------------------------------
4049import Servant.API.BasicAuth
50+-------------------------------------------------------------------------------
4151
4252
4353------------------------------------------------------------------------------
@@ -93,13 +103,6 @@ reqFailure (ResponseFailure _ s _) = Just s
93103reqFailure (RequestFailure _ s) = Just s
94104reqFailure _ = Nothing
95105
96−------------------------------------------------------------------------------
97−-- | Simple filter/accessor like 'reqFailure', but keeping the request tag
98−reqFailure' :: ReqResult tag a -> Maybe (tag,Text)
99−reqFailure' (ResponseFailure tag s _) = Just (tag,s)
100−reqFailure' (RequestFailure tag s) = Just (tag,s)
101−reqFailure' _ = Nothing
102−
103106
104107------------------------------------------------------------------------------
105108-- | Simple filter/accessor for the raw XHR response
@@ -159,7 +162,7 @@ prependToPathParts p req =
159162 req { reqPathParts = p : reqPathParts req }
160163
161164addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
162−addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
165+addHeader name val req = req { headers = (name, (fmap . fmap) (T.decodeUtf8 . toHeader) val) : headers req }
163166
164167
165168reqToReflexRequest
@@ -232,7 +235,7 @@ reqToReflexRequest reqMeth reqHost req =
232235 Map.insert "Content-Type" bCT (Map.fromList hs)
233236 , _xhrRequestConfig_user = Nothing
234237 , _xhrRequestConfig_password = Nothing
235− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
238+ , _xhrRequestConfig_responseType = Nothing
236239 , _xhrRequestConfig_withCredentials = False
237240 , _xhrRequestConfig_responseHeaders = def
238241 }
@@ -244,8 +247,8 @@ reqToReflexRequest reqMeth reqHost req =
244247 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
245248 , _xhrRequestConfig_user = Nothing
246249 , _xhrRequestConfig_password = Nothing
247− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
248− , _xhrRequestConfig_sendData = mempty
250+ , _xhrRequestConfig_responseType = Nothing
251+ , _xhrRequestConfig_sendData = ""
249252 , _xhrRequestConfig_withCredentials = False
250253 }
251254 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
@@ -254,8 +257,8 @@ reqToReflexRequest reqMeth reqHost req =
254257 mkAuth _ (Left e) = Left e
255258 mkAuth Nothing r = r
256259 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config
257− { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
258− , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
260+ { _xhrRequestConfig_user = Just $ T.decodeUtf8 u
261+ , _xhrRequestConfig_password = Just $ T.decodeUtf8 p}
259262
260263 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
261264 -> Dynamic t (Either Text (XhrRequestConfig x))
@@ -335,10 +338,9 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs
335338 return ()
336339
337340
338−
339−type XhrPayload = ByteString
341+type XhrPayload = T.Text
340342bytesToPayload :: BL.ByteString -> XhrPayload
341−bytesToPayload = BL.toStrict
343+bytesToPayload = T.decodeUtf8 . BL.toStrict
342344
343345
344346performRequestsCT
@@ -353,15 +355,14 @@ performRequestsCT
353355 -> m (Event t (f (ReqResult tag a)))
354356performRequestsCT ct reqMeth reqs reqHost opts trigger = do
355357 resps <- performRequests reqMeth reqs reqHost opts trigger
356− let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
357− first T.pack .
358− mimeUnrender ct $
359− BL.fromStrict x
360− decodeResp _ = Left "No body"
358+ let decodeResp x = first T.pack
359+ . mimeUnrender ct
360+ . JS.textToJSString
361+ =<< note "No body text" (_xhrResponse_responseText x)
361362 return $ fmap
362363 (\(t,rs) -> ffor rs $ \r -> case r of
363364 Left e -> RequestFailure t e
364− Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
365+ Right g -> evalResponse decodeResp (t,g)
365366 )
366367 resps
367368
@@ -388,9 +389,8 @@ evalResponse
388389 :: (XhrResponse -> Either Text a)
389390 -> (tag, XhrResponse)
390391 -> ReqResult tag a
391−evalResponse decode (tag, xhr) =
392− let status = _xhrResponse_status xhr
393− okStatus = status >= 200 && status < 400
392+evalResponse decodeRes (tag, xhr) =
393+ let okStatus = _xhrResponse_status xhr < 400
394394 errMsg = fromMaybe
395395 ("Empty response with error code " <>
396396 T.pack (show $ _xhrResponse_status xhr))
@@ -399,33 +399,56 @@ evalResponse decode (tag, xhr) =
399399 then either
400400 (\e -> ResponseFailure tag e xhr)
401401 (\v -> ResponseSuccess tag v xhr)
402− (decode xhr)
402+ (decodeRes xhr)
403403 else ResponseFailure tag errMsg xhr
404404 in respPayld
405405
406−------------------------------------------------------------------------------
407−-- | Utility for simultaneously accessing/filtering Success and Failure
408−-- response 'Event's,
409−fanReqResult :: Reflex t => Event t (ReqResult tag a) -> (Event t Text, Event t a)
410−fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess
411406
412−------------------------------------------------------------------------------
413−-- | Utility for simultaneously accessing/filtering Success and Failure
414−-- response 'Event's, but keeping the request tag
415−fanReqResult' :: Reflex t => Event t (ReqResult tag a) -> (Event t (tag, Text), Event t (tag, a))
416−fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'
407+-- | Similar to 'Servant.API.ContentType.MimeUnrender' but with the differnce that
408+-- the second argument expects a JSString instead of ByteString.
409+-- This can lead to better performance ghcjs.
410+class Accept contentType => MimeUnrender contentType a where
411+ mimeUnrender :: Proxy contentType -> JS.JSString -> Either String a
412+
413+instance FromJSON a => MimeUnrender JSON a where
414+ mimeUnrender _ = note "Failed to decode response" . jsonDecode
417415
416+-- | @urlDecodeAsForm@
417+-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
418+-- holds if every element of x is non-null (i.e., not @("", "")@)
419+instance FromForm a => MimeUnrender FormUrlEncoded a where
420+ mimeUnrender _ = first T.unpack . urlDecodeAsForm . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
421+
422+-- | @left show . TextL.decodeUtf8'@
423+instance MimeUnrender PlainText TL.Text where
424+ mimeUnrender _ = pure . JS.lazyTextFromJSString
425+
426+-- | @left show . TextS.decodeUtf8' . toStrict@
427+instance MimeUnrender PlainText T.Text where
428+ mimeUnrender _ = pure . JS.textFromJSString
429+
430+-- | @Right . BC.unpack@
431+instance MimeUnrender PlainText String where
432+ mimeUnrender _ = Right . T.unpack . JS.textFromJSString
433+
434+-- | @Right . id@
435+instance MimeUnrender OctetStream ByteString where
436+ mimeUnrender _ = pure . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
437+
438+-- | @Right . toStrict@
439+instance MimeUnrender OctetStream BS.ByteString where
440+ mimeUnrender _ = pure . T.encodeUtf8 . JS.textFromJSString
418441
419442note :: e -> Maybe a -> Either e a
420−note e = maybe (Left e) Right
443+note e Nothing = Left e
444+note _ (Just a) = Right a
421445
422446fmapL :: (e -> e') -> Either e a -> Either e' a
423447fmapL _ (Right a) = Right a
424448fmapL f (Left e) = Left (f e)
425449
426−builderToText :: Builder.Builder -> T.Text
427−builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
450+builderToText :: BB.Builder -> T.Text
451+builderToText = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString
428452
429453escape :: T.Text -> T.Text
430−escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
431−
454+escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . toEncodedUrlPiece
src/Servant/Reflex.hs+207−124
@@ -8,7 +8,6 @@
88{-# LANGUAGE MultiParamTypeClasses #-}
99{-# LANGUAGE OverloadedStrings #-}
1010{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE Rank2Types #-}
1211{-# LANGUAGE ScopedTypeVariables #-}
1312{-# LANGUAGE TupleSections #-}
1413{-# LANGUAGE TypeFamilies #-}
@@ -26,9 +25,7 @@
2625module Servant.Reflex
2726 ( client
2827 , clientWithOpts
29− , clientWithOptsAndResultHandler
3028 , clientWithRoute
31− , clientWithRouteAndResultHandler
3229 , BuildHeaderKeysTo(..)
3330 , toHeaders
3431 , HasClient
@@ -39,41 +36,39 @@ module Servant.Reflex
3936
4037------------------------------------------------------------------------------
4138import Control.Applicative
42−import qualified Data.CaseInsensitive as CI
43−import Data.Functor.Identity
44−import qualified Data.Map as Map
4539import Data.Monoid ((<>))
46−import Data.Proxy (Proxy (..))
4740import qualified Data.Set as Set
41+import qualified Data.Text.Encoding as E
42+import Data.CaseInsensitive (mk)
43+import Data.Functor.Identity
44+import Data.Proxy (Proxy (..))
45+import qualified Data.Map as Map
4846import Data.Text (Text)
4947import qualified Data.Text as T
50−import qualified Data.Text.Encoding as E
5148import GHC.Exts (Constraint)
5249import GHC.TypeLits (KnownSymbol, symbolVal)
53−import Servant.API ((:<|>) (..), (:>), BasicAuth,
54− BasicAuthData, BuildHeadersTo (..),
55− Capture, Header, Headers (..),
56− HttpVersion, IsSecure,
57− MimeRender (..), MimeUnrender,
50+import Servant.API ((:<|>)(..),(:>), BasicAuth,
51+ BasicAuthData, BuildHeadersTo(..),
52+ Capture, contentType, Header,
53+ Headers(..), HttpVersion, IsSecure,
54+ MimeRender(..),
5855 NoContent, QueryFlag, QueryParam,
59− QueryParams, Raw, ReflectMethod (..),
56+ QueryParams, Raw, ReflectMethod(..),
6057 RemoteHost, ReqBody,
61− ToHttpApiData (..), Vault, Verb,
62− contentType)
63−import Servant.API.Description (Summary)
58+ ToHttpApiData(..), Vault, Verb)
6459import qualified Servant.Auth as Auth
6560
6661import Reflex.Dom.Core (Dynamic, Event, Reflex,
67− XhrRequest (..), XhrResponse (..),
68− XhrResponseHeaders (..),
69− attachPromptlyDynWith, constDyn, ffor,
70− fmapMaybe, leftmost,
71− performRequestsAsync)
62+ XhrRequest(..),
63+ XhrResponseHeaders(..),
64+ XhrResponse(..), attachPromptlyDynWith, constDyn, ffor, fmapMaybe,
65+ leftmost, performRequestsAsync,
66+ )
7267------------------------------------------------------------------------------
7368import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
7469 showBaseUrl,
7570 SupportsServantReflex)
76−import Servant.Common.Req (ClientOptions(..),
71+import Servant.Common.Req (ClientOptions(..), MimeUnrender(..),
7772 defaultClientOptions,
7873 Req, ReqResult(..), QParam(..),
7974 QueryPart(..), addHeader, authData,
@@ -89,6 +84,8 @@ import Servant.Common.Req (ClientOptions(..),
8984 response,
9085 reqTag,
9186 qParams, withCredentials)
87+import Servant.Checked.Exceptions.Internal.Envelope (Envelope)
88+import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow, Throws, Throwing, ThrowingNonterminal)
9289
9390
9491-- * Accessing APIs as a Client
@@ -103,7 +100,7 @@ import Servant.Common.Req (ClientOptions(..),
103100-- >
104101-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
105102-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
106−-- > -> m (Event t (l, ReqResult Book)))
103+-- -> m (Event t (l, ReqResult Book)))
107104-- > (getAllBooks :<|> postNewBook) = client myApi host
108105-- > where host = constDyn $ BaseUrl Http "localhost" 8080
109106client
@@ -125,53 +122,21 @@ clientWithOpts
125122 -> Client t m layout tag
126123clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
127124
128−-- | Like 'clientWithOpts' but allows passing a function which will process the
129−-- result event in some way. This can be used to handle errors in a uniform way
130−-- across call sites.
131−clientWithOptsAndResultHandler
132− :: (HasClient t m layout tag)
133− => Proxy layout
134− -> Proxy m
135− -> Proxy tag
136− -> Dynamic t BaseUrl
137− -> ClientOptions
138− -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
139− -> Client t m layout tag
140−clientWithOptsAndResultHandler p q t = clientWithRouteAndResultHandler p q t defReq
141−
142125
143126-- | This class lets us define how each API combinator
144127-- influences the creation of an HTTP request. It's mostly
145128-- an internal class, you can just use 'client'.
146−class Monad m => HasClient t m layout (tag :: *) where
129+class HasClient t m layout (tag :: *) where
147130 type Client t m layout tag :: *
148− clientWithRoute
149− :: Proxy layout
150− -> Proxy m
151− -> Proxy tag
152− -> Req t
153− -> Dynamic t BaseUrl
154− -> ClientOptions
155− -> Client t m layout tag
156− clientWithRoute l m t r b o = clientWithRouteAndResultHandler l m t r b o return
157−
158− clientWithRouteAndResultHandler
159− :: Proxy layout
160− -> Proxy m
161− -> Proxy tag
162− -> Req t
163− -> Dynamic t BaseUrl
164− -> ClientOptions
165− -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
166− -> Client t m layout tag
131+ clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag
167132
168133
169134instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
170135 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
171136
172− clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =
173− clientWithRouteAndResultHandler (Proxy :: Proxy a) q pTag req baseurl opts wrap :<|>
174− clientWithRouteAndResultHandler (Proxy :: Proxy b) q pTag req baseurl opts wrap
137+ clientWithRoute Proxy q pTag req baseurl opts =
138+ clientWithRoute (Proxy :: Proxy a) q pTag req baseurl opts :<|>
139+ clientWithRoute (Proxy :: Proxy b) q pTag req baseurl opts
175140
176141
177142-- Capture. Example:
@@ -192,9 +157,11 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
192157 type Client t m (Capture capture a :> sublayout) tag =
193158 Dynamic t (Either Text a) -> Client t m sublayout tag
194159
195− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
196− clientWithRouteAndResultHandler
197− (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
160+ clientWithRoute Proxy q t req baseurl opts val =
161+ clientWithRoute (Proxy :: Proxy sublayout)
162+ q t
163+ (prependToPathParts p req)
164+ baseurl opts
198165 where p = (fmap . fmap) (toUrlPiece) val
199166
200167
@@ -207,8 +174,8 @@ instance {-# OVERLAPPABLE #-}
207174 Event t tag -> m (Event t (ReqResult tag a))
208175 -- TODO how to access input types here?
209176 -- ExceptT ServantError IO a
210− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
211− wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
177+ clientWithRoute Proxy _ _ req baseurl opts trigs =
178+ fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
212179 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
213180 req' = req { reqMethod = method }
214181
@@ -221,33 +188,29 @@ instance {-# OVERLAPPING #-}
221188 Event t tag -> m (Event t (ReqResult tag NoContent))
222189 -- TODO: how to access input types here?
223190 -- ExceptT ServantError IO NoContent
224− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
225− wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
191+ clientWithRoute Proxy _ _ req baseurl opts =
192+ (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl opts
226193 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
227194
228195
229196toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
230197toHeaders r =
231− let hdrs = maybe []
232− (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
198+ let toBS = E.encodeUtf8
199+ hdrs = maybe []
200+ (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
233201 (Map.toList $ _xhrResponse_headers xhr))
234202 (response r)
235203 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
236204
237−
238205class BuildHeaderKeysTo hs where
239− buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
206+ buildHeaderKeysTo :: Proxy hs -> [T.Text]
240207
241208instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
242209 where buildHeaderKeysTo _ = []
243210
244211instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
245212 => BuildHeaderKeysTo ((Header h v) ': xs) where
246− buildHeaderKeysTo _ =
247− let
248− thisKey = CI.mk $ T.pack (symbolVal (Proxy :: Proxy h))
249− in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)
250−
213+ buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
251214
252215-- HEADERS Verb (Content) --
253216-- Headers combinator not treated in fully general case,
@@ -262,10 +225,10 @@ instance {-# OVERLAPPABLE #-}
262225 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
263226 type Client t m (Verb method status cts' (Headers ls a)) tag =
264227 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
265− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
228+ clientWithRoute Proxy _ _ req baseurl opts trigs = do
266229 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
267230 resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
268− wrap $ toHeaders <$> resp
231+ return $ toHeaders <$> resp
269232 where req' = req { respHeaders =
270233 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
271234 }
@@ -278,10 +241,10 @@ instance {-# OVERLAPPABLE #-}
278241 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
279242 type Client t m (Verb method status cts (Headers ls NoContent)) tag
280243 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
281− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
244+ clientWithRoute Proxy _ _ req baseurl opts trigs = do
282245 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
283246 resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
284− wrap $ toHeaders <$> resp
247+ return $ toHeaders <$> resp
285248 where req' = req {respHeaders =
286249 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
287250 }
@@ -308,11 +271,11 @@ instance (KnownSymbol sym, ToHttpApiData a,
308271 type Client t m (Header sym a :> sublayout) tag =
309272 Dynamic t (Either Text a) -> Client t m sublayout tag
310273
311− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =
312− clientWithRouteAndResultHandler
313− (Proxy :: Proxy sublayout) q t
314− (Servant.Common.Req.addHeader hname eVal req)
315− baseurl opts wrap
274+ clientWithRoute Proxy q t req baseurl opts eVal =
275+ clientWithRoute (Proxy :: Proxy sublayout)
276+ q t
277+ (Servant.Common.Req.addHeader hname eVal req)
278+ baseurl opts
316279 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
317280
318281
@@ -326,21 +289,8 @@ instance HasClient t m sublayout tag
326289 type Client t m (HttpVersion :> sublayout) tag =
327290 Client t m sublayout tag
328291
329− clientWithRouteAndResultHandler Proxy =
330− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
331−
332−-- | Using a 'Summary' combinator in your API doesn't affect the client
333−-- functions.
334−instance (HasClient t m sublayout tag, KnownSymbol sym)
335− => HasClient t m (Summary sym :> sublayout) tag where
336−
337− type Client t m (Summary sym :> sublayout) tag =
338− Client t m sublayout tag
339−
340− clientWithRouteAndResultHandler Proxy =
341− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
342−
343−
292+ clientWithRoute Proxy q t =
293+ clientWithRoute (Proxy :: Proxy sublayout) q t
344294
345295
346296-- | If you use a 'QueryParam' in one of your endpoints in your API,
@@ -376,9 +326,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
376326 Dynamic t (QParam a) -> Client t m sublayout tag
377327
378328 -- if mparam = Nothing, we don't add it to the query string
379− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
380− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
381− (req {qParams = paramPair : qParams req}) baseurl opts wrap
329+ clientWithRoute Proxy q t req baseurl opts mparam =
330+ clientWithRoute (Proxy :: Proxy sublayout) q t
331+ (req {qParams = paramPair : qParams req}) baseurl opts
382332
383333 where pname = symbolVal (Proxy :: Proxy sym)
384334 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -422,8 +372,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
422372 type Client t m (QueryParams sym a :> sublayout) tag =
423373 Dynamic t [a] -> Client t m sublayout tag
424374
425− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
426− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
375+ clientWithRoute Proxy q t req baseurl opts paramlist =
376+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
427377
428378 where req' = req { qParams = (T.pack pname, params') : qParams req }
429379 pname = symbolVal (Proxy :: Proxy sym)
@@ -462,8 +412,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
462412 type Client t m (QueryFlag sym :> sublayout) tag =
463413 Dynamic t Bool -> Client t m sublayout tag
464414
465− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
466− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
415+ clientWithRoute Proxy q t req baseurl opts flag =
416+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
467417
468418 where req' = req { qParams = thisPair : qParams req }
469419 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -477,7 +427,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
477427 -> Event t tag
478428 -> m (Event t (ReqResult tag ()))
479429
480− clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
430+ clientWithRoute _ _ _ _ baseurl _ xhrs triggers = do
481431
482432 let xhrs' = liftA2 (\x path -> case x of
483433 Left e -> Left e
@@ -488,7 +438,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
488438 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
489439
490440 resps <- performRequestsAsync okReq
491− wrap $ leftmost [ uncurry RequestFailure <$> badReq
441+ return $ leftmost [ uncurry RequestFailure <$> badReq
492442 , evalResponse (const $ Right ()) <$> resps
493443 ]
494444
@@ -519,8 +469,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
519469 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
520470 Dynamic t (Either Text a) -> Client t m sublayout tag
521471
522− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
523− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
472+ clientWithRoute Proxy q t req baseurl opts body =
473+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
524474 where req' = req { reqBody = bodyBytesCT }
525475 ctProxy = Proxy :: Proxy ct
526476 ctString = T.pack $ show $ contentType ctProxy
@@ -534,9 +484,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
534484instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
535485 type Client t m (path :> sublayout) tag = Client t m sublayout tag
536486
537− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =
538− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
539− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap
487+ clientWithRoute Proxy q t req baseurl opts =
488+ clientWithRoute (Proxy :: Proxy sublayout) q t
489+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts
540490
541491 where p = symbolVal (Proxy :: Proxy path)
542492
@@ -544,23 +494,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient
544494instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
545495 type Client t m (Vault :> api) tag = Client t m api tag
546496
547− clientWithRouteAndResultHandler Proxy =
548− clientWithRouteAndResultHandler (Proxy :: Proxy api)
497+ clientWithRoute Proxy q t req baseurl =
498+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
549499
550500
551501instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
552502 type Client t m (RemoteHost :> api) tag = Client t m api tag
553503
554− clientWithRouteAndResultHandler Proxy =
555− clientWithRouteAndResultHandler (Proxy :: Proxy api)
504+ clientWithRoute Proxy q t req baseurl =
505+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
556506
557507
558508
559509instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
560510 type Client t m (IsSecure :> api) tag = Client t m api tag
561511
562− clientWithRouteAndResultHandler Proxy =
563− clientWithRouteAndResultHandler (Proxy :: Proxy api)
512+ clientWithRoute Proxy q t req baseurl =
513+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
564514
565515
566516instance (HasClient t m api tag, Reflex t)
@@ -569,8 +519,8 @@ instance (HasClient t m api tag, Reflex t)
569519 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
570520 -> Client t m api tag
571521
572− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
573− clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
522+ clientWithRoute Proxy q t req baseurl opts authdata =
523+ clientWithRoute (Proxy :: Proxy api) q t req' baseurl opts
574524 where
575525 req' = req { authData = Just authdata }
576526
@@ -613,7 +563,7 @@ for empty and one for non-empty lists).
613563instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where
614564
615565 type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag
616− clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)
566+ clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)
617567
618568
619569type family HasCookieAuth xs :: Constraint where
@@ -623,3 +573,136 @@ type family HasCookieAuth xs :: Constraint where
623573
624574class CookieAuthNotEnabled
625575
576+{- servant-checked-exceptions
577+~~~~~~~~~~~~~~~~~~~~~
578+-}
579+
580+-- | Change a 'Throws' into 'Throwing'.
581+instance (HasClient t m (Throwing '[e] :> api) tag) => HasClient t m (Throws e :> api) tag where
582+ type Client t m (Throws e :> api) tag = Client t m (Throwing '[e] :> api) tag
583+
584+ clientWithRoute
585+ :: Proxy (Throws e :> api)
586+ -> Proxy m
587+ -> Proxy tag
588+ -> Req t
589+ -> Dynamic t BaseUrl
590+ -> ClientOptions
591+ -> Client t m (Throwing '[e] :> api) tag
592+ clientWithRoute _ = clientWithRoute (Proxy :: Proxy (Throwing '[e] :> api))
593+
594+-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'
595+-- but returning an @'Envelope' es@.
596+instance (HasClient t m (Verb method status ctypes (Envelope es a)) tag) =>
597+ HasClient t m (Throwing es :> Verb method status ctypes a) tag where
598+
599+ type Client t m (Throwing es :> Verb method status ctypes a) tag =
600+ Client t m (Verb method status ctypes (Envelope es a)) tag
601+
602+ clientWithRoute
603+ :: Proxy (Throwing es :> Verb method status ctypes a)
604+ -> Proxy m
605+ -> Proxy tag
606+ -> Req t
607+ -> Dynamic t BaseUrl
608+ -> ClientOptions
609+ -> Client t m (Verb method status ctypes (Envelope es a)) tag
610+ clientWithRoute Proxy =
611+ clientWithRoute (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))
612+
613+-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'
614+-- but returning an @'Envelope' \'[]@.
615+instance (HasClient t m (Verb method status ctypes (Envelope '[] a)) tag) =>
616+ HasClient t m (NoThrow :> Verb method status ctypes a) tag where
617+
618+ type Client t m (NoThrow :> Verb method status ctypes a) tag =
619+ Client t m (Verb method status ctypes (Envelope '[] a)) tag
620+
621+ clientWithRoute
622+ :: Proxy (NoThrow :> Verb method status ctypes a)
623+ -> Proxy m
624+ -> Proxy tag
625+ -> Req t
626+ -> Dynamic t BaseUrl
627+ -> ClientOptions
628+ -> Client t m (Verb method status ctypes (Envelope '[] a)) tag
629+ clientWithRoute Proxy =
630+ clientWithRoute (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))
631+
632+-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each
633+-- branch of the API.
634+instance HasClient t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag =>
635+ HasClient t m (Throwing es :> (api1 :<|> api2)) tag where
636+
637+ type Client t m (Throwing es :> (api1 :<|> api2)) tag =
638+ Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag
639+
640+ clientWithRoute
641+ :: Proxy (Throwing es :> (api1 :<|> api2))
642+ -> Proxy m
643+ -> Proxy tag
644+ -> Req t
645+ -> Dynamic t BaseUrl
646+ -> ClientOptions
647+ -> Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag
648+ clientWithRoute _ =
649+ clientWithRoute (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))
650+
651+-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each branch of the
652+-- API.
653+instance HasClient t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag =>
654+ HasClient t m (NoThrow :> (api1 :<|> api2)) tag where
655+
656+ type Client t m (NoThrow :> (api1 :<|> api2)) tag =
657+ Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag
658+
659+ clientWithRoute
660+ :: Proxy (NoThrow :> (api1 :<|> api2))
661+ -> Proxy m
662+ -> Proxy tag
663+ -> Req t
664+ -> Dynamic t BaseUrl
665+ -> ClientOptions
666+ -> Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag
667+ clientWithRoute _ =
668+ clientWithRoute (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))
669+
670+-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the
671+-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other
672+-- combinator, push it down so it is closer to the 'Verb'.
673+instance HasClient t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag =>
674+ HasClient t m (Throwing es :> api :> apis) tag where
675+
676+ type Client t m (Throwing es :> api :> apis) tag =
677+ Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag
678+
679+ clientWithRoute
680+ :: Proxy (Throwing es :> api :> apis)
681+ -> Proxy m
682+ -> Proxy tag
683+ -> Req t
684+ -> Dynamic t BaseUrl
685+ -> ClientOptions
686+ -> Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag
687+ clientWithRoute _ =
688+ clientWithRoute (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))
689+
690+-- | When 'NoThrow' comes before any other combinator, push it down so it is
691+-- closer to the 'Verb'.
692+instance HasClient t m (api :> NoThrow :> apis) tag =>
693+ HasClient t m (NoThrow :> api :> apis) tag where
694+
695+ type Client t m (NoThrow :> api :> apis) tag =
696+ Client t m (api :> NoThrow :> apis) tag
697+
698+ clientWithRoute
699+ :: Proxy (NoThrow :> api :> apis)
700+ -> Proxy m
701+ -> Proxy tag
702+ -> Req t
703+ -> Dynamic t BaseUrl
704+ -> ClientOptions
705+ -> Client t m (api :> NoThrow :> apis) tag
706+ clientWithRoute _ =
707+ clientWithRoute (Proxy :: Proxy (api :> NoThrow :> apis))
708+
src/Servant/Reflex/Multi.hs+165−36
@@ -37,34 +37,32 @@ module Servant.Reflex.Multi (
3737 ) where
3838
3939------------------------------------------------------------------------------
40−import Control.Applicative (liftA2)
41−import Data.Functor.Compose (Compose (..), getCompose)
42−import Data.Proxy (Proxy (..))
43−import qualified Data.Set as Set
44−import Data.Text (Text)
45−import qualified Data.Text as T
46−import qualified Data.Text.Encoding as E
47−import GHC.TypeLits (KnownSymbol, symbolVal)
48−import Servant.API ((:<|>) (..), (:>), BasicAuth,
49− BasicAuthData, BuildHeadersTo (..),
50− Capture, Header, Headers (..),
51− HttpVersion, IsSecure,
52− MimeRender (..), MimeUnrender,
53− NoContent, QueryFlag, QueryParam,
54− QueryParams, Raw, ReflectMethod (..),
55− RemoteHost, ReqBody,
56− ToHttpApiData (..), Vault, Verb,
57− contentType)
58−import Servant.API.Description (Summary)
59−
60−import Reflex.Dom.Core (Dynamic, Event, Reflex,
61− XhrRequest (..),
62− XhrResponseHeaders (..),
63− attachPromptlyDynWith, constDyn)
40+import Control.Applicative (liftA2)
41+import Data.Functor.Compose (Compose (..), getCompose)
42+import Data.Proxy (Proxy (..))
43+import qualified Data.Set as Set
44+import Data.Text (Text)
45+import qualified Data.Text as T
46+import qualified Data.Text.Encoding as E
47+import GHC.TypeLits (KnownSymbol, symbolVal)
48+import Servant.API ((:<|>) (..), (:>), BasicAuth,
49+ BasicAuthData, BuildHeadersTo (..),
50+ Capture, Header, Headers (..),
51+ HttpVersion, IsSecure, MimeRender (..),
52+ NoContent, QueryFlag,
53+ QueryParam, QueryParams, Raw,
54+ ReflectMethod (..), RemoteHost,
55+ ReqBody, ToHttpApiData (..), Vault,
56+ Verb, contentType)
57+
58+import Reflex.Dom.Core (Dynamic, Event, Reflex,
59+ XhrRequest (..),
60+ XhrResponseHeaders (..),
61+ attachPromptlyDynWith, constDyn)
6462------------------------------------------------------------------------------
6563import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
6664 SupportsServantReflex)
67−import Servant.Common.Req (ClientOptions,
65+import Servant.Common.Req (ClientOptions, MimeUnrender,
6866 QParam (..), QueryPart (..), Req,
6967 ReqResult (..), addHeader, authData,
7068 defReq,
@@ -76,6 +74,8 @@ import Servant.Common.Req (ClientOptions,
7674 qParams, reqBody, reqFailure,
7775 reqMethod, reqSuccess, reqSuccess',
7876 respHeaders, response, withCredentials)
77+import Servant.Checked.Exceptions.Internal.Envelope (Envelope)
78+import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow, Throws, Throwing, ThrowingNonterminal)
7979import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
8080
8181
@@ -242,17 +242,6 @@ instance HasClientMulti t m sublayout f tag
242242 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
243243
244244
245−------------------------------------------------------------------------------
246−instance (HasClientMulti t m sublayout f tag, KnownSymbol sym)
247− => HasClientMulti t m (Summary sym :> sublayout) f tag where
248−
249− type ClientMulti t m (Summary sym :> sublayout) f tag =
250− ClientMulti t m sublayout f tag
251−
252− clientWithRouteMulti Proxy q f tag =
253− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
254−
255−
256245------------------------------------------------------------------------------
257246instance (KnownSymbol sym,
258247 ToHttpApiData a,
@@ -399,3 +388,143 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
399388 where
400389 req' a r = r { authData = Just (constDyn a) }
401390 reqs' = liftA2 req' <$> authdatas <*> reqs
391+
392+{- servant-checked-exceptions
393+~~~~~~~~~~~~~~~~~~~~~
394+-}
395+
396+-- | Change a 'Throws' into 'Throwing'.
397+instance (HasClientMulti t m (Throwing '[e] :> api) f tag) => HasClientMulti t m (Throws e :> api) f tag where
398+ type ClientMulti t m (Throws e :> api) f tag = ClientMulti t m (Throwing '[e] :> api) f tag
399+
400+ clientWithRouteMulti
401+ :: Proxy (Throws e :> api)
402+ -> Proxy m
403+ -> Proxy f
404+ -> Proxy tag
405+ -> Dynamic t (f (Req t))
406+ -> Dynamic t BaseUrl
407+ -> ClientOptions
408+ -> ClientMulti t m (Throwing '[e] :> api) f tag
409+ clientWithRouteMulti _ = clientWithRouteMulti (Proxy :: Proxy (Throwing '[e] :> api))
410+
411+-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'
412+-- but returning an @'Envelope' es@.
413+instance (HasClientMulti t m (Verb method status ctypes (Envelope es a)) f tag) =>
414+ HasClientMulti t m (Throwing es :> Verb method status ctypes a) f tag where
415+
416+ type ClientMulti t m (Throwing es :> Verb method status ctypes a) f tag =
417+ ClientMulti t m (Verb method status ctypes (Envelope es a)) f tag
418+
419+ clientWithRouteMulti
420+ :: Proxy (Throwing es :> Verb method status ctypes a)
421+ -> Proxy m
422+ -> Proxy f
423+ -> Proxy tag
424+ -> Dynamic t (f (Req t))
425+ -> Dynamic t BaseUrl
426+ -> ClientOptions
427+ -> ClientMulti t m (Verb method status ctypes (Envelope es a)) f tag
428+ clientWithRouteMulti Proxy =
429+ clientWithRouteMulti (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))
430+
431+-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'
432+-- but returning an @'Envelope' \'[]@.
433+instance (HasClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag) =>
434+ HasClientMulti t m (NoThrow :> Verb method status ctypes a) f tag where
435+
436+ type ClientMulti t m (NoThrow :> Verb method status ctypes a) f tag =
437+ ClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag
438+
439+ clientWithRouteMulti
440+ :: Proxy (NoThrow :> Verb method status ctypes a)
441+ -> Proxy m
442+ -> Proxy f
443+ -> Proxy tag
444+ -> Dynamic t (f (Req t))
445+ -> Dynamic t BaseUrl
446+ -> ClientOptions
447+ -> ClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag
448+ clientWithRouteMulti Proxy =
449+ clientWithRouteMulti (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))
450+
451+-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each
452+-- branch of the API.
453+instance HasClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag =>
454+ HasClientMulti t m (Throwing es :> (api1 :<|> api2)) f tag where
455+
456+ type ClientMulti t m (Throwing es :> (api1 :<|> api2)) f tag =
457+ ClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag
458+
459+ clientWithRouteMulti
460+ :: Proxy (Throwing es :> (api1 :<|> api2))
461+ -> Proxy m
462+ -> Proxy f
463+ -> Proxy tag
464+ -> Dynamic t (f (Req t))
465+ -> Dynamic t BaseUrl
466+ -> ClientOptions
467+ -> ClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag
468+ clientWithRouteMulti _ =
469+ clientWithRouteMulti (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))
470+
471+-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each branch of the
472+-- API.
473+instance HasClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag =>
474+ HasClientMulti t m (NoThrow :> (api1 :<|> api2)) f tag where
475+
476+ type ClientMulti t m (NoThrow :> (api1 :<|> api2)) f tag =
477+ ClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag
478+
479+ clientWithRouteMulti
480+ :: Proxy (NoThrow :> (api1 :<|> api2))
481+ -> Proxy m
482+ -> Proxy f
483+ -> Proxy tag
484+ -> Dynamic t (f (Req t))
485+ -> Dynamic t BaseUrl
486+ -> ClientOptions
487+ -> ClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag
488+ clientWithRouteMulti _ =
489+ clientWithRouteMulti (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))
490+
491+-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the
492+-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other
493+-- combinator, push it down so it is closer to the 'Verb'.
494+instance HasClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag =>
495+ HasClientMulti t m (Throwing es :> api :> apis) f tag where
496+
497+ type ClientMulti t m (Throwing es :> api :> apis) f tag =
498+ ClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag
499+
500+ clientWithRouteMulti
501+ :: Proxy (Throwing es :> api :> apis)
502+ -> Proxy m
503+ -> Proxy f
504+ -> Proxy tag
505+ -> Dynamic t (f (Req t))
506+ -> Dynamic t BaseUrl
507+ -> ClientOptions
508+ -> ClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag
509+ clientWithRouteMulti _ =
510+ clientWithRouteMulti (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))
511+
512+-- | When 'NoThrow' comes before any other combinator, push it down so it is
513+-- closer to the 'Verb'.
514+instance HasClientMulti t m (api :> NoThrow :> apis) f tag =>
515+ HasClientMulti t m (NoThrow :> api :> apis) f tag where
516+
517+ type ClientMulti t m (NoThrow :> api :> apis) f tag =
518+ ClientMulti t m (api :> NoThrow :> apis) f tag
519+
520+ clientWithRouteMulti
521+ :: Proxy (NoThrow :> api :> apis)
522+ -> Proxy m
523+ -> Proxy f
524+ -> Proxy tag
525+ -> Dynamic t (f (Req t))
526+ -> Dynamic t BaseUrl
527+ -> ClientOptions
528+ -> ClientMulti t m (api :> NoThrow :> apis) f tag
529+ clientWithRouteMulti _ =
530+ clientWithRouteMulti (Proxy :: Proxy (api :> NoThrow :> apis))
testdriver/test/Servant/ReflexSpec.hs+1−2
@@ -9,7 +9,6 @@ import qualified Data.Text as T
99import Data.Foldable
1010import Test.WebDriver.Commands.Wait
1111import Test.Hspec.WebDriver
12−import Test.Hspec.WebDriver (chromeCaps)
1312
1413
1514clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()
@@ -29,7 +28,7 @@ spec :: Spec
2928spec = do
3029 describe "servant-reflex tests" $ do
3130
32− session "test page" $ using [chromeCaps] $ do
31+ session "test page" $ using Chrome $ do
3332
3433 it "opens the page" $ runWD $
3534 openPage "http://localhost:8000"
testserver/API.hsmode 100644 → 120000+1−69
@@ -1,69 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TypeOperators #-}
4−
5−module API where
6−
7−import Data.Aeson
8−import Data.Aeson.Types (typeMismatch)
9−import Data.Text (Text)
10−import Servant.API
11−
12−newtype Question = Question { unQuestion :: Text } deriving (Show)
13−
14−instance ToJSON Question where
15− toJSON (Question txt) = object ["question" .= txt]
16−
17−instance FromJSON Question where
18− parseJSON (Object v) = Question <$> v .: "question"
19− parseJSON x = typeMismatch "Couldn't find key 'question'" x
20−
21−newtype Answer = Answer { unAnswer :: Text } deriving (Show)
22−
23−instance ToJSON Answer where
24− toJSON (Answer txt) = object ["answer" .= txt]
25−
26−instance FromJSON Answer where
27− parseJSON (Object v) = Answer <$> v .: "answer"
28− parseJSON x = typeMismatch "Couldn't find key 'answer'" x
29−
30−
31−-- | API spec for server, client, and docs
32−type API = "getunit" :> Get '[JSON] ()
33− :<|> "getint" :> Get '[JSON] Int
34− :<|> "sayhi" :> QueryParam "username" Text
35− :> QueryParams "greetings" Text
36− :> QueryFlag "gusto"
37− :> Get '[JSON] Text
38− :<|> "double" :> ReqBody '[JSON] Double
39− :> Post '[JSON] Double
40− :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
41− :<|> "qna" :> ReqBody '[JSON] Question
42− :> Post '[JSON] Answer
43− :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
44− :<|> Raw
45−
46−type GET = Get '[JSON] ()
47−
48−-- Imported the comprehensive API example for testing.
49−-- https://github.com/haskell-servant/servant/blob/master/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs
50−type ComprehensiveAPI =
51− GET :<|>
52− Get '[JSON] Int :<|>
53− Capture "foo" Int :> GET :<|>
54− Header "foo" Int :> GET :<|>
55− HttpVersion :> GET :<|>
56− IsSecure :> GET :<|>
57− QueryParam "foo" Int :> GET :<|>
58− QueryParams "foo" Int :> GET :<|>
59− QueryFlag "foo" :> GET :<|>
60−-- Raw :<|>
61− RemoteHost :> GET :<|>
62− ReqBody '[JSON] Int :> GET :<|>
63− Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>
64− "foo" :> GET :<|>
65− Vault :> GET :<|>
66− Verb 'POST 204 '[JSON] () :<|>
67− Verb 'POST 204 '[JSON] Int
68−-- This one isn't in scope
69−-- :<|> WithNamedContext "foo" '[] GET
@@ -0,0 +1 @@
1+../exec/API.hs
testserver/Main.hs+3−10
@@ -7,12 +7,10 @@
77{-# LANGUAGE TypeOperators #-}
88
99import Control.Monad.IO.Class (liftIO)
10−import Control.Monad.Reader (reader)
1110import Data.Aeson
1211import Data.Bool
1312import Data.Char (toUpper)
1413import qualified Data.List as L
15−import Data.Maybe (fromMaybe)
1614import Data.Monoid
1715import Data.Proxy
1816import Data.Text hiding (head, length, map,
@@ -27,7 +25,6 @@ import Snap.Http.Server
2725import Servant
2826import Servant.Server
2927-- import Snap.Util.FileServe
30−import System.Environment (lookupEnv)
3128import API
3229import Snap
3330
@@ -43,7 +40,7 @@ instance ToJSON Greet
4340testApi :: Proxy API
4441testApi = Proxy
4542
46−data App = App { appStaticDir :: String }
43+data App = App
4744
4845-- Server-side handlers.
4946--
@@ -54,7 +51,7 @@ data App = App { appStaticDir :: String }
5451server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
5552server = return () :<|> return 100 :<|> sayhi :<|> dbl
5653 :<|> multi :<|> qna :<|> serveSecret
57− :<|> statics
54+ :<|> serveDirectory "static"
5855 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
5956 sayhi nm greetings withGusto = case nm of
6057 Nothing -> return ("Sorry, who are you?" :: Text)
@@ -79,9 +76,6 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl
7976 req <- getRequest
8077 liftIO $ putStrLn (show req)
8178 return 101
82− statics = do
83− staticDir <- reader appStaticDir
84− serveDirectory staticDir
8579
8680-- Turn the server into a WAI app. 'serve' is provided by servant,
8781-- more precisely by the Servant.Server module.
@@ -91,11 +85,10 @@ test = serveSnapWithContext testApi
9185
9286initApp :: SnapletInit App App
9387initApp = makeSnaplet "myapp" "example" Nothing $ do
94− staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")
9588 addRoutes [("", test)
9689 ,("", serveDirectory "static")
9790 ]
98− return (App staticDir)
91+ return App
9992
10093-- Put this all to work!
10194main :: IO ()
testserver/run-wd-tests.shnew file+5
@@ -0,0 +1,5 @@
1+#!/usr/bin/env bash
2+
3+dist/build/back/back -p 8000 &
4+phantomjs --webdriver=127.0.0.1:4444 &
5+dist/build/spec/spec
testserver/testserver.cabal+4−5
@@ -19,13 +19,12 @@ executable back
1919 main-is: Main.hs
2020 -- other-modules:
2121 -- other-extensions:
22− build-depends: aeson >= 0.9 && < 1.5
23− , base >=4.8 && < 5
24− , mtl
22+ build-depends: aeson >= 0.9 && < 1.4
23+ , base >=4.8 && <4.11
2524 , snap >= 1.0 && < 1.2
26− , snap-server >= 1.0 && < 1.2
25+ , snap-server >= 1.0 && < 1.1
2726 , snap-core >= 1.0 && < 1.1
28− , servant >= 0.16 && < 0.18
27+ , servant >= 0.8 && < 0.12
2928 , servant-snap >= 0.8 && < 0.9
3029 , text >= 1.0 && < 1.3
3130 -- hs-source-dirs:
testserver/tr.nixnew file+32
@@ -0,0 +1,32 @@
1+{ reflex-platform, ... }:
2+let
3+
4+ dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;
5+ cabal2nixResult = reflex-platform.cabal2nixResult;
6+ nixpkgs = (import <nixpkgs> {});
7+in
8+reflex-platform.ghc.override {
9+ overrides = self: super: {
10+ servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});
11+ snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap) {});
12+ io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});
13+ io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});
14+ heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});
15+ xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});
16+ snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});
17+ snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});
18+ snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});
19+ snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});
20+ hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});
21+
22+ # servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});
23+ # servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});
24+ # servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});
25+ # servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});
26+ # servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});
27+ # servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});
28+ # servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});
29+ # servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});
30+
31+ };
32+}
travis.nixdeleted−70
@@ -1,70 +0,0 @@
1−{
2− nativeCompiler ? "ghc",
3− # ^ Choose a GHC for compiling backend components (web server, selenium)
4− # (ghc, ghc8_0, ghc8_2, ghc8_4 or ghcHEAD)
5−
6− jsCompiler ? "ghcjs"
7− # ^ Choose a GHCJS for compiling the frontend
8− # (ghcjs, ghcjs8_0, ghcjs8_2 or ghcjs8_4)
9−
10−}:
11−
12−let
13−
14− reflexPlatform = import ./nix/reflex-platform.nix;
15−
16− lib = reflexPlatform.nixpkgs.haskell.lib;
17− do = funs: pkg: builtins.foldl' (a: b: b a) pkg funs;
18−
19− ghcjsPkgs = with lib; reflexPlatform.${jsCompiler}.override {
20− overrides = self: super: {
21− http-media = dontCheck super.http-media;
22− servant = dontCheck super.servant;
23− lens-aeson = dontCheck super.lens-aeson;
24− servant-reflex = lib.appendConfigureFlag
25− (self.callPackage ./default.nix {}) "-fExample";
26− };
27− };
28−
29− ghcPkgs = with lib; reflexPlatform.${nativeCompiler}.override {
30− overrides = self: super: {
31− servant-snap = dontCheck ((import ./nix/servant-snap.nix {}) self super);
32− testdriver = self.callCabal2nix "testdriver" ./testdriver {};
33− testserver = import nix/testserver.nix ghcjsPkgs.servant-reflex self super;
34− servant-reflex = self.callPackage ./default.nix {};
35− };
36− };
37−
38− testresults = import ./nix/testresults.nix
39− { inherit reflexPlatform;
40− inherit (ghcPkgs) testserver testdriver;
41− inherit (reflexPlatform.nixpkgs) curl;
42− phantomjs = reflexPlatform.nixpkgs.phantomjs2;
43− };
44−
45−in
46− rec {
47−
48− inherit reflexPlatform ghcPkgs ghcjsPkgs;
49−
50− build = ghcjsPkgs.servant-reflex;
51− buildGhc = ghcPkgs.servant-reflex;
52− testserver = ghcPkgs.testserver;
53− testdriver = ghcPkgs.testdriver;
54− inherit testresults;
55−
56− cabalBuild = reflexPlatform.${jsCompiler}.shellFor {
57− name = "servant-reflex-cabal-builder";
58−
59− packages = p: [
60− build
61− ];
62−
63− shellHook = ''
64− cabal configure --ghcjs -f Example
65− cabal build
66− exec/toSite.sh
67− exit $?
68− '';
69− };
70− }