on master help sign in
32 files changed+650−518
since splitsnapshots
unifiedsplit
.gitignore+2 .gitmodules−12 .travis.yml+12−56 changelog.md → ChangeLog.md+14−1 README.md+70−33 build.sh−3 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+24−18 shell.nix+1 src/Servant/Common/BaseUrl.hs+4−5 src/Servant/Common/Req.hs+104−138 src/Servant/Reflex.hs+161−157 src/Servant/Reflex/Multi.hs+36−23 testdriver/test/Servant/ReflexSpec.hs+2−1 testserver/API.hs+69−1 testserver/Main.hs+10−3 testserver/run-wd-tests.sh−5 testserver/testserver.cabal+5−4 testserver/tr.nix−32 travis.nix+70
.gitignore+2
@@ -7,3 +7,5 @@ log
77*.stats
88out
99/.stack-work/
10+TAGS
11+dist-newstyle
.gitmodules−12
@@ -1,12 +0,0 @@
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+12−56
@@ -1,61 +1,17 @@
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−
1+language: nix
2+nix: 2.3.6
3+sudo: require
214
225before_install:
23− - unset CC
24− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
25− - git submodule update --init --recursive
6+ - sudo cp -rT $TRAVIS_BUILD_DIR/nix /etc/nix
267
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
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"
4512
4613script:
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"
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
changelog.md → ChangeLog.mdrenamed+14−1
@@ -1,7 +1,20 @@
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+
1140.3.3
215-----
316
4−Explicitly escape reserved characters from path pieces and query parameters
17+- Fix encoding issue: Explicitly escape reserved characters from path pieces and query parameters
518
619
7200.3.2
README.md+70−33
@@ -4,14 +4,19 @@
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 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−
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.
1014
1115
1216## Example
1317
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:
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:
1520
1621```haskell
1722type API = "getint" :> Get '[JSON] Int
@@ -24,7 +29,8 @@ type API = "getint" :> Get '[JSON] Int
2429 :<|> Raw
2530```
2631
27−`servant-reflex` then computes client functions that can query the API through an `XhrRequest`.
32+`servant-reflex` then computes client functions that can query the API through
33+an `XhrRequest`.
2834
2935```haskell
3036
@@ -37,7 +43,16 @@ type API = "getint" :> Get '[JSON] Int
3743 (constDyn (BasePath "/"))
3844```
3945
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.
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.
4156
4257```haskell
4358 -- No need to write these functions. servant-reflex creates them for you!
@@ -62,7 +77,13 @@ These client functions are computed from your API type. They manage serializatio
6277 -> m (Event t (ReqResult () Double))
6378```
6479
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:
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:
6687
6788```haskell
6889 -- ... continued ...
@@ -80,7 +101,8 @@ These client functions are computed from your API type. They manage serializatio
80101 dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])
81102```
82103
83−This example builds some input fields to enter API parameters, buttons to trigger the API calls, and text elements to show the results:
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:
84106
85107```haskell
86108 elClass "div" "int-demo" $ do
@@ -103,47 +125,53 @@ This example builds some input fields to enter API parameters, buttons to trigge
103125 display =<< holdDyn Nothing outputDouble
104126```
105127
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.
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.
107133
108134
109135## Building the library and test server
110136
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:
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.
115144
116145```
117−git submodule update --init --recursive
118−./build.sh
146+nix build -f travis.nix testserver -o server
119147```
120148
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:
149+Point it at the static directory and run it:
131150
132151```
133−cd testserver
134−dist/build/back/back -p 8001
152+STATIC_DIR=server/static server/back -p 8000
135153```
136154
137−And simply browse to `localhost:8001`
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.
138158
139−**For a larger example of a project that shares types between backend and frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
159+**For a larger example of a project that shares types between backend and
160+frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
140161
141162
142163## Tagging requests
143164
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.
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.
145169
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:
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:
147175
148176```haskell
149177 ...
@@ -173,7 +201,10 @@ So far we have used an `Event t ()` to trigger sending a request. If we choose e
173201
174202## Simultaneous requests
175203
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:
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:
177208
178209```haskell
179210sayHi
@@ -184,4 +215,10 @@ sayHi
184215 -> m (Event t (f (ReqResult tag Text)))
185216```
186217
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.
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.
build.shdeleted−3
@@ -1,3 +0,0 @@
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"
default.nixnew file+21
@@ -0,0 +1,21 @@
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-datadeleted−1

Submodule changed.

deps/reflex-platformdeleted−1

Submodule changed.

deps/servantdeleted−1

Submodule changed.

deps/servant-snapdeleted−1

Submodule changed.

exec/Example.hs+2−2
@@ -21,7 +21,8 @@ import Servant.API
2121import API
2222import Data.Proxy
2323import Text.Read (readMaybe)
24−import Reflex.Dom hiding (run)
24+import Reflex.Dom.Core hiding (run, mainWidget)
25+import Reflex.Dom (mainWidget)
2526------------------------------------------------------------------------------
2627import Servant.Reflex
2728import Servant.Reflex.Multi
@@ -97,7 +98,6 @@ run = mdo
9798
9899 -- Name the computed API client functions
99100 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.confnew file+3
@@ -0,0 +1,3 @@
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.nixnew file+7
@@ -0,0 +1,7 @@
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.nixnew file+7
@@ -0,0 +1,7 @@
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.nixnew file+17
@@ -0,0 +1,17 @@
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.nixnew file+9
@@ -0,0 +1,9 @@
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.nixdeleted−11
@@ -1,11 +0,0 @@
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.nixdeleted−9
@@ -1,9 +0,0 @@
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+24−18
@@ -1,7 +1,7 @@
11Name: servant-reflex
2−Version: 0.3.3
3−Synopsis: Servant reflex API generator
4−Description: Servant reflex API generator
2+Version: 0.3.6
3+Synopsis: servant API generator for reflex apps
4+Description: Generate reflex-compatible client functions from servant API descriptions
55License: BSD3
66License-file: LICENSE.md
77Author: Greg Hale, Doug Beardsley
@@ -17,38 +17,35 @@ Flag Example
1717
1818library
1919 exposed-modules:
20− Servant.Reflex
21− Servant.Reflex.Multi
22−
23− other-modules:
2420 Servant.Common.BaseUrl
2521 Servant.Common.Req
22+ Servant.Reflex
23+ Servant.Reflex.Multi
2624
2725 hs-source-dirs: src
2826 build-depends:
29− base >= 4.8 && < 4.10,
30− aeson >= 0.11 && < 1.3,
27+ base >= 4.8 && < 5,
3128 bytestring >= 0.10 && < 0.11,
3229 case-insensitive >= 1.2.0.4 && < 1.3,
33− containers >= 0.5.6 && < 0.6,
30+ containers >= 0.5.6 && < 0.7,
3431 data-default >= 0.5 && < 0.8,
35− exceptions >= 0.8 && < 0.9,
32+ exceptions >= 0.8 && < 0.11,
3633 ghcjs-dom >= 0.2 && < 0.10,
37− http-api-data >= 0.3.6 && < 0.4,
38− http-media >= 0.6 && < 0.7,
34+ http-api-data >= 0.3.6 && < 0.5,
35+ http-media >= 0.6 && < 0.9,
3936 jsaddle >= 0.8 && < 0.10,
4037 mtl >= 2.2.1 && < 2.3,
4138 network-uri >= 2.6 && < 2.7,
42− reflex >= 0.5 && < 0.6,
43− reflex-dom-core == 0.4 && < 0.5,
39+ reflex >= 0.5 && < 0.9,
40+ reflex-dom-core >= 0.6 && < 0.7,
4441 safe >= 0.3.9 && < 0.4,
45− servant >= 0.8 && < 0.12,
42+ servant >= 0.16 && < 0.18,
4643 servant-auth >= 0.2.1 && < 0.4,
4744 string-conversions >= 0.4 && < 0.5,
4845 text >= 1.2 && < 1.3,
4946 transformers >= 0.4 && < 0.6
5047
51− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
48+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
5249
5350 default-language: Haskell2010
5451
@@ -57,7 +54,16 @@ executable example
5754 buildable: True
5855 else
5956 buildable: False
60− build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text
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
6167 default-language: Haskell2010
6268 main-is: Example.hs
6369 other-modules: API
shell.nixnew file+1
@@ -0,0 +1 @@
1+(import ./travis.nix {nativeCompiler = "ghc";}).ghcPkgs.servant-reflex.env
src/Servant/Common/BaseUrl.hs+4−5
@@ -85,15 +85,14 @@ baseUrlWidget = elClass "div" "base-url" $ do
8585 where pathWidget :: m (Dynamic t BaseUrl)
8686 pathWidget = do
8787 text "Url base path"
88− t <- textInput (def {_textInputConfig_attributes =
89− constDyn ("placeholder" =: "/a/b")})
88+ t <- inputElement def
9089 return $ BasePath <$> value t
9190 fullUrlWidget :: m (Dynamic t BaseUrl)
9291 fullUrlWidget = do
9392 schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def
94− srv <- textInput def {_textInputConfig_attributes = constDyn $ "placeholder" =: "example.com"}
93+ srv <- inputElement def
9594 text ":"
96− prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}
95+ prt <- inputElement def
9796 port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))
98− path <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "a/b" }
97+ path <- inputElement def
9998 return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path
src/Servant/Common/Req.hs+104−138
@@ -1,61 +1,46 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE ExistentialQuantification #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE FunctionalDependencies #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE LambdaCase #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE NamedFieldPuns #-}
11−{-# LANGUAGE OverloadedStrings #-}
12−{-# LANGUAGE RankNTypes #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE TupleSections #-}
15−{-# OPTIONS_GHC -fno-warn-orphans #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TupleSections #-}
1610
1711module Servant.Common.Req where
1812
1913-------------------------------------------------------------------------------
20−import Control.Applicative (liftA2, liftA3)
14+import Control.Applicative (liftA2, liftA3)
15+import Control.Arrow ((&&&))
2116import Control.Concurrent
22−import Control.Monad (join)
23−import Control.Monad.IO.Class (MonadIO, liftIO)
24−import Data.Aeson
25−import Data.Bifunctor (first)
26−import qualified Data.ByteString as BS
27−import qualified Data.ByteString.Builder as BB
28−import Data.ByteString.Lazy (ByteString)
29−import qualified Data.ByteString.Lazy.Char8 as BL
17+import Control.Monad (join)
18+import Control.Monad.IO.Class (MonadIO, liftIO)
19+import Data.Bifunctor (first)
20+import qualified Data.ByteString.Builder as Builder
21+import qualified Data.ByteString.Lazy.Char8 as BL
22+import Data.ByteString (ByteString)
23+import qualified Data.Map as Map
24+import Data.Maybe (catMaybes, fromMaybe)
3025import Data.Functor.Compose
31−import qualified Data.JSString.Text as JS (lazyTextFromJSString)
32−import qualified Data.Map as Map
33−import Data.Maybe (catMaybes, fromMaybe)
34−import Data.Monoid ((<>))
35−import Data.Proxy (Proxy (..))
36−import Data.Text (Text)
37−import qualified Data.Text as T
38−import qualified Data.Text.Encoding as T
39−import qualified Data.Text.Lazy as TL
40−import Data.Traversable (forM)
41−import qualified Language.Javascript.JSaddle as JS
26+import Data.Monoid ((<>))
27+import Data.Proxy (Proxy(..))
28+import Data.Text (Text)
29+import qualified Data.Text as T
30+import qualified Data.Text.Encoding as TE
31+import Data.Traversable (forM)
4232import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
43−import qualified Network.URI as N
44−import Reflex.Dom.Core hiding (tag)
45−import Servant.API.ContentTypes (Accept, FormUrlEncoded,
46− JSON, NoContent (..),
47− OctetStream, PlainText)
48−import Servant.Common.BaseUrl (BaseUrl,
49− SupportsServantReflex,
50− showBaseUrl)
51−import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)
52−import Web.HttpApiData (ToHttpApiData (..))
33+import qualified Network.URI as N
34+import Reflex.Dom.Core hiding (tag)
35+import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
36+ SupportsServantReflex)
37+import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
38+import Web.HttpApiData (ToHttpApiData(..))
5339-------------------------------------------------------------------------------
5440import Servant.API.BasicAuth
55−-------------------------------------------------------------------------------
5641
57−jsonDecode = undefined
58−-----------------------------------------------------------------------------
42+
43+------------------------------------------------------------------------------
5944-- | The result of a request event
6045data ReqResult tag a
6146 = ResponseSuccess tag a XhrResponse
@@ -108,6 +93,13 @@ reqFailure (ResponseFailure _ s _) = Just s
10893reqFailure (RequestFailure _ s) = Just s
10994reqFailure _ = Nothing
11095
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+
111103
112104------------------------------------------------------------------------------
113105-- | Simple filter/accessor for the raw XHR response
@@ -149,42 +141,34 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
149141-------------------------------------------------------------------------------
150142-- The data structure used to build up request information while traversing
151143-- the shape of a servant API
152−data Req t = forall o. (IsXhrPayload o, Show o) => Req
144+data Req t = Req
153145 { reqMethod :: Text
154146 , reqPathParts :: [Dynamic t (Either Text Text)]
155147 , qParams :: [(Text, QueryPart t)]
156− , reqBody :: Maybe (Dynamic t (Either Text (o, Text)))
148+ , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))
157149 , headers :: [(Text, Dynamic t (Either Text Text))]
158150 , respHeaders :: XhrResponseHeaders
159151 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))
160152 }
161153
162154defReq :: Req t
163−defReq = Req "GET" [] [] (Nothing :: Maybe (Dynamic t (Either Text ((), Text)))) [] def Nothing
155+defReq = Req "GET" [] [] Nothing [] def Nothing
164156
165157prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t
166158prependToPathParts p req =
167159 req { reqPathParts = p : reqPathParts req }
168160
169161addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
170−addHeader name val req = req { headers = (name, (fmap . fmap) (T.decodeUtf8 . toHeader) val) : headers req }
171−
162+addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
172163
173−-- class ReflexDom'MimeRender a b | b -> a where
174−-- ghcjsMimerender :: IsXhrPayload c => Proxy a -> b -> c
175−
176−-- instance ReflexDom'MimeRender BL.ByteString Blob where
177−-- ghcjsMimerender _ = id
178−
179−data SomeXhrRequest = forall o. (IsXhrPayload o, Show o) => SomeXhrRequest (XhrRequest (Maybe o))
180164
181165reqToReflexRequest
182− :: forall t. Reflex t
183− => Text
184− -> Dynamic t BaseUrl
185− -> Req t
186− -> Dynamic t (Either Text SomeXhrRequest)
187−reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (Either Text (o, Text)))) _ _ _) =
166+ :: forall t. Reflex t
167+ => Text
168+ -> Dynamic t BaseUrl
169+ -> Req t
170+ -> Dynamic t (Either Text (XhrRequest XhrPayload))
171+reqToReflexRequest reqMeth reqHost req =
188172 let t :: Dynamic t [Either Text Text]
189173 t = sequence $ reverse $ reqPathParts req
190174
@@ -236,33 +220,33 @@ reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (
236220 fmap (fmap (\rightVal -> (headerName, rightVal))) dynam
237221
238222 mkConfigBody :: Either Text [(Text,Text)]
239− -> (Either Text (o, Text))
240− -> Either Text (XhrRequestConfig (Maybe o))
223+ -> (Either Text (BL.ByteString, Text))
224+ -> Either Text (XhrRequestConfig XhrPayload)
241225 mkConfigBody ehs rb = case (ehs, rb) of
242226 (_, Left e) -> Left e
243227 (Left e, _) -> Left e
244228 (Right hs, Right (bBytes, bCT)) ->
245229 Right $ XhrRequestConfig
246− { _xhrRequestConfig_sendData = Just bBytes
230+ { _xhrRequestConfig_sendData = bytesToPayload bBytes
247231 , _xhrRequestConfig_headers =
248232 Map.insert "Content-Type" bCT (Map.fromList hs)
249233 , _xhrRequestConfig_user = Nothing
250234 , _xhrRequestConfig_password = Nothing
251− , _xhrRequestConfig_responseType = Nothing
235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
252236 , _xhrRequestConfig_withCredentials = False
253237 , _xhrRequestConfig_responseHeaders = def
254238 }
255239
256− xhrOpts :: Dynamic t (Either Text (XhrRequestConfig (Maybe o)))
257− xhrOpts = case reqBody of
240+ xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))
241+ xhrOpts = case reqBody req of
258242 Nothing -> ffor xhrHeaders $ \case
259243 Left e -> Left e
260244 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
261245 , _xhrRequestConfig_user = Nothing
262246 , _xhrRequestConfig_password = Nothing
263− , _xhrRequestConfig_responseType = Nothing
247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
248+ , _xhrRequestConfig_sendData = mempty
264249 , _xhrRequestConfig_withCredentials = False
265− , _xhrRequestConfig_sendData = Nothing
266250 }
267251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
268252
@@ -270,16 +254,16 @@ reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (
270254 mkAuth _ (Left e) = Left e
271255 mkAuth Nothing r = r
272256 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config
273− { _xhrRequestConfig_user = Just $ T.decodeUtf8 u
274− , _xhrRequestConfig_password = Just $ T.decodeUtf8 p}
257+ { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
258+ , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
275259
276260 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
277261 -> Dynamic t (Either Text (XhrRequestConfig x))
278262 addAuth xhr = case authData req of
279− Nothing -> xhr
263+ Nothing -> xhr
280264 Just auth -> liftA2 mkAuth auth xhr
281265
282− xhrReq = (liftA2 . liftA2) (\p opt -> SomeXhrRequest $ XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
266+ xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
283267
284268 in xhrReq
285269
@@ -288,11 +272,8 @@ reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (
288272displayHttpRequest :: Text -> Text
289273displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
290274
291−instance IsXhrPayload o => IsXhrPayload (Maybe o) where
292− sendXhrPayload xhr = maybe (sendXhrPayload xhr ()) (sendXhrPayload xhr)
293−
294275-- | This function performs the request
295−performRequests :: forall t m f tag. (SupportsServantReflex t m, Traversable f)
276+performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
296277 => Text
297278 -> Dynamic t (f (Req t))
298279 -> Dynamic t BaseUrl
@@ -305,7 +286,6 @@ performRequests reqMeth rs reqHost opts trigger = do
305286 reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
306287
307288 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
308− reqs :: Event t (Compose ((,) tag) f (Either Text SomeXhrRequest))
309289 reqs = attachPromptlyDynWith
310290 (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
311291
@@ -321,31 +301,32 @@ performSomeRequestsAsync
321301 HasWebView (Performable m),
322302 PerformEvent t m,
323303 TriggerEvent t m,
324− Traversable f
304+ Traversable f,
305+ IsXhrPayload a,
306+ Show a
325307 )
326308 => ClientOptions
327− -> Event t (f (Either Text SomeXhrRequest))
309+ -> Event t (f (Either Text (XhrRequest a)))
328310 -> m (Event t (f (Either Text XhrResponse)))
329−performSomeRequestsAsync opts sxhr =
330− performSomeRequestsAsync' opts newXMLHttpRequest $ return <$> sxhr
311+performSomeRequestsAsync opts =
312+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
331313
332314
333315------------------------------------------------------------------------------
334316-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
335317-- that accepts 'f (Either e (XhrRequestb))' events
336318performSomeRequestsAsync'
337− :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
319+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
338320 => ClientOptions
339− -> (forall b. IsXhrPayload b => XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
340− -> Event t (Performable m (f (Either Text SomeXhrRequest)))
341− -> m (Event t (f (Either Text a)))
321+ -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
322+ -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
342323performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
343324 rs <- hrs
344325 resps <- forM rs $ \r -> case r of
345326 Left e -> do
346327 resp <- liftIO $ newMVar (Left e)
347328 return resp
348− Right (SomeXhrRequest r') -> do
329+ Right r' -> do
349330 resp <- liftIO newEmptyMVar
350331 r'' <- liftJSM $ (optsRequestFixup opts) r'
351332 _ <- newXhr r'' $ liftIO . putMVar resp . Right
@@ -354,6 +335,12 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs
354335 return ()
355336
356337
338+
339+type XhrPayload = ByteString
340+bytesToPayload :: BL.ByteString -> XhrPayload
341+bytesToPayload = BL.toStrict
342+
343+
357344performRequestsCT
358345 :: (SupportsServantReflex t m,
359346 MimeUnrender ct a, Traversable f)
@@ -366,14 +353,15 @@ performRequestsCT
366353 -> m (Event t (f (ReqResult tag a)))
367354performRequestsCT ct reqMeth reqs reqHost opts trigger = do
368355 resps <- performRequests reqMeth reqs reqHost opts trigger
369− let decodeResp x = first T.pack
370− . mimeUnrender ct
371− . JS.textToJSString
372− =<< note "No body text" (_xhrResponse_responseText x)
356+ let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
357+ first T.pack .
358+ mimeUnrender ct $
359+ BL.fromStrict x
360+ decodeResp _ = Left "No body"
373361 return $ fmap
374362 (\(t,rs) -> ffor rs $ \r -> case r of
375363 Left e -> RequestFailure t e
376− Right g -> evalResponse decodeResp (t,g)
364+ Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
377365 )
378366 resps
379367
@@ -400,8 +388,9 @@ evalResponse
400388 :: (XhrResponse -> Either Text a)
401389 -> (tag, XhrResponse)
402390 -> ReqResult tag a
403−evalResponse decodeRes (tag, xhr) =
404− let okStatus = _xhrResponse_status xhr < 400
391+evalResponse decode (tag, xhr) =
392+ let status = _xhrResponse_status xhr
393+ okStatus = status >= 200 && status < 400
405394 errMsg = fromMaybe
406395 ("Empty response with error code " <>
407396 T.pack (show $ _xhrResponse_status xhr))
@@ -410,56 +399,33 @@ evalResponse decodeRes (tag, xhr) =
410399 then either
411400 (\e -> ResponseFailure tag e xhr)
412401 (\v -> ResponseSuccess tag v xhr)
413− (decodeRes xhr)
402+ (decode xhr)
414403 else ResponseFailure tag errMsg xhr
415404 in respPayld
416405
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
417411
418−-- | Similar to 'Servant.API.ContentType.MimeUnrender' but with the differnce that
419−-- the second argument expects a JSString instead of ByteString.
420−-- This can lead to better performance ghcjs.
421−class Accept contentType => MimeUnrender contentType a where
422− mimeUnrender :: Proxy contentType -> JS.JSString -> Either String a
423−
424−instance FromJSON a => MimeUnrender JSON a where
425− mimeUnrender _ = note "Failed to decode response" . jsonDecode
426−
427−-- | @urlDecodeAsForm@
428−-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
429−-- holds if every element of x is non-null (i.e., not @("", "")@)
430−instance FromForm a => MimeUnrender FormUrlEncoded a where
431− mimeUnrender _ = first T.unpack . urlDecodeAsForm . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
432−
433−-- | @left show . TextL.decodeUtf8'@
434−instance MimeUnrender PlainText TL.Text where
435− mimeUnrender _ = pure . JS.lazyTextFromJSString
436−
437−-- | @left show . TextS.decodeUtf8' . toStrict@
438−instance MimeUnrender PlainText T.Text where
439− mimeUnrender _ = pure . JS.textFromJSString
440−
441−-- | @Right . BC.unpack@
442−instance MimeUnrender PlainText String where
443− mimeUnrender _ = Right . T.unpack . JS.textFromJSString
444−
445−-- | @Right . id@
446−instance MimeUnrender OctetStream ByteString where
447− mimeUnrender _ = pure . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString
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'
448417
449−-- | @Right . toStrict@
450−instance MimeUnrender OctetStream BS.ByteString where
451− mimeUnrender _ = pure . T.encodeUtf8 . JS.textFromJSString
452418
453419note :: e -> Maybe a -> Either e a
454−note e Nothing = Left e
455−note _ (Just a) = Right a
420+note e = maybe (Left e) Right
456421
457422fmapL :: (e -> e') -> Either e a -> Either e' a
458423fmapL _ (Right a) = Right a
459424fmapL f (Left e) = Left (f e)
460425
461−builderToText :: BB.Builder -> T.Text
462−builderToText = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString
426+builderToText :: Builder.Builder -> T.Text
427+builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
463428
464429escape :: T.Text -> T.Text
465−escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . toEncodedUrlPiece
430+escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
431+
src/Servant/Reflex.hs+161−157
@@ -1,17 +1,14 @@
11{-# LANGUAGE AllowAmbiguousTypes #-}
22{-# LANGUAGE CPP #-}
33{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE DefaultSignatures #-}
5−{-# LANGUAGE ExtendedDefaultRules #-}
64{-# LANGUAGE FlexibleContexts #-}
75{-# LANGUAGE FlexibleInstances #-}
8−{-# LANGUAGE FunctionalDependencies #-}
96{-# LANGUAGE GeneralizedNewtypeDeriving #-}
107{-# LANGUAGE InstanceSigs #-}
118{-# LANGUAGE MultiParamTypeClasses #-}
129{-# LANGUAGE OverloadedStrings #-}
1310{-# LANGUAGE PolyKinds #-}
14−{-# LANGUAGE RecordWildCards #-}
11+{-# LANGUAGE Rank2Types #-}
1512{-# LANGUAGE ScopedTypeVariables #-}
1613{-# LANGUAGE TupleSections #-}
1714{-# LANGUAGE TypeFamilies #-}
@@ -29,7 +26,9 @@
2926module Servant.Reflex
3027 ( client
3128 , clientWithOpts
29+ , clientWithOptsAndResultHandler
3230 , clientWithRoute
31+ , clientWithRouteAndResultHandler
3332 , BuildHeaderKeysTo(..)
3433 , toHeaders
3534 , HasClient
@@ -40,56 +39,56 @@ module Servant.Reflex
4039
4140------------------------------------------------------------------------------
4241import Control.Applicative
43−import qualified Data.ByteString as BS
44−import qualified Data.ByteString.Lazy as BL
45−import Data.CaseInsensitive (mk)
42+import qualified Data.CaseInsensitive as CI
4643import Data.Functor.Identity
47−import Data.Kind (Type)
48−import qualified Data.Map as Map
49−import Data.Monoid ((<>))
50−import Data.Proxy (Proxy (..))
51−import qualified Data.Set as Set
52−import Data.Text (Text)
53−import qualified Data.Text as T
54−import qualified Data.Text.Encoding as E
55−import qualified Data.Text.Lazy as TL
56−import GHC.Exts (Constraint)
57−import GHC.TypeLits (KnownSymbol, symbolVal)
58−import GHCJS.DOM.Types (Blob, Document, FormData)
59−import Servant.API ((:<|>) (..), (:>), Accept (..),
60− BasicAuth, BasicAuthData,
61− BuildHeadersTo (..), Capture,
62− FormUrlEncoded, Header, Headers (..),
63− HttpVersion, IsSecure, JSON,
64− MimeRender (..), NoContent,
65− OctetStream, PlainText, QueryFlag,
66− QueryParam, QueryParams, Raw,
67− ReflectMethod (..), RemoteHost,
68− ReqBody, ToHttpApiData (..), Vault,
69− Verb, contentType)
70−import qualified Servant.Auth as Auth
71−
72−import Reflex.Dom.Core (Dynamic, Event, IsXhrPayload, Reflex,
73− XhrRequest (..), XhrResponse (..),
74− XhrResponseHeaders (..),
75− attachPromptlyDynWith, constDyn, ffor,
76− fmapMaybe, leftmost,
77− performRequestsAsync)
44+import qualified Data.Map as Map
45+import Data.Monoid ((<>))
46+import Data.Proxy (Proxy (..))
47+import qualified Data.Set as Set
48+import Data.Text (Text)
49+import qualified Data.Text as T
50+import qualified Data.Text.Encoding as E
51+import GHC.Exts (Constraint)
52+import GHC.TypeLits (KnownSymbol, symbolVal)
53+import Servant.API ((:<|>) (..), (:>), BasicAuth,
54+ BasicAuthData, BuildHeadersTo (..),
55+ Capture, Header, Headers (..),
56+ HttpVersion, IsSecure,
57+ MimeRender (..), MimeUnrender,
58+ NoContent, QueryFlag, QueryParam,
59+ QueryParams, Raw, ReflectMethod (..),
60+ RemoteHost, ReqBody,
61+ ToHttpApiData (..), Vault, Verb,
62+ contentType)
63+import Servant.API.Description (Summary)
64+import qualified Servant.Auth as Auth
65+
66+import Reflex.Dom.Core (Dynamic, Event, Reflex,
67+ XhrRequest (..), XhrResponse (..),
68+ XhrResponseHeaders (..),
69+ attachPromptlyDynWith, constDyn, ffor,
70+ fmapMaybe, leftmost,
71+ performRequestsAsync)
7872------------------------------------------------------------------------------
79−import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
80− SupportsServantReflex, baseUrlWidget,
81− showBaseUrl)
82−import Servant.Common.Req (ClientOptions (..), MimeUnrender (..),
83− QParam (..), QueryPart (..), Req (..),
84− ReqResult (..), addHeader, authData,
85− defReq, defaultClientOptions,
86− evalResponse, performRequestsCT,
87− performRequestsNoBody,
88− performSomeRequestsAsync,
89− prependToPathParts, qParamToQueryPart,
90− qParams, reqBody, reqFailure,
91− reqMethod, reqSuccess, reqTag,
92− respHeaders, response, withCredentials)
73+import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
74+ showBaseUrl,
75+ SupportsServantReflex)
76+import Servant.Common.Req (ClientOptions(..),
77+ defaultClientOptions,
78+ Req, ReqResult(..), QParam(..),
79+ QueryPart(..), addHeader, authData,
80+ defReq, evalResponse, prependToPathParts,
81+ -- performRequestCT,
82+ performRequestsCT,
83+ -- performRequestNoBody,
84+ performRequestsNoBody,
85+ performSomeRequestsAsync,
86+ qParamToQueryPart, reqBody,
87+ reqSuccess, reqFailure,
88+ reqMethod, respHeaders,
89+ response,
90+ reqTag,
91+ qParams, withCredentials)
9392
9493
9594-- * Accessing APIs as a Client
@@ -104,7 +103,7 @@ import Servant.Common.Req (ClientOptions (..), MimeUnrender (..),
104103-- >
105104-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
106105-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
107−-- -> m (Event t (l, ReqResult Book)))
106+-- > -> m (Event t (l, ReqResult Book)))
108107-- > (getAllBooks :<|> postNewBook) = client myApi host
109108-- > where host = constDyn $ BaseUrl Http "localhost" 8080
110109client
@@ -126,21 +125,53 @@ clientWithOpts
126125 -> Client t m layout tag
127126clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
128127
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+
129142
130143-- | This class lets us define how each API combinator
131144-- influences the creation of an HTTP request. It's mostly
132145-- an internal class, you can just use 'client'.
133−class HasClient t m layout (tag :: Type) where
134− type Client t m layout tag :: Type
135− clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> Client t m layout tag
146+class Monad m => HasClient t m layout (tag :: *) where
147+ 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
136167
137168
138169instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
139170 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
140171
141− clientWithRoute Proxy q pTag req baseurl opts =
142− clientWithRoute (Proxy :: Proxy a) q pTag req baseurl opts :<|>
143− clientWithRoute (Proxy :: Proxy b) q pTag req baseurl opts
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
144175
145176
146177-- Capture. Example:
@@ -161,11 +192,9 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
161192 type Client t m (Capture capture a :> sublayout) tag =
162193 Dynamic t (Either Text a) -> Client t m sublayout tag
163194
164− clientWithRoute Proxy q t req baseurl opts val =
165− clientWithRoute (Proxy :: Proxy sublayout)
166− q t
167− (prependToPathParts p req)
168− baseurl opts
195+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
196+ clientWithRouteAndResultHandler
197+ (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
169198 where p = (fmap . fmap) (toUrlPiece) val
170199
171200
@@ -178,8 +207,8 @@ instance {-# OVERLAPPABLE #-}
178207 Event t tag -> m (Event t (ReqResult tag a))
179208 -- TODO how to access input types here?
180209 -- ExceptT ServantError IO a
181− clientWithRoute Proxy _ _ req baseurl opts trigs =
182− fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
210+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
211+ wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
183212 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
184213 req' = req { reqMethod = method }
185214
@@ -192,29 +221,33 @@ instance {-# OVERLAPPING #-}
192221 Event t tag -> m (Event t (ReqResult tag NoContent))
193222 -- TODO: how to access input types here?
194223 -- ExceptT ServantError IO NoContent
195− clientWithRoute Proxy _ _ req baseurl opts =
196− (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl opts
224+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
225+ wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
197226 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
198227
199228
200229toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
201230toHeaders r =
202− let toBS = E.encodeUtf8
203− hdrs = maybe []
204− (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
231+ let hdrs = maybe []
232+ (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
205233 (Map.toList $ _xhrResponse_headers xhr))
206234 (response r)
207235 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
208236
237+
209238class BuildHeaderKeysTo hs where
210− buildHeaderKeysTo :: Proxy hs -> [T.Text]
239+ buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
211240
212241instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
213242 where buildHeaderKeysTo _ = []
214243
215244instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
216245 => BuildHeaderKeysTo ((Header h v) ': xs) where
217− buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
246+ buildHeaderKeysTo _ =
247+ let
248+ thisKey = CI.mk $ T.pack (symbolVal (Proxy :: Proxy h))
249+ in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)
250+
218251
219252-- HEADERS Verb (Content) --
220253-- Headers combinator not treated in fully general case,
@@ -229,10 +262,10 @@ instance {-# OVERLAPPABLE #-}
229262 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
230263 type Client t m (Verb method status cts' (Headers ls a)) tag =
231264 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
232− clientWithRoute Proxy _ _ req baseurl opts trigs = do
265+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
233266 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
234267 resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
235− return $ toHeaders <$> resp
268+ wrap $ toHeaders <$> resp
236269 where req' = req { respHeaders =
237270 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
238271 }
@@ -245,10 +278,10 @@ instance {-# OVERLAPPABLE #-}
245278 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
246279 type Client t m (Verb method status cts (Headers ls NoContent)) tag
247280 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
248− clientWithRoute Proxy _ _ req baseurl opts trigs = do
281+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
249282 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
250283 resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
251− return $ toHeaders <$> resp
284+ wrap $ toHeaders <$> resp
252285 where req' = req {respHeaders =
253286 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
254287 }
@@ -275,11 +308,11 @@ instance (KnownSymbol sym, ToHttpApiData a,
275308 type Client t m (Header sym a :> sublayout) tag =
276309 Dynamic t (Either Text a) -> Client t m sublayout tag
277310
278− clientWithRoute Proxy q t req baseurl opts eVal =
279− clientWithRoute (Proxy :: Proxy sublayout)
280− q t
281− (Servant.Common.Req.addHeader hname eVal req)
282− baseurl opts
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
283316 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
284317
285318
@@ -293,8 +326,21 @@ instance HasClient t m sublayout tag
293326 type Client t m (HttpVersion :> sublayout) tag =
294327 Client t m sublayout tag
295328
296− clientWithRoute Proxy q t =
297− clientWithRoute (Proxy :: Proxy sublayout) q t
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+
298344
299345
300346-- | If you use a 'QueryParam' in one of your endpoints in your API,
@@ -330,9 +376,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
330376 Dynamic t (QParam a) -> Client t m sublayout tag
331377
332378 -- if mparam = Nothing, we don't add it to the query string
333− clientWithRoute Proxy q t req baseurl opts mparam =
334− clientWithRoute (Proxy :: Proxy sublayout) q t
335− (req {qParams = paramPair : qParams req}) baseurl opts
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
336382
337383 where pname = symbolVal (Proxy :: Proxy sym)
338384 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -376,8 +422,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
376422 type Client t m (QueryParams sym a :> sublayout) tag =
377423 Dynamic t [a] -> Client t m sublayout tag
378424
379− clientWithRoute Proxy q t req baseurl opts paramlist =
380− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
425+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
426+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
381427
382428 where req' = req { qParams = (T.pack pname, params') : qParams req }
383429 pname = symbolVal (Proxy :: Proxy sym)
@@ -416,8 +462,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
416462 type Client t m (QueryFlag sym :> sublayout) tag =
417463 Dynamic t Bool -> Client t m sublayout tag
418464
419− clientWithRoute Proxy q t req baseurl opts flag =
420− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
465+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
466+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
421467
422468 where req' = req { qParams = thisPair : qParams req }
423469 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -431,7 +477,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
431477 -> Event t tag
432478 -> m (Event t (ReqResult tag ()))
433479
434− clientWithRoute _ _ _ _ baseurl _ xhrs triggers = do
480+ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
435481
436482 let xhrs' = liftA2 (\x path -> case x of
437483 Left e -> Left e
@@ -442,7 +488,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
442488 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
443489
444490 resps <- performRequestsAsync okReq
445− return $ leftmost [ uncurry RequestFailure <$> badReq
491+ wrap $ leftmost [ uncurry RequestFailure <$> badReq
446492 , evalResponse (const $ Right ()) <$> resps
447493 ]
448494
@@ -467,73 +513,30 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
467513-- > where host = BaseUrl Http "localhost" 8080
468514-- > -- then you can just use "addBook" to query that endpoint
469515
470−instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),
471− HasClient t m sublayout tag, Reflex t)
472− => HasClient t m (ReqBody (ct ': cts) (a :: Type) :> sublayout) tag where
516+instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
517+ => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where
473518
474519 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
475− Dynamic t (Either Text (ToConvert ct a)) -> Client t m sublayout tag
520+ Dynamic t (Either Text a) -> Client t m sublayout tag
476521
477− clientWithRoute Proxy q t Req{..} baseurl opts body =
478− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
479− where req' = Req { reqBody = Just $ (fmap . fmap)
480− (\b -> (ghcjsMimeRender ctProxy atProxy b, ctString)) body
481− , ..}
522+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
523+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
524+ where req' = req { reqBody = bodyBytesCT }
482525 ctProxy = Proxy :: Proxy ct
483− atProxy = Proxy :: Proxy a
484526 ctString = T.pack $ show $ contentType ctProxy
527+ bodyBytesCT = Just $ (fmap . fmap)
528+ (\b -> (mimeRender ctProxy b, ctString))
529+ body
485530
486−class Accept ctype => GHCJS'MimeRender (ctype :: Type) (a :: Type) where
487− type ToConvert ctype a :: Type
488− type ToConvert ctype a = a
489−
490− type ToSend ctype a :: Type
491− type ToSend ctype a = BS.ByteString
492531
493− ghcjsMimeRender
494− :: IsXhrPayload (ToSend ctype a)
495− => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
496− default ghcjsMimeRender
497− :: (IsXhrPayload (ToSend ctype a), MimeRender ctype a,
498− MimeRender ctype (ToConvert ctype a), ToSend ctype a ~ BS.ByteString)
499− => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
500− ghcjsMimeRender ctype _ = BL.toStrict . mimeRender ctype
501−
502−instance MimeRender JSON x => GHCJS'MimeRender JSON x
503−
504−instance MimeRender FormUrlEncoded x => GHCJS'MimeRender FormUrlEncoded x
505−
506−instance GHCJS'MimeRender OctetStream BL.ByteString where
507− type ToConvert OctetStream BL.ByteString = Blob
508− type ToSend OctetStream BL.ByteString = Blob
509− ghcjsMimeRender _ _ = id
510−
511−instance GHCJS'MimeRender PlainText String where
512− type ToSend PlainText String = Text
513− ghcjsMimeRender _ _ = T.pack
514−
515−instance GHCJS'MimeRender PlainText Text where
516− type ToSend PlainText Text = Text
517− ghcjsMimeRender _ _ = id
518−
519−instance GHCJS'MimeRender PlainText TL.Text where
520− type ToSend PlainText TL.Text = Text
521− ghcjsMimeRender _ _ = TL.toStrict
522−
523−instance GHCJS'MimeRender PlainText BL.ByteString where
524− type ToSend PlainText BL.ByteString = BS.ByteString
525− ghcjsMimeRender _ _ = BL.toStrict
526−
527−instance GHCJS'MimeRender PlainText BS.ByteString where
528− ghcjsMimeRender _ _ = id
529532
530533-- | Make the querying function append @path@ to the request path.
531534instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
532535 type Client t m (path :> sublayout) tag = Client t m sublayout tag
533536
534− clientWithRoute Proxy q t req baseurl opts =
535− clientWithRoute (Proxy :: Proxy sublayout) q t
536− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts
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
537540
538541 where p = symbolVal (Proxy :: Proxy path)
539542
@@ -541,23 +544,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient
541544instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
542545 type Client t m (Vault :> api) tag = Client t m api tag
543546
544− clientWithRoute Proxy q t req baseurl =
545− clientWithRoute (Proxy :: Proxy api) q t req baseurl
547+ clientWithRouteAndResultHandler Proxy =
548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
546549
547550
548551instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
549552 type Client t m (RemoteHost :> api) tag = Client t m api tag
550553
551− clientWithRoute Proxy q t req baseurl =
552− clientWithRoute (Proxy :: Proxy api) q t req baseurl
554+ clientWithRouteAndResultHandler Proxy =
555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
553556
554557
555558
556559instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
557560 type Client t m (IsSecure :> api) tag = Client t m api tag
558561
559− clientWithRoute Proxy q t req baseurl =
560− clientWithRoute (Proxy :: Proxy api) q t req baseurl
562+ clientWithRouteAndResultHandler Proxy =
563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
561564
562565
563566instance (HasClient t m api tag, Reflex t)
@@ -566,8 +569,8 @@ instance (HasClient t m api tag, Reflex t)
566569 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
567570 -> Client t m api tag
568571
569− clientWithRoute Proxy q t req baseurl opts authdata =
570− clientWithRoute (Proxy :: Proxy api) q t req' baseurl opts
572+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
573+ clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
571574 where
572575 req' = req { authData = Just authdata }
573576
@@ -610,7 +613,7 @@ for empty and one for non-empty lists).
610613instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where
611614
612615 type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag
613− clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)
616+ clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)
614617
615618
616619type family HasCookieAuth xs :: Constraint where
@@ -619,3 +622,4 @@ type family HasCookieAuth xs :: Constraint where
619622 HasCookieAuth '[] = CookieAuthNotEnabled
620623
621624class CookieAuthNotEnabled
625+
src/Servant/Reflex/Multi.hs+36−23
@@ -37,32 +37,34 @@ 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, 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)
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)
6264------------------------------------------------------------------------------
6365import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
6466 SupportsServantReflex)
65−import Servant.Common.Req (ClientOptions, MimeUnrender,
67+import Servant.Common.Req (ClientOptions,
6668 QParam (..), QueryPart (..), Req,
6769 ReqResult (..), addHeader, authData,
6870 defReq,
@@ -240,6 +242,17 @@ instance HasClientMulti t m sublayout f tag
240242 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
241243
242244
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+
243256------------------------------------------------------------------------------
244257instance (KnownSymbol sym,
245258 ToHttpApiData a,
testdriver/test/Servant/ReflexSpec.hs+2−1
@@ -9,6 +9,7 @@ import qualified Data.Text as T
99import Data.Foldable
1010import Test.WebDriver.Commands.Wait
1111import Test.Hspec.WebDriver
12+import Test.Hspec.WebDriver (chromeCaps)
1213
1314
1415clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()
@@ -28,7 +29,7 @@ spec :: Spec
2829spec = do
2930 describe "servant-reflex tests" $ do
3031
31− session "test page" $ using Chrome $ do
32+ session "test page" $ using [chromeCaps] $ do
3233
3334 it "opens the page" $ runWD $
3435 openPage "http://localhost:8000"
testserver/API.hsmode 120000 → 100644+69−1
@@ -1 +0,0 @@
1−../exec/API.hs
@@ -0,0 +1,69 @@
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
testserver/Main.hs+10−3
@@ -7,10 +7,12 @@
77{-# LANGUAGE TypeOperators #-}
88
99import Control.Monad.IO.Class (liftIO)
10+import Control.Monad.Reader (reader)
1011import Data.Aeson
1112import Data.Bool
1213import Data.Char (toUpper)
1314import qualified Data.List as L
15+import Data.Maybe (fromMaybe)
1416import Data.Monoid
1517import Data.Proxy
1618import Data.Text hiding (head, length, map,
@@ -25,6 +27,7 @@ import Snap.Http.Server
2527import Servant
2628import Servant.Server
2729-- import Snap.Util.FileServe
30+import System.Environment (lookupEnv)
2831import API
2932import Snap
3033
@@ -40,7 +43,7 @@ instance ToJSON Greet
4043testApi :: Proxy API
4144testApi = Proxy
4245
43−data App = App
46+data App = App { appStaticDir :: String }
4447
4548-- Server-side handlers.
4649--
@@ -51,7 +54,7 @@ data App = App
5154server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
5255server = return () :<|> return 100 :<|> sayhi :<|> dbl
5356 :<|> multi :<|> qna :<|> serveSecret
54− :<|> serveDirectory "static"
57+ :<|> statics
5558 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
5659 sayhi nm greetings withGusto = case nm of
5760 Nothing -> return ("Sorry, who are you?" :: Text)
@@ -76,6 +79,9 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl
7679 req <- getRequest
7780 liftIO $ putStrLn (show req)
7881 return 101
82+ statics = do
83+ staticDir <- reader appStaticDir
84+ serveDirectory staticDir
7985
8086-- Turn the server into a WAI app. 'serve' is provided by servant,
8187-- more precisely by the Servant.Server module.
@@ -85,10 +91,11 @@ test = serveSnapWithContext testApi
8591
8692initApp :: SnapletInit App App
8793initApp = makeSnaplet "myapp" "example" Nothing $ do
94+ staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")
8895 addRoutes [("", test)
8996 ,("", serveDirectory "static")
9097 ]
91− return App
98+ return (App staticDir)
9299
93100-- Put this all to work!
94101main :: IO ()
testserver/run-wd-tests.shdeleted−5
@@ -1,5 +0,0 @@
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+5−4
@@ -19,12 +19,13 @@ executable back
1919 main-is: Main.hs
2020 -- other-modules:
2121 -- other-extensions:
22− build-depends: aeson >= 0.9 && < 1.4
23− , base >=4.8 && <4.11
22+ build-depends: aeson >= 0.9 && < 1.5
23+ , base >=4.8 && < 5
24+ , mtl
2425 , snap >= 1.0 && < 1.2
25− , snap-server >= 1.0 && < 1.1
26+ , snap-server >= 1.0 && < 1.2
2627 , snap-core >= 1.0 && < 1.1
27− , servant >= 0.8 && < 0.12
28+ , servant >= 0.16 && < 0.18
2829 , servant-snap >= 0.8 && < 0.9
2930 , text >= 1.0 && < 1.3
3031 -- hs-source-dirs:
testserver/tr.nixdeleted−32
@@ -1,32 +0,0 @@
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.nixnew file+70
@@ -0,0 +1,70 @@
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+ }