on master help sign in
32 files changed+659−532
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−159 src/Servant/Reflex/Multi.hs+45−35 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,65 +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−-- #ifndef __GHCJS__
58−-- jsonDecode :: JS.JSString -> Maybe a
59−-- jsonDecode = error "jsonDecode is only available in GHCJS"
60−-- #endif
6142
62−-----------------------------------------------------------------------------
43+------------------------------------------------------------------------------
6344-- | The result of a request event
6445data ReqResult tag a
6546 = ResponseSuccess tag a XhrResponse
@@ -112,6 +93,13 @@ reqFailure (ResponseFailure _ s _) = Just s
11293reqFailure (RequestFailure _ s) = Just s
11394reqFailure _ = Nothing
11495
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+
115103
116104------------------------------------------------------------------------------
117105-- | Simple filter/accessor for the raw XHR response
@@ -153,35 +141,34 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
153141-------------------------------------------------------------------------------
154142-- The data structure used to build up request information while traversing
155143-- the shape of a servant API
156−data Req t = forall o. (IsXhrPayload o, Show o) => Req
144+data Req t = Req
157145 { reqMethod :: Text
158146 , reqPathParts :: [Dynamic t (Either Text Text)]
159147 , qParams :: [(Text, QueryPart t)]
160− , reqBody :: Maybe (Dynamic t (Either Text (o, Text)))
148+ , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))
161149 , headers :: [(Text, Dynamic t (Either Text Text))]
162150 , respHeaders :: XhrResponseHeaders
163151 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))
164152 }
165153
166−data SomeXhrRequest = forall o. (IsXhrPayload o, Show o) => SomeXhrRequest (XhrRequest (Maybe o))
167−
168154defReq :: Req t
169−defReq = Req "GET" [] [] (Nothing :: Maybe (Dynamic t (Either Text ((), Text)))) [] def Nothing
155+defReq = Req "GET" [] [] Nothing [] def Nothing
170156
171157prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t
172158prependToPathParts p req =
173159 req { reqPathParts = p : reqPathParts req }
174160
175161addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
176−addHeader name val req = req { headers = (name, (fmap . fmap) (T.decodeUtf8 . toHeader) val) : headers req }
162+addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
163+
177164
178165reqToReflexRequest
179− :: forall t. Reflex t
180− => Text
181− -> Dynamic t BaseUrl
182− -> Req t
183− -> Dynamic t (Either Text SomeXhrRequest)
184−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 =
185172 let t :: Dynamic t [Either Text Text]
186173 t = sequence $ reverse $ reqPathParts req
187174
@@ -233,33 +220,33 @@ reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (
233220 fmap (fmap (\rightVal -> (headerName, rightVal))) dynam
234221
235222 mkConfigBody :: Either Text [(Text,Text)]
236− -> (Either Text (o, Text))
237− -> Either Text (XhrRequestConfig (Maybe o))
223+ -> (Either Text (BL.ByteString, Text))
224+ -> Either Text (XhrRequestConfig XhrPayload)
238225 mkConfigBody ehs rb = case (ehs, rb) of
239226 (_, Left e) -> Left e
240227 (Left e, _) -> Left e
241228 (Right hs, Right (bBytes, bCT)) ->
242229 Right $ XhrRequestConfig
243− { _xhrRequestConfig_sendData = Just bBytes
230+ { _xhrRequestConfig_sendData = bytesToPayload bBytes
244231 , _xhrRequestConfig_headers =
245232 Map.insert "Content-Type" bCT (Map.fromList hs)
246233 , _xhrRequestConfig_user = Nothing
247234 , _xhrRequestConfig_password = Nothing
248− , _xhrRequestConfig_responseType = Nothing
235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
249236 , _xhrRequestConfig_withCredentials = False
250237 , _xhrRequestConfig_responseHeaders = def
251238 }
252239
253− xhrOpts :: Dynamic t (Either Text (XhrRequestConfig (Maybe o)))
254− xhrOpts = case reqBody of
240+ xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))
241+ xhrOpts = case reqBody req of
255242 Nothing -> ffor xhrHeaders $ \case
256243 Left e -> Left e
257244 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
258245 , _xhrRequestConfig_user = Nothing
259246 , _xhrRequestConfig_password = Nothing
260− , _xhrRequestConfig_responseType = Nothing
247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
248+ , _xhrRequestConfig_sendData = mempty
261249 , _xhrRequestConfig_withCredentials = False
262− , _xhrRequestConfig_sendData = Nothing
263250 }
264251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
265252
@@ -267,16 +254,16 @@ reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (
267254 mkAuth _ (Left e) = Left e
268255 mkAuth Nothing r = r
269256 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config
270− { _xhrRequestConfig_user = Just $ T.decodeUtf8 u
271− , _xhrRequestConfig_password = Just $ T.decodeUtf8 p}
257+ { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
258+ , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
272259
273260 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
274261 -> Dynamic t (Either Text (XhrRequestConfig x))
275262 addAuth xhr = case authData req of
276− Nothing -> xhr
263+ Nothing -> xhr
277264 Just auth -> liftA2 mkAuth auth xhr
278265
279− 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)
280267
281268 in xhrReq
282269
@@ -285,14 +272,8 @@ reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (
285272displayHttpRequest :: Text -> Text
286273displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
287274
288−instance IsXhrPayload o => IsXhrPayload (Maybe o) where
289− sendXhrPayload xhr = maybe (sendXhrPayload xhr ()) (sendXhrPayload xhr)
290−
291−instance (IsXhrPayload o, IsXhrPayload o') => IsXhrPayload (Either o o') where
292− sendXhrPayload xhr = either (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−159
@@ -1,18 +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 #-}
11−{-# LANGUAGE LambdaCase #-}
128{-# LANGUAGE MultiParamTypeClasses #-}
139{-# LANGUAGE OverloadedStrings #-}
1410{-# LANGUAGE PolyKinds #-}
15−{-# LANGUAGE RecordWildCards #-}
11+{-# LANGUAGE Rank2Types #-}
1612{-# LANGUAGE ScopedTypeVariables #-}
1713{-# LANGUAGE TupleSections #-}
1814{-# LANGUAGE TypeFamilies #-}
@@ -30,9 +26,10 @@
3026module Servant.Reflex
3127 ( client
3228 , clientWithOpts
29+ , clientWithOptsAndResultHandler
3330 , clientWithRoute
31+ , clientWithRouteAndResultHandler
3432 , BuildHeaderKeysTo(..)
35− , GHCJS'MimeRender(..)
3633 , toHeaders
3734 , HasClient
3835 , Client
@@ -42,56 +39,56 @@ module Servant.Reflex
4239
4340------------------------------------------------------------------------------
4441import Control.Applicative
45−import qualified Data.ByteString as BS
46−import qualified Data.ByteString.Lazy as BL
47−import Data.CaseInsensitive (mk)
42+import qualified Data.CaseInsensitive as CI
4843import Data.Functor.Identity
49−import Data.Kind (Type)
50−import qualified Data.Map as Map
51−import Data.Monoid ((<>))
52−import Data.Proxy (Proxy (..))
53−import qualified Data.Set as Set
54−import Data.Text (Text)
55−import qualified Data.Text as T
56−import qualified Data.Text.Encoding as E
57−import qualified Data.Text.Lazy as TL
58−import GHC.Exts (Constraint)
59−import GHC.TypeLits (KnownSymbol, symbolVal)
60−import GHCJS.DOM.Types (Blob)
61−import Servant.API ((:<|>) (..), (:>), Accept (..),
62− BasicAuth, BasicAuthData,
63− BuildHeadersTo (..), Capture,
64− FormUrlEncoded, Header, Headers (..),
65− HttpVersion, IsSecure, JSON,
66− MimeRender (..), NoContent,
67− OctetStream, PlainText, QueryFlag,
68− QueryParam, QueryParams, Raw,
69− ReflectMethod (..), RemoteHost,
70− ReqBody, ToHttpApiData (..), Vault,
71− Verb, contentType)
72−import qualified Servant.Auth as Auth
73−
74−import Reflex.Dom.Core (Dynamic, Event, IsXhrPayload, Reflex,
75− XhrRequest (..), XhrResponse (..),
76− XhrResponseHeaders (..),
77− attachPromptlyDynWith, constDyn, ffor,
78− fmapMaybe, leftmost,
79− 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)
8072------------------------------------------------------------------------------
81−import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
82− SupportsServantReflex, baseUrlWidget,
83− showBaseUrl)
84−import Servant.Common.Req (ClientOptions (..), MimeUnrender (..),
85− QParam (..), QueryPart (..), Req (..),
86− ReqResult (..), addHeader, authData,
87− defReq, defaultClientOptions,
88− evalResponse, performRequestsCT,
89− performRequestsNoBody,
90− performSomeRequestsAsync,
91− prependToPathParts, qParamToQueryPart,
92− qParams, reqBody, reqFailure,
93− reqMethod, reqSuccess, reqTag,
94− 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)
9592
9693
9794-- * Accessing APIs as a Client
@@ -106,7 +103,7 @@ import Servant.Common.Req (ClientOptions (..), MimeUnrender (..),
106103-- >
107104-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
108105-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
109−-- -> m (Event t (l, ReqResult Book)))
106+-- > -> m (Event t (l, ReqResult Book)))
110107-- > (getAllBooks :<|> postNewBook) = client myApi host
111108-- > where host = constDyn $ BaseUrl Http "localhost" 8080
112109client
@@ -128,21 +125,53 @@ clientWithOpts
128125 -> Client t m layout tag
129126clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
130127
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+
131142
132143-- | This class lets us define how each API combinator
133144-- influences the creation of an HTTP request. It's mostly
134145-- an internal class, you can just use 'client'.
135−class HasClient t m layout (tag :: Type) where
136− type Client t m layout tag :: Type
137− 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
138167
139168
140169instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
141170 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
142171
143− clientWithRoute Proxy q pTag req baseurl opts =
144− clientWithRoute (Proxy :: Proxy a) q pTag req baseurl opts :<|>
145− 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
146175
147176
148177-- Capture. Example:
@@ -163,11 +192,9 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
163192 type Client t m (Capture capture a :> sublayout) tag =
164193 Dynamic t (Either Text a) -> Client t m sublayout tag
165194
166− clientWithRoute Proxy q t req baseurl opts val =
167− clientWithRoute (Proxy :: Proxy sublayout)
168− q t
169− (prependToPathParts p req)
170− 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
171198 where p = (fmap . fmap) (toUrlPiece) val
172199
173200
@@ -180,8 +207,8 @@ instance {-# OVERLAPPABLE #-}
180207 Event t tag -> m (Event t (ReqResult tag a))
181208 -- TODO how to access input types here?
182209 -- ExceptT ServantError IO a
183− clientWithRoute Proxy _ _ req baseurl opts trigs =
184− 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
185212 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
186213 req' = req { reqMethod = method }
187214
@@ -194,29 +221,33 @@ instance {-# OVERLAPPING #-}
194221 Event t tag -> m (Event t (ReqResult tag NoContent))
195222 -- TODO: how to access input types here?
196223 -- ExceptT ServantError IO NoContent
197− clientWithRoute Proxy _ _ req baseurl opts =
198− (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
199226 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
200227
201228
202229toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
203230toHeaders r =
204− let toBS = E.encodeUtf8
205− hdrs = maybe []
206− (\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))
207233 (Map.toList $ _xhrResponse_headers xhr))
208234 (response r)
209235 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
210236
237+
211238class BuildHeaderKeysTo hs where
212− buildHeaderKeysTo :: Proxy hs -> [T.Text]
239+ buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
213240
214241instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
215242 where buildHeaderKeysTo _ = []
216243
217244instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
218245 => BuildHeaderKeysTo ((Header h v) ': xs) where
219− 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+
220251
221252-- HEADERS Verb (Content) --
222253-- Headers combinator not treated in fully general case,
@@ -231,10 +262,10 @@ instance {-# OVERLAPPABLE #-}
231262 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
232263 type Client t m (Verb method status cts' (Headers ls a)) tag =
233264 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
234− clientWithRoute Proxy _ _ req baseurl opts trigs = do
265+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
235266 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
236267 resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
237− return $ toHeaders <$> resp
268+ wrap $ toHeaders <$> resp
238269 where req' = req { respHeaders =
239270 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
240271 }
@@ -247,10 +278,10 @@ instance {-# OVERLAPPABLE #-}
247278 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
248279 type Client t m (Verb method status cts (Headers ls NoContent)) tag
249280 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
250− clientWithRoute Proxy _ _ req baseurl opts trigs = do
281+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
251282 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
252283 resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
253− return $ toHeaders <$> resp
284+ wrap $ toHeaders <$> resp
254285 where req' = req {respHeaders =
255286 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
256287 }
@@ -277,11 +308,11 @@ instance (KnownSymbol sym, ToHttpApiData a,
277308 type Client t m (Header sym a :> sublayout) tag =
278309 Dynamic t (Either Text a) -> Client t m sublayout tag
279310
280− clientWithRoute Proxy q t req baseurl opts eVal =
281− clientWithRoute (Proxy :: Proxy sublayout)
282− q t
283− (Servant.Common.Req.addHeader hname eVal req)
284− 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
285316 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
286317
287318
@@ -295,8 +326,21 @@ instance HasClient t m sublayout tag
295326 type Client t m (HttpVersion :> sublayout) tag =
296327 Client t m sublayout tag
297328
298− clientWithRoute Proxy q t =
299− 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+
300344
301345
302346-- | If you use a 'QueryParam' in one of your endpoints in your API,
@@ -332,9 +376,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
332376 Dynamic t (QParam a) -> Client t m sublayout tag
333377
334378 -- if mparam = Nothing, we don't add it to the query string
335− clientWithRoute Proxy q t req baseurl opts mparam =
336− clientWithRoute (Proxy :: Proxy sublayout) q t
337− (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
338382
339383 where pname = symbolVal (Proxy :: Proxy sym)
340384 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -378,8 +422,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
378422 type Client t m (QueryParams sym a :> sublayout) tag =
379423 Dynamic t [a] -> Client t m sublayout tag
380424
381− clientWithRoute Proxy q t req baseurl opts paramlist =
382− 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
383427
384428 where req' = req { qParams = (T.pack pname, params') : qParams req }
385429 pname = symbolVal (Proxy :: Proxy sym)
@@ -418,8 +462,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
418462 type Client t m (QueryFlag sym :> sublayout) tag =
419463 Dynamic t Bool -> Client t m sublayout tag
420464
421− clientWithRoute Proxy q t req baseurl opts flag =
422− 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
423467
424468 where req' = req { qParams = thisPair : qParams req }
425469 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -433,7 +477,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
433477 -> Event t tag
434478 -> m (Event t (ReqResult tag ()))
435479
436− clientWithRoute _ _ _ _ baseurl _ xhrs triggers = do
480+ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
437481
438482 let xhrs' = liftA2 (\x path -> case x of
439483 Left e -> Left e
@@ -444,7 +488,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
444488 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
445489
446490 resps <- performRequestsAsync okReq
447− return $ leftmost [ uncurry RequestFailure <$> badReq
491+ wrap $ leftmost [ uncurry RequestFailure <$> badReq
448492 , evalResponse (const $ Right ()) <$> resps
449493 ]
450494
@@ -469,73 +513,30 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
469513-- > where host = BaseUrl Http "localhost" 8080
470514-- > -- then you can just use "addBook" to query that endpoint
471515
472−instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),
473− HasClient t m sublayout tag, Reflex t)
474− => 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
475518
476519 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
477− Dynamic t (Either Text (ToConvert ct a)) -> Client t m sublayout tag
520+ Dynamic t (Either Text a) -> Client t m sublayout tag
478521
479− clientWithRoute Proxy q t Req{..} baseurl opts body =
480− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts
481− where req' = Req { reqBody = Just $ (fmap . fmap)
482− (\b -> (ghcjsMimeRender ctProxy atProxy b, ctString)) body
483− , ..}
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 }
484525 ctProxy = Proxy :: Proxy ct
485− atProxy = Proxy :: Proxy a
486526 ctString = T.pack $ show $ contentType ctProxy
527+ bodyBytesCT = Just $ (fmap . fmap)
528+ (\b -> (mimeRender ctProxy b, ctString))
529+ body
487530
488−class Accept ctype => GHCJS'MimeRender (ctype :: Type) (a :: Type) where
489− type ToConvert ctype a :: Type
490− type ToConvert ctype a = a
491−
492− type ToSend ctype a :: Type
493− type ToSend ctype a = BS.ByteString
494531
495− ghcjsMimeRender
496− :: IsXhrPayload (ToSend ctype a)
497− => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
498− default ghcjsMimeRender
499− :: (MimeRender ctype a,
500− MimeRender ctype (ToConvert ctype a), ToSend ctype a ~ BS.ByteString)
501− => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a
502− ghcjsMimeRender ctype _ = BL.toStrict . mimeRender ctype
503−
504−instance MimeRender JSON x => GHCJS'MimeRender JSON x
505−
506−instance MimeRender FormUrlEncoded x => GHCJS'MimeRender FormUrlEncoded x
507−
508−instance GHCJS'MimeRender OctetStream BL.ByteString where
509− type ToConvert OctetStream BL.ByteString = Either BL.ByteString Blob
510− type ToSend OctetStream BL.ByteString = Either BS.ByteString Blob
511− ghcjsMimeRender _ _ = \case Left bl -> Left $ BL.toStrict bl; Right x -> Right x
512−
513−instance GHCJS'MimeRender PlainText String where
514− type ToSend PlainText String = Text
515− ghcjsMimeRender _ _ = T.pack
516−
517−instance GHCJS'MimeRender PlainText Text where
518− type ToSend PlainText Text = Text
519− ghcjsMimeRender _ _ = id
520−
521−instance GHCJS'MimeRender PlainText TL.Text where
522− type ToSend PlainText TL.Text = Text
523− ghcjsMimeRender _ _ = TL.toStrict
524−
525−instance GHCJS'MimeRender PlainText BL.ByteString where
526− type ToSend PlainText BL.ByteString = BS.ByteString
527− ghcjsMimeRender _ _ = BL.toStrict
528−
529−instance GHCJS'MimeRender PlainText BS.ByteString where
530− ghcjsMimeRender _ _ = id
531532
532533-- | Make the querying function append @path@ to the request path.
533534instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
534535 type Client t m (path :> sublayout) tag = Client t m sublayout tag
535536
536− clientWithRoute Proxy q t req baseurl opts =
537− clientWithRoute (Proxy :: Proxy sublayout) q t
538− (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
539540
540541 where p = symbolVal (Proxy :: Proxy path)
541542
@@ -543,23 +544,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient
543544instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
544545 type Client t m (Vault :> api) tag = Client t m api tag
545546
546− clientWithRoute Proxy q t req baseurl =
547− clientWithRoute (Proxy :: Proxy api) q t req baseurl
547+ clientWithRouteAndResultHandler Proxy =
548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
548549
549550
550551instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
551552 type Client t m (RemoteHost :> api) tag = Client t m api tag
552553
553− clientWithRoute Proxy q t req baseurl =
554− clientWithRoute (Proxy :: Proxy api) q t req baseurl
554+ clientWithRouteAndResultHandler Proxy =
555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
555556
556557
557558
558559instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
559560 type Client t m (IsSecure :> api) tag = Client t m api tag
560561
561− clientWithRoute Proxy q t req baseurl =
562− clientWithRoute (Proxy :: Proxy api) q t req baseurl
562+ clientWithRouteAndResultHandler Proxy =
563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
563564
564565
565566instance (HasClient t m api tag, Reflex t)
@@ -568,8 +569,8 @@ instance (HasClient t m api tag, Reflex t)
568569 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
569570 -> Client t m api tag
570571
571− clientWithRoute Proxy q t req baseurl opts authdata =
572− 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
573574 where
574575 req' = req { authData = Just authdata }
575576
@@ -612,7 +613,7 @@ for empty and one for non-empty lists).
612613instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where
613614
614615 type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag
615− clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)
616+ clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)
616617
617618
618619type family HasCookieAuth xs :: Constraint where
@@ -621,3 +622,4 @@ type family HasCookieAuth xs :: Constraint where
621622 HasCookieAuth '[] = CookieAuthNotEnabled
622623
623624class CookieAuthNotEnabled
625+
src/Servant/Reflex/Multi.hs+45−35
@@ -7,7 +7,6 @@
77{-# LANGUAGE MultiParamTypeClasses #-}
88{-# LANGUAGE OverloadedStrings #-}
99{-# LANGUAGE PolyKinds #-}
10−{-# LANGUAGE RecordWildCards #-}
1110{-# LANGUAGE ScopedTypeVariables #-}
1211{-# LANGUAGE TupleSections #-}
1312{-# LANGUAGE TypeFamilies #-}
@@ -38,34 +37,37 @@ module Servant.Reflex.Multi (
3837 ) where
3938
4039------------------------------------------------------------------------------
41−import Control.Applicative (liftA2)
42−import Data.Functor.Compose (Compose (..), getCompose)
43−import Data.Proxy (Proxy (..))
44−import qualified Data.Set as Set
45−import Data.Text (Text)
46−import qualified Data.Text as T
47−import qualified Data.Text.Encoding as E
48−import GHC.TypeLits (KnownSymbol, symbolVal)
49−import Servant.API ((:<|>) (..), (:>), BasicAuth,
50− BasicAuthData, BuildHeadersTo (..),
51− Capture, Header, Headers (..),
52− HttpVersion, IsSecure, NoContent,
53− QueryFlag, QueryParam, QueryParams,
54− Raw, ReflectMethod (..), RemoteHost,
55− ReqBody, ToHttpApiData (..), Vault,
56− Verb, contentType)
57−
58−import Reflex.Dom.Core (Dynamic, Event, IsXhrPayload, 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,
66− QParam (..), QueryPart (..), Req (..),
67− ReqResult (..), SomeXhrRequest (..),
68− addHeader, authData, defReq,
67+import Servant.Common.Req (ClientOptions,
68+ QParam (..), QueryPart (..), Req,
69+ ReqResult (..), addHeader, authData,
70+ defReq,
6971 defaultClientOptions,
7072 performRequestsCT,
7173 performRequestsNoBody,
@@ -74,8 +76,7 @@ import Servant.Common.Req (ClientOptions, MimeUnrender,
7476 qParams, reqBody, reqFailure,
7577 reqMethod, reqSuccess, reqSuccess',
7678 respHeaders, response, withCredentials)
77−import Servant.Reflex (BuildHeaderKeysTo (..),
78− GHCJS'MimeRender (..), toHeaders)
79+import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
7980
8081
8182------------------------------------------------------------------------------
@@ -241,6 +242,17 @@ instance HasClientMulti t m sublayout f tag
241242 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
242243
243244
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+
244256------------------------------------------------------------------------------
245257instance (KnownSymbol sym,
246258 ToHttpApiData a,
@@ -314,31 +326,29 @@ instance (SupportsServantReflex t m,
314326 clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do
315327 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
316328 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
317− rawReqs''' = (fmap . fmap . fmap) (SomeXhrRequest . fmap Just) rawReqs''
318− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs'''
329+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''
319330 return resps
320331 where
321332 aux (tag, Right r) = ResponseSuccess tag () r
322333 aux (tag, Left e) = RequestFailure tag e
323334
324335
325−instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),
336+instance (MimeRender ct a,
326337 HasClientMulti t m sublayout f tag,
327338 Reflex t,
328339 Applicative f)
329340 => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where
330341
331342 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
332− Dynamic t (f (Either Text (ToConvert ct a))) -> ClientMulti t m sublayout f tag
343+ Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
333344
334345 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
335346 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
336− where req' b Req{..} = Req { reqBody = bodyBytesCT (constDyn b), .. }
347+ where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
337348 ctProxy = Proxy :: Proxy ct
338− atProxy = Proxy :: Proxy a
339349 ctString = T.pack $ show $ contentType ctProxy
340350 bodyBytesCT b = Just $ (fmap . fmap)
341− (\b' -> (ghcjsMimeRender ctProxy atProxy b', ctString))
351+ (\b' -> (mimeRender ctProxy b', ctString))
342352 b
343353 reqs' = liftA2 req' <$> bodies <*> reqs
344354
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+ }