git.iko.soy/typeable/servant-reflex
on master help sign in
33 files changed+755−442
since splitsnapshots
unifiedsplit
.gitignore+2 .gitmodules−12 .travis.yml+12−56 changelog.md → ChangeLog.md+28 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/API.hs+1 exec/Example.hs+27−6 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+26−19 shell.nix+1 src/Servant/Common/BaseUrl.hs+10−7 src/Servant/Common/Req.hs+106−92 src/Servant/Reflex.hs+157−86 src/Servant/Reflex/Multi.hs+82−53 testdriver/test/Servant/ReflexSpec.hs+2−1 testserver/API.hs+69−1 testserver/Main.hs+20−5 testserver/run-wd-tests.sh−5 testserver/testserver.cabal+8−7 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+28
@@ -1,3 +1,31 @@
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+
14+0.3.3
15+-----
16+
17+- Fix encoding issue: Explicitly escape reserved characters from path pieces and query parameters
18+
19+
20+0.3.2
21+-----
22+
23+- **Addition of 'Servant.Reflex.Common.Req.ClientOpts'** which
24+allows the users to apply a final adjustment to Requests before
25+thery are sent, such as setting the 'withCredentials' flag
26+or print the Request to the console for debugging
27+[PR #47](https://github.com/imalsogreg/servant-reflex/pull/47)
28+
1290.3
230---
331
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 && 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/API.hs+1
@@ -40,6 +40,7 @@ type API = "getunit" :> Get '[JSON] ()
4040 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
4141 :<|> "qna" :> ReqBody '[JSON] Question
4242 :> Post '[JSON] Answer
43+ :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
4344 :<|> Raw
4445
4546type GET = Get '[JSON] ()
exec/Example.hs+27−6
@@ -1,3 +1,4 @@
1+{-# LANGUAGE DataKinds #-}
12{-# LANGUAGE FlexibleContexts #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE OverloadedStrings #-}
@@ -14,12 +15,14 @@ import Control.Monad.Fix (MonadFix)
1415import Data.Monoid (First(..), (<>))
1516import Data.Text (Text)
1617import qualified Data.Text as T
18+import qualified Data.Text.Encoding as T
1719import GHC.TypeLits
1820import Servant.API
1921import API
2022import Data.Proxy
2123import Text.Read (readMaybe)
22−import Reflex.Dom hiding (run)
24+import Reflex.Dom.Core hiding (run, mainWidget)
25+import Reflex.Dom (mainWidget)
2326------------------------------------------------------------------------------
2427import Servant.Reflex
2528import Servant.Reflex.Multi
@@ -43,7 +46,7 @@ runMulti :: forall t m. (SupportsServantReflex t m,
4346runMulti = do
4447 url <- baseUrlWidget
4548 el "br" blank
46− let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ ) =
49+ let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =
4750 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
4851
4952 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
@@ -66,9 +69,12 @@ runMulti = do
6669 textInput def
6770 gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
6871 b <- button "Go"
69− r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts) (constDyn [True, False]) (1 <$ b)
72+ r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)
73+ (constDyn [True, False]) (1 <$ b)
74+
75+ dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .
76+ fmap reqSuccess <$> r')
7077
71− dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes . fmap reqSuccess <$> r')
7278
7379 return ()
7480
@@ -91,8 +97,11 @@ run = mdo
9197 el "br" (return ())
9298
9399 -- Name the computed API client functions
94− let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> doRaw) =
95− client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url
100+ let tweakRequest = ClientOptions $ \r -> do
101+ return $ r & withCredentials .~ True
102+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl
103+ :<|> multi :<|> qna :<|> secret :<|> doRaw) =
104+ clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest
96105
97106 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
98107
@@ -177,6 +186,18 @@ run = mdo
177186 el "p" $
178187 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
179188
189+ divClass "demo-group" $ do
190+ un <- fmap value $ text "Username" >> textArea def
191+ pw <- fmap value $ text "Unhidden PW" >> textArea def
192+ let ba :: Dynamic t (BasicAuthData ) = BasicAuthData
193+ <$> fmap T.encodeUtf8 un
194+ <*> fmap T.encodeUtf8 pw
195+ b <- button "Get secret"
196+ r <- secret (Just <$> ba) (0 <$ b)
197+ res <- holdDyn Nothing (reqSuccess <$> r)
198+ display res
199+
200+
180201showXhrResponse :: XhrResponse -> Text
181202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
182203 T.unlines ["stat: " <> tShow stat
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+26−19
@@ -1,8 +1,8 @@
11Name: servant-reflex
2−Version: 0.3.1
3−Synopsis: Servant reflex API generator
4−Description: Servant reflex API generator
5−License: AllRightsReserved
2+Version: 0.3.6
3+Synopsis: servant API generator for reflex apps
4+Description: Generate reflex-compatible client functions from servant API descriptions
5+License: BSD3
66License-file: LICENSE.md
77Author: Greg Hale, Doug Beardsley
88Maintainer: imalsogreg@gmail.com
@@ -17,37 +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,
27+ base >= 4.8 && < 5,
3028 bytestring >= 0.10 && < 0.11,
3129 case-insensitive >= 1.2.0.4 && < 1.3,
32− containers >= 0.5.6 && < 0.6,
30+ containers >= 0.5.6 && < 0.7,
3331 data-default >= 0.5 && < 0.8,
34− exceptions >= 0.8 && < 0.9,
32+ exceptions >= 0.8 && < 0.11,
3533 ghcjs-dom >= 0.2 && < 0.10,
36− http-api-data >= 0.2 && < 0.4,
37− http-media >= 0.6 && < 0.7,
34+ http-api-data >= 0.3.6 && < 0.5,
35+ http-media >= 0.6 && < 0.9,
3836 jsaddle >= 0.8 && < 0.10,
3937 mtl >= 2.2.1 && < 2.3,
4038 network-uri >= 2.6 && < 2.7,
41− reflex >= 0.5 && < 0.6,
42− reflex-dom == 0.4 && < 0.5,
39+ reflex >= 0.5 && < 0.9,
40+ reflex-dom-core >= 0.6 && < 0.8,
4341 safe >= 0.3.9 && < 0.4,
44− servant >= 0.8 && < 0.11,
45− servant-auth >= 0.2.7 && < 0.2.8,
42+ servant >= 0.16 && < 0.19,
43+ servant-auth >= 0.2.1 && < 0.4,
4644 string-conversions >= 0.4 && < 0.5,
4745 text >= 1.2 && < 1.3,
4846 transformers >= 0.4 && < 0.6
4947
50− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
48+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
5149
5250 default-language: Haskell2010
5351
@@ -56,7 +54,16 @@ executable example
5654 buildable: True
5755 else
5856 buildable: False
59− 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
6067 default-language: Haskell2010
6168 main-is: Example.hs
6269 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+10−7
@@ -1,4 +1,5 @@
11{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE CPP #-}
23{-# LANGUAGE DeriveDataTypeable #-}
34{-# LANGUAGE DeriveGeneric #-}
45{-# LANGUAGE FlexibleContexts #-}
@@ -28,11 +29,14 @@ import qualified Data.Text as T
2829import GHC.Generics
2930import Language.Javascript.JSaddle.Monad (MonadJSM)
3031import Reflex
31−import Reflex.Dom
32+import Reflex.Dom.Core
3233import Text.Read
3334
34−
35+#if !MIN_VERSION_reflex_dom_core(0,7,0)
3536type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadJSM (Performable m))
37+#else
38+type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, MonadJSM (Performable m))
39+#endif
3640
3741-- | URI scheme to use
3842data Scheme =
@@ -85,15 +89,14 @@ baseUrlWidget = elClass "div" "base-url" $ do
8589 where pathWidget :: m (Dynamic t BaseUrl)
8690 pathWidget = do
8791 text "Url base path"
88− t <- textInput (def {_textInputConfig_attributes =
89− constDyn ("placeholder" =: "/a/b")})
92+ t <- inputElement def
9093 return $ BasePath <$> value t
9194 fullUrlWidget :: m (Dynamic t BaseUrl)
9295 fullUrlWidget = do
9396 schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def
94− srv <- textInput def {_textInputConfig_attributes = constDyn $ "placeholder" =: "example.com"}
97+ srv <- inputElement def
9598 text ":"
96− prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}
99+ prt <- inputElement def
97100 port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))
98− path <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "a/b" }
101+ path <- inputElement def
99102 return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path
src/Servant/Common/Req.hs+106−92
@@ -4,18 +4,22 @@
44{-# LANGUAGE GADTs #-}
55{-# LANGUAGE OverloadedStrings #-}
66{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE RankNTypes #-}
78{-# LANGUAGE ScopedTypeVariables #-}
89{-# LANGUAGE TupleSections #-}
910
1011module Servant.Common.Req where
1112
1213-------------------------------------------------------------------------------
13−import Control.Concurrent
1414import Control.Applicative (liftA2, liftA3)
15+import Control.Arrow ((&&&))
16+import Control.Concurrent
1517import Control.Monad (join)
1618import Control.Monad.IO.Class (MonadIO, liftIO)
1719import Data.Bifunctor (first)
20+import qualified Data.ByteString.Builder as Builder
1821import qualified Data.ByteString.Lazy.Char8 as BL
22+import Data.ByteString (ByteString)
1923import qualified Data.Map as Map
2024import Data.Maybe (catMaybes, fromMaybe)
2125import Data.Functor.Compose
@@ -25,8 +29,9 @@ import Data.Text (Text)
2529import qualified Data.Text as T
2630import qualified Data.Text.Encoding as TE
2731import Data.Traversable (forM)
28−import Language.Javascript.JSaddle.Monad (JSM, MonadJSM)
29−import Reflex.Dom hiding (tag)
32+import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
33+import qualified Network.URI as N
34+import Reflex.Dom.Core hiding (tag)
3035import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
3136 SupportsServantReflex)
3237import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
@@ -47,6 +52,23 @@ data ReqResult tag a
4752 -- ^ A failure to construct the request tagged with 'tag' at trigger time
4853 deriving (Functor)
4954
55+data ClientOptions = ClientOptions
56+ { optsRequestFixup :: forall a. Show a => XhrRequest a -> JSM (XhrRequest a)
57+ -- ^ Aribtrarily modify requests just before they are sent.
58+ -- Warning: This escape hatch opens the possibility for your
59+ -- requests to diverge from what the server expects, when the
60+ -- server is also derived from a servant API
61+ }
62+
63+defaultClientOptions :: ClientOptions
64+defaultClientOptions = ClientOptions { optsRequestFixup = return }
65+
66+-- withCredentials :: Lens' (XhrRequest a) Bool
67+withCredentials :: (Show a, Functor f) => (Bool -> f Bool) -> XhrRequest a -> f (XhrRequest a)
68+withCredentials inj r@(XhrRequest _ _ cfg) =
69+ let cfg' = (\b -> cfg { _xhrRequestConfig_withCredentials = b}) <$>
70+ inj (_xhrRequestConfig_withCredentials cfg)
71+ in (\c' -> r {_xhrRequest_config = c' }) <$> cfg'
5072
5173------------------------------------------------------------------------------
5274-- | Simple filter/accessor for successful responses, when you want to
@@ -71,6 +93,13 @@ reqFailure (ResponseFailure _ s _) = Just s
7193reqFailure (RequestFailure _ s) = Just s
7294reqFailure _ = Nothing
7395
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+
74103
75104------------------------------------------------------------------------------
76105-- | Simple filter/accessor for the raw XHR response
@@ -138,7 +167,7 @@ reqToReflexRequest
138167 => Text
139168 -> Dynamic t BaseUrl
140169 -> Req t
141− -> (Dynamic t (Either Text (XhrRequest XhrPayload)))
170+ -> Dynamic t (Either Text (XhrRequest XhrPayload))
142171reqToReflexRequest reqMeth reqHost req =
143172 let t :: Dynamic t [Either Text Text]
144173 t = sequence $ reverse $ reqPathParts req
@@ -150,18 +179,22 @@ reqToReflexRequest reqMeth reqHost req =
150179 urlParts = fmap sequence t
151180
152181 urlPath :: Dynamic t (Either Text Text)
153− urlPath = (fmap.fmap) (T.intercalate "/") urlParts
182+ urlPath = (fmap.fmap)
183+ (T.intercalate "/" . fmap escape)
184+ urlParts
154185
155186 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
156187 queryPartString (pName, qp) = case qp of
157188 QueryPartParam p -> ffor p $ \case
158189 Left e -> Just (Left e)
159− Right (Just a) -> Just (Right $ pName <> "=" <> a)
190+ Right (Just a) -> Just (Right $ pName <> "=" <> escape a)
160191 Right Nothing -> Nothing
161192 QueryPartParams ps -> ffor ps $ \pStrings ->
162193 if null pStrings
163194 then Nothing
164− else Just $ Right (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) pStrings))
195+ else Just . Right
196+ . T.intercalate "&"
197+ $ fmap (\p -> pName <> "=" <> escape p) pStrings
165198 QueryPartFlag fl -> ffor fl $ \case
166199 True -> Just $ Right pName
167200 False -> Nothing
@@ -196,10 +229,10 @@ reqToReflexRequest reqMeth reqHost req =
196229 Right $ XhrRequestConfig
197230 { _xhrRequestConfig_sendData = bytesToPayload bBytes
198231 , _xhrRequestConfig_headers =
199− Map.insert "Content-Type" bCT (Map.fromList hs)
232+ Map.insert "Content-Type" bCT (Map.fromList hs)
200233 , _xhrRequestConfig_user = Nothing
201234 , _xhrRequestConfig_password = Nothing
202− , _xhrRequestConfig_responseType = Nothing
235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
203236 , _xhrRequestConfig_withCredentials = False
204237 , _xhrRequestConfig_responseHeaders = def
205238 }
@@ -211,8 +244,8 @@ reqToReflexRequest reqMeth reqHost req =
211244 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
212245 , _xhrRequestConfig_user = Nothing
213246 , _xhrRequestConfig_password = Nothing
214− , _xhrRequestConfig_responseType = Nothing
215− , _xhrRequestConfig_sendData = ""
247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
248+ , _xhrRequestConfig_sendData = mempty
216249 , _xhrRequestConfig_withCredentials = False
217250 }
218251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
@@ -239,42 +272,57 @@ reqToReflexRequest reqMeth reqHost req =
239272displayHttpRequest :: Text -> Text
240273displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
241274
242−-- | This function actually performs the request.
275+-- | This function performs the request
243276performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
244277 => Text
245278 -> Dynamic t (f (Req t))
246279 -> Dynamic t BaseUrl
280+ -> ClientOptions
247281 -> Event t tag
248282 -> m (Event t (tag, f (Either Text XhrResponse)))
249−performRequests reqMeth rs reqHost trigger = do
250− -- let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))
251− let xhrReqs = join $ (\(fxhr :: f (Req t)) -> sequence $ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
252− let reqs = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
253− resps <- performSomeRequestsAsync reqs
283+performRequests reqMeth rs reqHost opts trigger = do
284+ let xhrReqs =
285+ join $ (\(fxhr :: f (Req t)) -> sequence $
286+ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
287+
288+ -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
289+ reqs = attachPromptlyDynWith
290+ (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
291+
292+ resps <- performSomeRequestsAsync opts reqs
254293 return $ getCompose <$> resps
255294
256−-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.
295+-- | Issues a collection of requests when the supplied Event fires.
296+-- When ALL requests from a given firing complete, the results are
297+-- collected and returned via the return Event.
257298performSomeRequestsAsync
258299 :: (MonadIO (Performable m),
259300 MonadJSM (Performable m),
301+#if !MIN_VERSION_reflex_dom_core(0,7,0)
260302 HasWebView (Performable m),
303+#endif
261304 PerformEvent t m,
262305 TriggerEvent t m,
263306 Traversable f,
264− IsXhrPayload a)
265− => Event t (f (Either Text (XhrRequest a)))
307+ IsXhrPayload a,
308+ Show a
309+ )
310+ => ClientOptions
311+ -> Event t (f (Either Text (XhrRequest a)))
266312 -> m (Event t (f (Either Text XhrResponse)))
267−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return
313+performSomeRequestsAsync opts =
314+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
268315
269316
270317------------------------------------------------------------------------------
271318-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
272319-- that accepts 'f (Either e (XhrRequestb))' events
273320performSomeRequestsAsync'
274− :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
275− => (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
321+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
322+ => ClientOptions
323+ -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
276324 -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
277−performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
325+performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
278326 rs <- hrs
279327 resps <- forM rs $ \r -> case r of
280328 Left e -> do
@@ -282,70 +330,17 @@ performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb ->
282330 return resp
283331 Right r' -> do
284332 resp <- liftIO newEmptyMVar
285− _ <- newXhr r' $ liftIO . putMVar resp . Right
333+ r'' <- liftJSM $ (optsRequestFixup opts) r'
334+ _ <- newXhr r'' $ liftIO . putMVar resp . Right
286335 return resp
287336 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
288337 return ()
289338
290339
291340
292−-- | This function actually performs the request.
293−performRequest :: forall t m tag .(SupportsServantReflex t m)
294− => Text
295− -> (Req t)
296− -> Dynamic t BaseUrl
297− -> Event t tag
298− -> m (Event t (tag, XhrResponse), Event t (tag, Text))
299−performRequest reqMeth req reqHost trigger = do
300−
301− let xhrReq = reqToReflexRequest reqMeth reqHost req
302− let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger
303− okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) e) reqs
304− badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) e) reqs
305−
306− resps <- performRequestsAsync okReqs
307−
308− return (resps, badReqs)
309−
310−
311−type XhrPayload = T.Text
341+type XhrPayload = ByteString
312342bytesToPayload :: BL.ByteString -> XhrPayload
313−bytesToPayload = TE.decodeUtf8 . BL.toStrict
314−
315−
316−-- performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)
317−-- => Text
318−-- -> Req t
319−-- -> Dynamic t BaseUrl
320−-- -> Event t tag -> m (Event t (ReqResult tag NoContent))
321−-- performRequestNoBody reqMeth req reqHost trigger = do
322−-- (resp, badReq) <- performRequest reqMeth req reqHost trigger
323−-- let decodeResp = const $ Right NoContent
324−-- return $ leftmost [ fmap (evalResponse decodeResp) resp
325−-- , fmap (uncurry RequestFailure) badReq
326−-- ]
327−
328−
329−-- performRequestCT
330−-- :: (SupportsServantReflex t m,
331−-- MimeUnrender ct a)
332−-- => Proxy ct
333−-- -> Text
334−-- -> Req t
335−-- -> Dynamic t BaseUrl
336−-- -> Event t tag
337−-- -> m (Event t (ReqResult tag a))
338−-- performRequestCT ct reqMeth req reqHost trigger = do
339−-- (resp, badReq) <- performRequest reqMeth req reqHost trigger
340−-- let decodeResp x = first T.pack .
341−-- mimeUnrender ct .
342−-- BL.fromStrict .
343−-- TE.encodeUtf8 =<< note "No body text"
344−-- (_xhrResponse_responseText x)
345−
346−-- return $ leftmost [fmap (evalResponse decodeResp) resp
347−-- , fmap (uncurry RequestFailure) badReq
348−-- ]
343+bytesToPayload = BL.toStrict
349344
350345
351346performRequestsCT
@@ -355,19 +350,20 @@ performRequestsCT
355350 -> Text
356351 -> Dynamic t (f (Req t))
357352 -> Dynamic t BaseUrl
353+ -> ClientOptions
358354 -> Event t tag
359355 -> m (Event t (f (ReqResult tag a)))
360−performRequestsCT ct reqMeth reqs reqHost trigger = do
361− resps <- performRequests reqMeth reqs reqHost trigger
362− let decodeResp x = first T.pack .
363− mimeUnrender ct .
364− BL.fromStrict .
365− TE.encodeUtf8 =<< note "No body text"
366− (_xhrResponse_responseText x)
356+performRequestsCT ct reqMeth reqs reqHost opts trigger = do
357+ resps <- performRequests reqMeth reqs reqHost opts trigger
358+ let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
359+ first T.pack .
360+ mimeUnrender ct $
361+ BL.fromStrict x
362+ decodeResp _ = Left "No body"
367363 return $ fmap
368364 (\(t,rs) -> ffor rs $ \r -> case r of
369365 Left e -> RequestFailure t e
370− Right g -> evalResponse decodeResp (t,g)
366+ Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
371367 )
372368 resps
373369
@@ -378,10 +374,11 @@ performRequestsNoBody
378374 => Text
379375 -> Dynamic t (f (Req t))
380376 -> Dynamic t BaseUrl
377+ -> ClientOptions
381378 -> Event t tag
382379 -> m (Event t (f (ReqResult tag NoContent)))
383−performRequestsNoBody reqMeth reqs reqHost trigger = do
384− resps <- performRequests reqMeth reqs reqHost trigger
380+performRequestsNoBody reqMeth reqs reqHost opts trigger = do
381+ resps <- performRequests reqMeth reqs reqHost opts trigger
385382 let decodeResp = const $ Right NoContent
386383 return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
387384 Left e -> RequestFailure tag e
@@ -394,7 +391,8 @@ evalResponse
394391 -> (tag, XhrResponse)
395392 -> ReqResult tag a
396393evalResponse decode (tag, xhr) =
397− let okStatus = _xhrResponse_status xhr < 400
394+ let status = _xhrResponse_status xhr
395+ okStatus = status >= 200 && status < 400
398396 errMsg = fromMaybe
399397 ("Empty response with error code " <>
400398 T.pack (show $ _xhrResponse_status xhr))
@@ -407,7 +405,17 @@ evalResponse decode (tag, xhr) =
407405 else ResponseFailure tag errMsg xhr
408406 in respPayld
409407
408+------------------------------------------------------------------------------
409+-- | Utility for simultaneously accessing/filtering Success and Failure
410+-- response 'Event's,
411+fanReqResult :: Reflex t => Event t (ReqResult tag a) -> (Event t Text, Event t a)
412+fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess
410413
414+------------------------------------------------------------------------------
415+-- | Utility for simultaneously accessing/filtering Success and Failure
416+-- response 'Event's, but keeping the request tag
417+fanReqResult' :: Reflex t => Event t (ReqResult tag a) -> (Event t (tag, Text), Event t (tag, a))
418+fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'
411419
412420
413421note :: e -> Maybe a -> Either e a
@@ -416,3 +424,9 @@ note e = maybe (Left e) Right
416424fmapL :: (e -> e') -> Either e a -> Either e' a
417425fmapL _ (Right a) = Right a
418426fmapL f (Left e) = Left (f e)
427+
428+builderToText :: Builder.Builder -> T.Text
429+builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
430+
431+escape :: T.Text -> T.Text
432+escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
src/Servant/Reflex.hs+157−86
@@ -8,6 +8,7 @@
88{-# LANGUAGE MultiParamTypeClasses #-}
99{-# LANGUAGE OverloadedStrings #-}
1010{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE Rank2Types #-}
1112{-# LANGUAGE ScopedTypeVariables #-}
1213{-# LANGUAGE TupleSections #-}
1314{-# LANGUAGE TypeFamilies #-}
@@ -24,48 +25,57 @@
2425-- API.
2526module Servant.Reflex
2627 ( client
28+ , clientWithOpts
29+ , clientWithOptsAndResultHandler
30+ , clientWithRoute
31+ , clientWithRouteAndResultHandler
2732 , BuildHeaderKeysTo(..)
2833 , toHeaders
29− , HasClient(..)
34+ , HasClient
35+ , Client
3036 , module Servant.Common.Req
3137 , module Servant.Common.BaseUrl
3238 ) where
3339
3440------------------------------------------------------------------------------
3541import Control.Applicative
36−import Data.Monoid ((<>))
37−import qualified Data.Set as Set
38−import qualified Data.Text.Encoding as E
39−import Data.CaseInsensitive (mk)
42+import qualified Data.CaseInsensitive as CI
4043import Data.Functor.Identity
41−import Data.Proxy (Proxy (..))
4244import qualified Data.Map as Map
45+import Data.Monoid ((<>))
46+import Data.Proxy (Proxy (..))
47+import qualified Data.Set as Set
4348import Data.Text (Text)
4449import qualified Data.Text as T
50+import qualified Data.Text.Encoding as E
4551import GHC.Exts (Constraint)
4652import GHC.TypeLits (KnownSymbol, symbolVal)
47−import Servant.API ((:<|>)(..),(:>), BasicAuth,
48− BasicAuthData, BuildHeadersTo(..),
49− Capture, contentType, Header,
50− Headers(..), HttpVersion, IsSecure,
51− MimeRender(..), MimeUnrender,
52− NoContent, QueryFlag, QueryParam,
53− QueryParams, Raw, ReflectMethod(..),
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 (..),
5460 RemoteHost, ReqBody,
55− ToHttpApiData(..), Vault, Verb)
61+ ToHttpApiData (..), Vault, Verb,
62+ contentType)
63+import Servant.API.Description (Summary)
5664import qualified Servant.Auth as Auth
5765
58−import Reflex.Dom (Dynamic, Event, Reflex,
59− XhrRequest(..),
60− XhrResponseHeaders(..),
61− XhrResponse(..), attachPromptlyDynWith, constDyn, ffor, fmapMaybe,
62− leftmost, performRequestsAsync,
63− )
66+import Reflex.Dom.Core (Dynamic, Event, Reflex,
67+ XhrRequest (..), XhrResponse (..),
68+ XhrResponseHeaders (..),
69+ attachPromptlyDynWith, constDyn, ffor,
70+ fmapMaybe, leftmost,
71+ performRequestsAsync)
6472------------------------------------------------------------------------------
6573import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
6674 showBaseUrl,
6775 SupportsServantReflex)
68−import Servant.Common.Req (Req, ReqResult(..), QParam(..),
76+import Servant.Common.Req (ClientOptions(..),
77+ defaultClientOptions,
78+ Req, ReqResult(..), QParam(..),
6979 QueryPart(..), addHeader, authData,
7080 defReq, evalResponse, prependToPathParts,
7181 -- performRequestCT,
@@ -75,9 +85,10 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),
7585 performSomeRequestsAsync,
7686 qParamToQueryPart, reqBody,
7787 reqSuccess, reqFailure,
78− reqMethod, respHeaders, response,
88+ reqMethod, respHeaders,
89+ response,
7990 reqTag,
80− qParams)
91+ qParams, withCredentials)
8192
8293
8394-- * Accessing APIs as a Client
@@ -92,28 +103,75 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),
92103-- >
93104-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
94105-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
95−-- -> m (Event t (l, ReqResult Book)))
106+-- > -> m (Event t (l, ReqResult Book)))
96107-- > (getAllBooks :<|> postNewBook) = client myApi host
97108-- > where host = constDyn $ BaseUrl Http "localhost" 8080
98−client :: (HasClient t m layout tag)
99− => Proxy layout -> Proxy m -> Proxy tag -> Dynamic t BaseUrl -> Client t m layout tag
100−client p q t baseurl = clientWithRoute p q t defReq baseurl
109+client
110+ :: (HasClient t m layout tag)
111+ => Proxy layout
112+ -> Proxy m
113+ -> Proxy tag
114+ -> Dynamic t BaseUrl
115+ -> Client t m layout tag
116+client p q t baseurl = clientWithRoute p q t defReq baseurl defaultClientOptions
117+
118+clientWithOpts
119+ :: (HasClient t m layout tag)
120+ => Proxy layout
121+ -> Proxy m
122+ -> Proxy tag
123+ -> Dynamic t BaseUrl
124+ -> ClientOptions
125+ -> Client t m layout tag
126+clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
127+
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
101141
102142
103143-- | This class lets us define how each API combinator
104144-- influences the creation of an HTTP request. It's mostly
105145-- an internal class, you can just use 'client'.
106−class HasClient t m layout (tag :: *) where
146+class Monad m => HasClient t m layout (tag :: *) where
107147 type Client t m layout tag :: *
108− clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> 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
109167
110168
111169instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
112170 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
113171
114− clientWithRoute Proxy q pTag req baseurl =
115− clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>
116− clientWithRoute (Proxy :: Proxy b) q pTag req baseurl
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
117175
118176
119177-- Capture. Example:
@@ -134,11 +192,9 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
134192 type Client t m (Capture capture a :> sublayout) tag =
135193 Dynamic t (Either Text a) -> Client t m sublayout tag
136194
137− clientWithRoute Proxy q t req baseurl val =
138− clientWithRoute (Proxy :: Proxy sublayout)
139− q t
140− (prependToPathParts p req)
141− baseurl
195+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
196+ clientWithRouteAndResultHandler
197+ (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
142198 where p = (fmap . fmap) (toUrlPiece) val
143199
144200
@@ -151,9 +207,8 @@ instance {-# OVERLAPPABLE #-}
151207 Event t tag -> m (Event t (ReqResult tag a))
152208 -- TODO how to access input types here?
153209 -- ExceptT ServantError IO a
154− clientWithRoute Proxy _ _ req baseurl trigs =
155− -- performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs
156− fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl trigs
210+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
211+ wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
157212 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
158213 req' = req { reqMethod = method }
159214
@@ -166,29 +221,33 @@ instance {-# OVERLAPPING #-}
166221 Event t tag -> m (Event t (ReqResult tag NoContent))
167222 -- TODO: how to access input types here?
168223 -- ExceptT ServantError IO NoContent
169− clientWithRoute Proxy _ _ req baseurl =
170− (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl
224+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
225+ wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
171226 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
172227
173228
174229toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
175230toHeaders r =
176− let toBS = E.encodeUtf8
177− hdrs = maybe []
178− (\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))
179233 (Map.toList $ _xhrResponse_headers xhr))
180234 (response r)
181235 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
182236
237+
183238class BuildHeaderKeysTo hs where
184− buildHeaderKeysTo :: Proxy hs -> [T.Text]
239+ buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
185240
186241instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
187242 where buildHeaderKeysTo _ = []
188243
189244instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
190245 => BuildHeaderKeysTo ((Header h v) ': xs) where
191− 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+
192251
193252-- HEADERS Verb (Content) --
194253-- Headers combinator not treated in fully general case,
@@ -203,10 +262,10 @@ instance {-# OVERLAPPABLE #-}
203262 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
204263 type Client t m (Verb method status cts' (Headers ls a)) tag =
205264 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
206− clientWithRoute Proxy _ _ req baseurl trigs = do
265+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
207266 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
208− resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl trigs
209− return $ toHeaders <$> resp
267+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
268+ wrap $ toHeaders <$> resp
210269 where req' = req { respHeaders =
211270 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
212271 }
@@ -219,10 +278,10 @@ instance {-# OVERLAPPABLE #-}
219278 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
220279 type Client t m (Verb method status cts (Headers ls NoContent)) tag
221280 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
222− clientWithRoute Proxy _ _ req baseurl trigs = do
281+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
223282 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
224− resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl trigs
225− return $ toHeaders <$> resp
283+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
284+ wrap $ toHeaders <$> resp
226285 where req' = req {respHeaders =
227286 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
228287 }
@@ -249,11 +308,11 @@ instance (KnownSymbol sym, ToHttpApiData a,
249308 type Client t m (Header sym a :> sublayout) tag =
250309 Dynamic t (Either Text a) -> Client t m sublayout tag
251310
252− clientWithRoute Proxy q t req baseurl eVal =
253− clientWithRoute (Proxy :: Proxy sublayout)
254− q t
255− (Servant.Common.Req.addHeader hname eVal req)
256− baseurl
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
257316 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
258317
259318
@@ -267,8 +326,21 @@ instance HasClient t m sublayout tag
267326 type Client t m (HttpVersion :> sublayout) tag =
268327 Client t m sublayout tag
269328
270− clientWithRoute Proxy q t =
271− 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+
272344
273345
274346-- | If you use a 'QueryParam' in one of your endpoints in your API,
@@ -298,15 +370,15 @@ instance HasClient t m sublayout tag
298370-- > -- 'getBooksBy Nothing' for all books
299371-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
300372instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)
301− => HasClient t m (QueryParam sym a :> sublayout) tag where
373+ => HasClient t m (QueryParam' mods sym a :> sublayout) tag where
302374
303− type Client t m (QueryParam sym a :> sublayout) tag =
375+ type Client t m (QueryParam' mods sym a :> sublayout) tag =
304376 Dynamic t (QParam a) -> Client t m sublayout tag
305377
306378 -- if mparam = Nothing, we don't add it to the query string
307− clientWithRoute Proxy q t req baseurl mparam =
308− clientWithRoute (Proxy :: Proxy sublayout) q t
309− (req {qParams = paramPair : qParams req}) baseurl
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
310382
311383 where pname = symbolVal (Proxy :: Proxy sym)
312384 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -350,8 +422,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
350422 type Client t m (QueryParams sym a :> sublayout) tag =
351423 Dynamic t [a] -> Client t m sublayout tag
352424
353− clientWithRoute Proxy q t req baseurl paramlist =
354− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
425+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
426+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
355427
356428 where req' = req { qParams = (T.pack pname, params') : qParams req }
357429 pname = symbolVal (Proxy :: Proxy sym)
@@ -390,8 +462,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
390462 type Client t m (QueryFlag sym :> sublayout) tag =
391463 Dynamic t Bool -> Client t m sublayout tag
392464
393− clientWithRoute Proxy q t req baseurl flag =
394− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
465+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
466+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
395467
396468 where req' = req { qParams = thisPair : qParams req }
397469 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -405,7 +477,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
405477 -> Event t tag
406478 -> m (Event t (ReqResult tag ()))
407479
408− clientWithRoute _ _ _ _ baseurl xhrs triggers = do
480+ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
409481
410482 let xhrs' = liftA2 (\x path -> case x of
411483 Left e -> Left e
@@ -416,7 +488,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
416488 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
417489
418490 resps <- performRequestsAsync okReq
419− return $ leftmost [ uncurry RequestFailure <$> badReq
491+ wrap $ leftmost [ uncurry RequestFailure <$> badReq
420492 , evalResponse (const $ Right ()) <$> resps
421493 ]
422494
@@ -447,8 +519,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
447519 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
448520 Dynamic t (Either Text a) -> Client t m sublayout tag
449521
450− clientWithRoute Proxy q t req baseurl body =
451− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
522+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
523+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
452524 where req' = req { reqBody = bodyBytesCT }
453525 ctProxy = Proxy :: Proxy ct
454526 ctString = T.pack $ show $ contentType ctProxy
@@ -462,9 +534,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
462534instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
463535 type Client t m (path :> sublayout) tag = Client t m sublayout tag
464536
465− clientWithRoute Proxy q t req baseurl =
466− clientWithRoute (Proxy :: Proxy sublayout) q t
467− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl
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
468540
469541 where p = symbolVal (Proxy :: Proxy path)
470542
@@ -472,23 +544,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient
472544instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
473545 type Client t m (Vault :> api) tag = Client t m api tag
474546
475− clientWithRoute Proxy q t req baseurl =
476− clientWithRoute (Proxy :: Proxy api) q t req baseurl
547+ clientWithRouteAndResultHandler Proxy =
548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
477549
478550
479551instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
480552 type Client t m (RemoteHost :> api) tag = Client t m api tag
481553
482− clientWithRoute Proxy q t req baseurl =
483− clientWithRoute (Proxy :: Proxy api) q t req baseurl
554+ clientWithRouteAndResultHandler Proxy =
555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
484556
485557
486558
487559instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
488560 type Client t m (IsSecure :> api) tag = Client t m api tag
489561
490− clientWithRoute Proxy q t req baseurl =
491− clientWithRoute (Proxy :: Proxy api) q t req baseurl
562+ clientWithRouteAndResultHandler Proxy =
563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
492564
493565
494566instance (HasClient t m api tag, Reflex t)
@@ -497,8 +569,8 @@ instance (HasClient t m api tag, Reflex t)
497569 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
498570 -> Client t m api tag
499571
500− clientWithRoute Proxy q t req baseurl authdata =
501− clientWithRoute (Proxy :: Proxy api) q t req' baseurl
572+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
573+ clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
502574 where
503575 req' = req { authData = Just authdata }
504576
@@ -541,7 +613,7 @@ for empty and one for non-empty lists).
541613instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where
542614
543615 type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag
544− clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)
616+ clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)
545617
546618
547619type family HasCookieAuth xs :: Constraint where
@@ -550,4 +622,3 @@ type family HasCookieAuth xs :: Constraint where
550622 HasCookieAuth '[] = CookieAuthNotEnabled
551623
552624class CookieAuthNotEnabled
553−
src/Servant/Reflex/Multi.hs+82−53
@@ -16,12 +16,15 @@
1616module Servant.Reflex.Multi (
1717 -- * Compute servant client functions
1818 clientA
19+ , clientWithOptsA
1920 , BaseUrl(..)
2021 , Scheme(..)
2122
2223 -- * Build QueryParam arguments
2324 , QParam(..)
2425
26+ -- * Access response data
27+ , withCredentials
2528
2629 -- * Access response data
2730 , ReqResult(..)
@@ -34,40 +37,45 @@ module Servant.Reflex.Multi (
3437 ) where
3538
3639------------------------------------------------------------------------------
37−import Control.Applicative (liftA2)
38−import Data.Functor.Compose (Compose (..), getCompose)
39−import Data.Proxy (Proxy (..))
40−import qualified Data.Set as Set
41−import Data.Text (Text)
42−import qualified Data.Text as T
43−import qualified Data.Text.Encoding as E
44−import GHC.TypeLits (KnownSymbol, symbolVal)
45−import Servant.API ((:<|>) (..), (:>), BasicAuth,
46− BasicAuthData, BuildHeadersTo (..),
47− Capture, Header, Headers (..),
48− HttpVersion, IsSecure, MimeRender (..),
49− MimeUnrender, NoContent, QueryFlag,
50− QueryParam, QueryParams, Raw,
51− ReflectMethod (..), RemoteHost,
52− ReqBody, ToHttpApiData (..), Vault,
53− Verb, contentType)
54−
55−import Reflex.Dom (Dynamic, Event, Reflex,
56− XhrRequest (..),
57− XhrResponseHeaders (..),
58− 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)
5964------------------------------------------------------------------------------
6065import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
6166 SupportsServantReflex)
62−import Servant.Common.Req (QParam (..), QueryPart (..), Req,
67+import Servant.Common.Req (ClientOptions,
68+ QParam (..), QueryPart (..), Req,
6369 ReqResult (..), addHeader, authData,
64− defReq, performRequestsCT,
70+ defReq,
71+ defaultClientOptions,
72+ performRequestsCT,
6573 performRequestsNoBody,
6674 performSomeRequestsAsync,
6775 prependToPathParts, qParamToQueryPart,
6876 qParams, reqBody, reqFailure,
6977 reqMethod, reqSuccess, reqSuccess',
70− respHeaders, response)
78+ respHeaders, response, withCredentials)
7179import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
7280
7381
@@ -77,14 +85,24 @@ clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
7785 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
7886clientA p q f tag baseurl =
7987 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
88+ defaultClientOptions
89+
8090
91+-- | A version of @client@ that sets the withCredentials flag
92+-- on requests. Use this function for clients of CORS API's
93+clientWithOptsA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
94+ => Proxy layout -> Proxy m -> Proxy f -> Proxy tag
95+ -> Dynamic t BaseUrl -> ClientOptions -> ClientMulti t m layout f tag
96+clientWithOptsA p q f tag baseurl opts =
97+ clientWithRouteMulti p q f tag
98+ (constDyn (pure defReq)) baseurl opts
8199
82100------------------------------------------------------------------------------
83101class HasClientMulti t m layout f (tag :: *) where
84102 type ClientMulti t m layout f tag :: *
85103 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
86104 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
87− -> ClientMulti t m layout f tag
105+ -> ClientOptions -> ClientMulti t m layout f tag
88106
89107
90108------------------------------------------------------------------------------
@@ -92,9 +110,9 @@ instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>
92110 HasClientMulti t m (a :<|> b) f tag where
93111 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>
94112 ClientMulti t m b f tag
95− clientWithRouteMulti Proxy q f tag reqs baseurl =
96− clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl :<|>
97− clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl
113+ clientWithRouteMulti Proxy q f tag reqs baseurl opts =
114+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>
115+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts
98116
99117
100118------------------------------------------------------------------------------
@@ -107,8 +125,8 @@ instance (SupportsServantReflex t m,
107125 type ClientMulti t m (Capture capture a :> sublayout) f tag =
108126 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
109127
110− clientWithRouteMulti _ q f tag reqs baseurl vals =
111− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
128+ clientWithRouteMulti _ q f tag reqs baseurl opts vals =
129+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
112130 where
113131 reqs' = (prependToPathParts <$> ps <*>) <$> reqs
114132 ps = (fmap . fmap . fmap) toUrlPiece vals
@@ -128,8 +146,8 @@ instance {-# OVERLAPPABLE #-}
128146 type ClientMulti t m (Verb method status cts' a) f tag =
129147 Event t tag -> m (Event t (f (ReqResult tag a)))
130148
131− clientWithRouteMulti _ _ _ _ reqs baseurl =
132− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
149+ clientWithRouteMulti _ _ _ _ reqs baseurl opts =
150+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts
133151 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
134152 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
135153
@@ -143,8 +161,8 @@ instance {-# OVERLAPPING #-}
143161 Event t tag -> m (Event t (f (ReqResult tag NoContent)))
144162 -- TODO: how to access input types here?
145163 -- ExceptT ServantError IO NoContent
146− clientWithRouteMulti Proxy _ _ _ req baseurl =
147− performRequestsNoBody method req baseurl
164+ clientWithRouteMulti Proxy _ _ _ req baseurl opts =
165+ performRequestsNoBody method req baseurl opts
148166 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
149167
150168
@@ -158,9 +176,9 @@ instance {-# OVERLAPPABLE #-}
158176 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where
159177 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =
160178 Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))
161− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
179+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
162180 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
163− resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl triggers :: m (Event t (f (ReqResult tag a)))
181+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))
164182 return $ fmap toHeaders <$> resp
165183 where
166184 reqs' = fmap (\r ->
@@ -181,9 +199,9 @@ instance {-# OVERLAPPABLE #-}
181199 cts (Headers ls NoContent)) f tag where
182200 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag
183201 = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))
184− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
202+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
185203 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
186− resp <- performRequestsNoBody method reqs' baseurl triggers
204+ resp <- performRequestsNoBody method reqs' baseurl opts triggers
187205 return $ fmap toHeaders <$> resp
188206 where reqs' = fmap (\req ->
189207 req {respHeaders = OnlyHeaders (Set.fromList
@@ -203,11 +221,11 @@ instance (KnownSymbol sym,
203221 type ClientMulti t m (Header sym a :> sublayout) f tag =
204222 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
205223
206− clientWithRouteMulti Proxy f q tag reqs baseurl eVals =
224+ clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =
207225 clientWithRouteMulti (Proxy :: Proxy sublayout) f
208226 q tag
209227 reqs'
210− baseurl
228+ baseurl opts
211229 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
212230 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
213231 <$> eVals <*>) <$> reqs
@@ -224,6 +242,17 @@ instance HasClientMulti t m sublayout f tag
224242 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
225243
226244
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+
227256------------------------------------------------------------------------------
228257instance (KnownSymbol sym,
229258 ToHttpApiData a,
@@ -237,9 +266,9 @@ instance (KnownSymbol sym,
237266
238267 -- if mparam = Nothing, we don't add it to the query string
239268 -- TODO: Check the above comment
240− clientWithRouteMulti Proxy q f tag reqs baseurl mparams =
269+ clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =
241270 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
242− reqs' baseurl
271+ reqs' baseurl opts
243272
244273 where pname = symbolVal (Proxy :: Proxy sym)
245274 p prm = QueryPartParam $ fmap qParamToQueryPart prm
@@ -260,8 +289,8 @@ instance (KnownSymbol sym,
260289 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
261290 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
262291
263− clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =
264− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
292+ clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =
293+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
265294
266295 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }
267296 pname = symbolVal (Proxy :: Proxy sym)
@@ -279,8 +308,8 @@ instance (KnownSymbol sym,
279308 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
280309 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
281310
282− clientWithRouteMulti Proxy q f' tag reqs baseurl flags =
283− clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl
311+ clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =
312+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts
284313
285314 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
286315 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
@@ -294,10 +323,10 @@ instance (SupportsServantReflex t m,
294323 -> Event t tag
295324 -> m (Event t (f (ReqResult tag ())))
296325
297− clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do
326+ clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do
298327 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
299328 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
300− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync rawReqs''
329+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''
301330 return resps
302331 where
303332 aux (tag, Right r) = ResponseSuccess tag () r
@@ -313,8 +342,8 @@ instance (MimeRender ct a,
313342 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
314343 Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
315344
316− clientWithRouteMulti Proxy q f tag reqs baseurl bodies =
317− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
345+ clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
346+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
318347 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
319348 ctProxy = Proxy :: Proxy ct
320349 ctString = T.pack $ show $ contentType ctProxy
@@ -365,8 +394,8 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
365394 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))
366395 -> ClientMulti t m api f tag
367396
368− clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =
369− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl
397+ clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =
398+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts
370399 where
371400 req' a r = r { authData = Just (constDyn a) }
372401 reqs' = liftA2 req' <$> authdatas <*> reqs
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+20−5
@@ -2,14 +2,17 @@
22{-# LANGUAGE DeriveGeneric #-}
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE TypeApplications #-}
56{-# LANGUAGE TypeFamilies #-}
67{-# LANGUAGE TypeOperators #-}
78
89import Control.Monad.IO.Class (liftIO)
10+import Control.Monad.Reader (reader)
911import Data.Aeson
1012import Data.Bool
1113import Data.Char (toUpper)
1214import qualified Data.List as L
15+import Data.Maybe (fromMaybe)
1316import Data.Monoid
1417import Data.Proxy
1518import Data.Text hiding (head, length, map,
@@ -24,6 +27,7 @@ import Snap.Http.Server
2427import Servant
2528import Servant.Server
2629-- import Snap.Util.FileServe
30+import System.Environment (lookupEnv)
2731import API
2832import Snap
2933
@@ -39,7 +43,7 @@ instance ToJSON Greet
3943testApi :: Proxy API
4044testApi = Proxy
4145
42−data App = App
46+data App = App { appStaticDir :: String }
4347
4448-- Server-side handlers.
4549--
@@ -47,8 +51,10 @@ data App = App
4751-- that represents the API, are glued together using :<|>.
4852--
4953-- Each handler runs in the 'ExceptT ServantErr IO' monad.
50−server :: Server API (Handler App App)
51−server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> serveDirectory "static"
54+server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
55+server = return () :<|> return 100 :<|> sayhi :<|> dbl
56+ :<|> multi :<|> qna :<|> serveSecret
57+ :<|> statics
5258 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
5359 sayhi nm greetings withGusto = case nm of
5460 Nothing -> return ("Sorry, who are you?" :: Text)
@@ -69,18 +75,27 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|>
6975 putStrLn $ "qna got: " ++ show q
7076 T.putStrLn $ unQuestion q
7177 return $ Answer $ unQuestion q
78+ serveSecret _ = do
79+ req <- getRequest
80+ liftIO $ putStrLn (show req)
81+ return 101
82+ statics = do
83+ staticDir <- reader appStaticDir
84+ serveDirectory staticDir
7285
7386-- Turn the server into a WAI app. 'serve' is provided by servant,
7487-- more precisely by the Servant.Server module.
7588test :: Handler App App ()
76−test = serveSnap testApi server
89+test = serveSnapWithContext testApi
90+ (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server
7791
7892initApp :: SnapletInit App App
7993initApp = makeSnaplet "myapp" "example" Nothing $ do
94+ staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")
8095 addRoutes [("", test)
8196 ,("", serveDirectory "static")
8297 ]
83− return App
98+ return (App staticDir)
8499
85100-- Put this all to work!
86101main :: 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+8−7
@@ -19,13 +19,14 @@ executable back
1919 main-is: Main.hs
2020 -- other-modules:
2121 -- other-extensions:
22− build-depends: aeson >= 0.9 && < 1.1
23− , base >=4.8 && <4.10
24− , snap >= 1.0 && < 1.1
25− , snap-server >= 1.0 && < 1.1
22+ build-depends: aeson >= 0.9 && < 1.5
23+ , base >=4.8 && < 5
24+ , mtl
25+ , snap >= 1.0 && < 1.2
26+ , snap-server >= 1.0 && < 1.2
2627 , snap-core >= 1.0 && < 1.1
27− , servant >= 0.8 && < 0.11
28− , servant-snap >= 0.7.2 && < 0.8
29− , text >= 1.2 && < 1.3
28+ , servant >= 0.16 && < 0.18
29+ , servant-snap >= 0.8 && < 0.9
30+ , text >= 1.0 && < 1.3
3031 -- hs-source-dirs:
3132 default-language: Haskell2010
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+ }