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

Submodule changed.

deps/reflex-platformnew file+1

Submodule changed.

deps/servantnew file+1

Submodule changed.

deps/servant-snapnew file+1

Submodule changed.

exec/API.hs−1
@@ -40,7 +40,6 @@ 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
4443 :<|> Raw
4544
4645type GET = Get '[JSON] ()
exec/Example.hs+6−27
@@ -1,4 +1,3 @@
1−{-# LANGUAGE DataKinds #-}
21{-# LANGUAGE FlexibleContexts #-}
32{-# LANGUAGE GADTs #-}
43{-# LANGUAGE OverloadedStrings #-}
@@ -15,14 +14,12 @@ import Control.Monad.Fix (MonadFix)
1514import Data.Monoid (First(..), (<>))
1615import Data.Text (Text)
1716import qualified Data.Text as T
18−import qualified Data.Text.Encoding as T
1917import GHC.TypeLits
2018import Servant.API
2119import API
2220import Data.Proxy
2321import Text.Read (readMaybe)
24−import Reflex.Dom.Core hiding (run, mainWidget)
25−import Reflex.Dom (mainWidget)
22+import Reflex.Dom hiding (run)
2623------------------------------------------------------------------------------
2724import Servant.Reflex
2825import Servant.Reflex.Multi
@@ -46,7 +43,7 @@ runMulti :: forall t m. (SupportsServantReflex t m,
4643runMulti = do
4744 url <- baseUrlWidget
4845 el "br" blank
49− let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =
46+ let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ ) =
5047 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
5148
5249 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
@@ -69,12 +66,9 @@ runMulti = do
6966 textInput def
7067 gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
7168 b <- button "Go"
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')
69+ r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts) (constDyn [True, False]) (1 <$ b)
7770
71+ dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes . fmap reqSuccess <$> r')
7872
7973 return ()
8074
@@ -97,11 +91,8 @@ run = mdo
9791 el "br" (return ())
9892
9993 -- Name the computed API client functions
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
94+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> doRaw) =
95+ client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url
10596
10697 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
10798
@@ -186,18 +177,6 @@ run = mdo
186177 el "p" $
187178 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
188179
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−
201180showXhrResponse :: XhrResponse -> Text
202181showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
203182 T.unlines ["stat: " <> tShow stat
nix/nix.confdeleted−3
@@ -1,3 +0,0 @@
1−substituters = https://cache.nixos.org/ https://nixcache.reflex-frp.org/
2−trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=
3−trusted-users = travis
nix/reflex-platform.nixdeleted−7
@@ -1,7 +0,0 @@
1−let
2− rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;
3−in import (builtins.fetchTarball
4− {
5− url = "https://github.com/reflex-frp/reflex-platform/archive/${rev}.tar.gz";
6− sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;
7− }) {}
nix/servant-snap.nixdeleted−7
@@ -1,7 +0,0 @@
1−# Servant-snap is marked broken in nixpkgs
2−{ nixpkgs ? import <nixpkgs> {}}: self: super:
3−self.callCabal2nix "servant-snap" (nixpkgs.fetchgit {
4− url = "https://github.com/haskell-servant/servant-snap.git";
5− rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";
6− sha256 = "sha256-fzzQGwG8Ko72OO/kwLMG52eNZSt3F2dxhNgM9gaO4yQ=";
7−}) {}
nix/testresults.nixdeleted−17
@@ -1,17 +0,0 @@
1−{ curl, reflexPlatform, testdriver, testserver, phantomjs }:
2−
3−reflexPlatform.nixpkgs.pkgs.runCommand "runWebdriveTest.sh" {} ''
4− echo About to phantom
5− ${phantomjs}/bin/phantomjs --webdriver=127.0.0.1:4444 &
6− sleep 3
7− echo About to Server
8− STATIC_DIR=${testserver}/static ${testserver}/back -q --no-access-log --no-error-log -p 8000 &
9− sleep 3
10− ${curl}/bin/curl localhost:8000
11− ${curl}/bin/curl localhost:8000/runmain.js
12− echo About to testdrive
13− ${testdriver}/bin/spec > $out 2>&1
14− echo Done
15− trap "exit" INT TERM
16− trap "kill 0" EXIT
17− ''
nix/testserver.nixdeleted−9
@@ -1,9 +0,0 @@
1−servant-reflex: self: super:
2−
3−(self.callCabal2nix "testserver" ../testserver {}).overrideDerivation (drv: {
4− postInstall = ''
5− cp dist/build/back/back $out/back
6− mkdir $out/static
7− cp ${servant-reflex}/bin/example.jsexe/* $out/static/
8− '';
9−})
overrides-ghc.nixnew file+11
@@ -0,0 +1,11 @@
1+{ reflex-platform, ... }:
2+let
3+ c2n = reflex-platform.cabal2nixResult;
4+ dc = reflex-platform.lib.dontCheck;
5+in reflex-platform.ghc.override {
6+ overrides = self: super: {
7+ servant-snap = dc (self.callPackage (c2n deps/servant-snap) {});
8+ heist = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});
9+ xmlhtml = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
10+ };
11+}
overrides.nixnew file+9
@@ -0,0 +1,9 @@
1+{ reflex-platform, ... }:
2+let
3+ dc = reflex-platform.lib.dontCheck;
4+ c2n = reflex-platform.cabal2nixResult;
5+in
6+reflex-platform.ghcjs.override {
7+ overrides = self: super: {
8+ };
9+}
servant-reflex.cabal+19−26
@@ -1,8 +1,8 @@
11Name: servant-reflex
2−Version: 0.3.6
3−Synopsis: servant API generator for reflex apps
4−Description: Generate reflex-compatible client functions from servant API descriptions
5−License: BSD3
2+Version: 0.3.1
3+Synopsis: Servant reflex API generator
4+Description: Servant reflex API generator
5+License: AllRightsReserved
66License-file: LICENSE.md
77Author: Greg Hale, Doug Beardsley
88Maintainer: imalsogreg@gmail.com
@@ -17,35 +17,37 @@ Flag Example
1717
1818library
1919 exposed-modules:
20− Servant.Common.BaseUrl
21− Servant.Common.Req
2220 Servant.Reflex
2321 Servant.Reflex.Multi
2422
23+ other-modules:
24+ Servant.Common.BaseUrl
25+ Servant.Common.Req
26+
2527 hs-source-dirs: src
2628 build-depends:
27− base >= 4.8 && < 5,
29+ base >= 4.8 && < 4.10,
30+ aeson >= 0.11 && < 1.0,
2831 bytestring >= 0.10 && < 0.11,
2932 case-insensitive >= 1.2.0.4 && < 1.3,
30− containers >= 0.5.6 && < 0.7,
33+ containers >= 0.5.6 && < 0.6,
3134 data-default >= 0.5 && < 0.8,
32− exceptions >= 0.8 && < 0.11,
35+ exceptions >= 0.8 && < 0.9,
3336 ghcjs-dom >= 0.2 && < 0.10,
34− http-api-data >= 0.3.6 && < 0.5,
35− http-media >= 0.6 && < 0.9,
37+ http-api-data >= 0.2 && < 0.4,
38+ http-media >= 0.6 && < 0.7,
3639 jsaddle >= 0.8 && < 0.10,
3740 mtl >= 2.2.1 && < 2.3,
3841 network-uri >= 2.6 && < 2.7,
39− reflex >= 0.5 && < 0.9,
40− reflex-dom-core >= 0.6 && < 0.7,
42+ reflex >= 0.5 && < 0.6,
43+ reflex-dom == 0.4 && < 0.5,
4144 safe >= 0.3.9 && < 0.4,
42− servant >= 0.16 && < 0.18,
43− servant-auth >= 0.2.1 && < 0.4,
45+ servant >= 0.8 && < 0.11,
4446 string-conversions >= 0.4 && < 0.5,
4547 text >= 1.2 && < 1.3,
4648 transformers >= 0.4 && < 0.6
4749
48− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
50+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
4951
5052 default-language: Haskell2010
5153
@@ -54,16 +56,7 @@ executable example
5456 buildable: True
5557 else
5658 buildable: False
57− build-depends:
58− aeson,
59− reflex,
60− servant-reflex,
61− base,
62− scientific,
63− servant,
64− reflex-dom,
65− reflex-dom-core,
66− text
59+ build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text
6760 default-language: Haskell2010
6861 main-is: Example.hs
6962 other-modules: API
shell.nixdeleted−1
@@ -1 +0,0 @@
1−(import ./travis.nix {nativeCompiler = "ghc";}).ghcPkgs.servant-reflex.env
src/Servant/Common/BaseUrl.hs+6−5
@@ -28,7 +28,7 @@ import qualified Data.Text as T
2828import GHC.Generics
2929import Language.Javascript.JSaddle.Monad (MonadJSM)
3030import Reflex
31−import Reflex.Dom.Core
31+import Reflex.Dom
3232import Text.Read
3333
3434
@@ -85,14 +85,15 @@ baseUrlWidget = elClass "div" "base-url" $ do
8585 where pathWidget :: m (Dynamic t BaseUrl)
8686 pathWidget = do
8787 text "Url base path"
88− t <- inputElement def
88+ t <- textInput (def {_textInputConfig_attributes =
89+ constDyn ("placeholder" =: "/a/b")})
8990 return $ BasePath <$> value t
9091 fullUrlWidget :: m (Dynamic t BaseUrl)
9192 fullUrlWidget = do
9293 schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def
93− srv <- inputElement def
94+ srv <- textInput def {_textInputConfig_attributes = constDyn $ "placeholder" =: "example.com"}
9495 text ":"
95− prt <- inputElement def
96+ prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}
9697 port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))
97− path <- inputElement def
98+ path <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "a/b" }
9899 return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path
src/Servant/Common/Req.hs+106−110
@@ -4,22 +4,19 @@
44{-# LANGUAGE GADTs #-}
55{-# LANGUAGE OverloadedStrings #-}
66{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE RankNTypes #-}
87{-# LANGUAGE ScopedTypeVariables #-}
98{-# LANGUAGE TupleSections #-}
109
1110module Servant.Common.Req where
1211
1312-------------------------------------------------------------------------------
14−import Control.Applicative (liftA2, liftA3)
15−import Control.Arrow ((&&&))
1613import Control.Concurrent
14+import Control.Applicative (liftA2, liftA3)
1715import Control.Monad (join)
1816import Control.Monad.IO.Class (MonadIO, liftIO)
17+import Data.Aeson
1918import Data.Bifunctor (first)
20−import qualified Data.ByteString.Builder as Builder
2119import qualified Data.ByteString.Lazy.Char8 as BL
22−import Data.ByteString (ByteString)
2320import qualified Data.Map as Map
2421import Data.Maybe (catMaybes, fromMaybe)
2522import Data.Functor.Compose
@@ -29,9 +26,10 @@ import Data.Text (Text)
2926import qualified Data.Text as T
3027import qualified Data.Text.Encoding as TE
3128import Data.Traversable (forM)
32−import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
33−import qualified Network.URI as N
34−import Reflex.Dom.Core hiding (tag)
29+import Language.Javascript.JSaddle.Monad (JSM, MonadJSM)
30+import qualified Language.Javascript.JSaddle as JS
31+import Language.Javascript.JSaddle.Types (JSVal)
32+import Reflex.Dom hiding (tag)
3533import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
3634 SupportsServantReflex)
3735import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
@@ -52,23 +50,6 @@ data ReqResult tag a
5250 -- ^ A failure to construct the request tagged with 'tag' at trigger time
5351 deriving (Functor)
5452
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'
7253
7354------------------------------------------------------------------------------
7455-- | Simple filter/accessor for successful responses, when you want to
@@ -93,13 +74,6 @@ reqFailure (ResponseFailure _ s _) = Just s
9374reqFailure (RequestFailure _ s) = Just s
9475reqFailure _ = Nothing
9576
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−
10377
10478------------------------------------------------------------------------------
10579-- | Simple filter/accessor for the raw XHR response
@@ -167,7 +141,7 @@ reqToReflexRequest
167141 => Text
168142 -> Dynamic t BaseUrl
169143 -> Req t
170− -> Dynamic t (Either Text (XhrRequest XhrPayload))
144+ -> (Dynamic t (Either Text (XhrRequest XhrPayload)))
171145reqToReflexRequest reqMeth reqHost req =
172146 let t :: Dynamic t [Either Text Text]
173147 t = sequence $ reverse $ reqPathParts req
@@ -179,22 +153,18 @@ reqToReflexRequest reqMeth reqHost req =
179153 urlParts = fmap sequence t
180154
181155 urlPath :: Dynamic t (Either Text Text)
182− urlPath = (fmap.fmap)
183− (T.intercalate "/" . fmap escape)
184− urlParts
156+ urlPath = (fmap.fmap) (T.intercalate "/") urlParts
185157
186158 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
187159 queryPartString (pName, qp) = case qp of
188160 QueryPartParam p -> ffor p $ \case
189161 Left e -> Just (Left e)
190− Right (Just a) -> Just (Right $ pName <> "=" <> escape a)
162+ Right (Just a) -> Just (Right $ pName <> "=" <> a)
191163 Right Nothing -> Nothing
192164 QueryPartParams ps -> ffor ps $ \pStrings ->
193165 if null pStrings
194166 then Nothing
195− else Just . Right
196− . T.intercalate "&"
197− $ fmap (\p -> pName <> "=" <> escape p) pStrings
167+ else Just $ Right (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) pStrings))
198168 QueryPartFlag fl -> ffor fl $ \case
199169 True -> Just $ Right pName
200170 False -> Nothing
@@ -229,10 +199,10 @@ reqToReflexRequest reqMeth reqHost req =
229199 Right $ XhrRequestConfig
230200 { _xhrRequestConfig_sendData = bytesToPayload bBytes
231201 , _xhrRequestConfig_headers =
232− Map.insert "Content-Type" bCT (Map.fromList hs)
202+ Map.insert "Content-Type" bCT (Map.fromList hs)
233203 , _xhrRequestConfig_user = Nothing
234204 , _xhrRequestConfig_password = Nothing
235− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
205+ , _xhrRequestConfig_responseType = Nothing
236206 , _xhrRequestConfig_withCredentials = False
237207 , _xhrRequestConfig_responseHeaders = def
238208 }
@@ -244,8 +214,8 @@ reqToReflexRequest reqMeth reqHost req =
244214 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
245215 , _xhrRequestConfig_user = Nothing
246216 , _xhrRequestConfig_password = Nothing
247− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
248− , _xhrRequestConfig_sendData = mempty
217+ , _xhrRequestConfig_responseType = Nothing
218+ , _xhrRequestConfig_sendData = ""
249219 , _xhrRequestConfig_withCredentials = False
250220 }
251221 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
@@ -272,29 +242,21 @@ reqToReflexRequest reqMeth reqHost req =
272242displayHttpRequest :: Text -> Text
273243displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
274244
275−-- | This function performs the request
245+-- | This function actually performs the request.
276246performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
277247 => Text
278248 -> Dynamic t (f (Req t))
279249 -> Dynamic t BaseUrl
280− -> ClientOptions
281250 -> Event t tag
282251 -> m (Event t (tag, f (Either Text XhrResponse)))
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
252+performRequests reqMeth rs reqHost trigger = do
253+ -- let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))
254+ let xhrReqs = join $ (\(fxhr :: f (Req t)) -> sequence $ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
255+ let reqs = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
256+ resps <- performSomeRequestsAsync reqs
293257 return $ getCompose <$> resps
294258
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.
259+-- | 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.
298260performSomeRequestsAsync
299261 :: (MonadIO (Performable m),
300262 MonadJSM (Performable m),
@@ -302,25 +264,20 @@ performSomeRequestsAsync
302264 PerformEvent t m,
303265 TriggerEvent t m,
304266 Traversable f,
305− IsXhrPayload a,
306− Show a
307− )
308− => ClientOptions
309− -> Event t (f (Either Text (XhrRequest a)))
267+ IsXhrPayload a)
268+ => Event t (f (Either Text (XhrRequest a)))
310269 -> m (Event t (f (Either Text XhrResponse)))
311−performSomeRequestsAsync opts =
312− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
270+performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return
313271
314272
315273------------------------------------------------------------------------------
316274-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
317275-- that accepts 'f (Either e (XhrRequestb))' events
318276performSomeRequestsAsync'
319− :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
320− => ClientOptions
321− -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
277+ :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
278+ => (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
322279 -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
323−performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
280+performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
324281 rs <- hrs
325282 resps <- forM rs $ \r -> case r of
326283 Left e -> do
@@ -328,40 +285,98 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs
328285 return resp
329286 Right r' -> do
330287 resp <- liftIO newEmptyMVar
331− r'' <- liftJSM $ (optsRequestFixup opts) r'
332− _ <- newXhr r'' $ liftIO . putMVar resp . Right
288+ _ <- newXhr r' $ liftIO . putMVar resp . Right
333289 return resp
334290 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
335291 return ()
336292
337293
338294
339−type XhrPayload = ByteString
340−bytesToPayload :: BL.ByteString -> XhrPayload
341−bytesToPayload = BL.toStrict
295+-- | This function actually performs the request.
296+performRequest :: forall t m tag .(SupportsServantReflex t m)
297+ => Text
298+ -> (Req t)
299+ -> Dynamic t BaseUrl
300+ -> Event t tag
301+ -> m (Event t (tag, XhrResponse), Event t (tag, Text))
302+performRequest reqMeth req reqHost trigger = do
303+
304+ let xhrReq = reqToReflexRequest reqMeth reqHost req
305+ let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger
306+ okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) e) reqs
307+ badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) e) reqs
342308
309+ resps <- performRequestsAsync okReqs
310+
311+ return (resps, badReqs)
312+
313+
314+type XhrPayload = T.Text
315+bytesToPayload :: BL.ByteString -> XhrPayload
316+bytesToPayload = TE.decodeUtf8 . BL.toStrict
317+
318+
319+-- performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)
320+-- => Text
321+-- -> Req t
322+-- -> Dynamic t BaseUrl
323+-- -> Event t tag -> m (Event t (ReqResult tag NoContent))
324+-- performRequestNoBody reqMeth req reqHost trigger = do
325+-- (resp, badReq) <- performRequest reqMeth req reqHost trigger
326+-- let decodeResp = const $ Right NoContent
327+-- return $ leftmost [ fmap (evalResponse decodeResp) resp
328+-- , fmap (uncurry RequestFailure) badReq
329+-- ]
330+
331+
332+-- performRequestCT
333+-- :: (SupportsServantReflex t m,
334+-- MimeUnrender ct a)
335+-- => Proxy ct
336+-- -> Text
337+-- -> Req t
338+-- -> Dynamic t BaseUrl
339+-- -> Event t tag
340+-- -> m (Event t (ReqResult tag a))
341+-- performRequestCT ct reqMeth req reqHost trigger = do
342+-- (resp, badReq) <- performRequest reqMeth req reqHost trigger
343+-- let decodeResp x = first T.pack .
344+-- mimeUnrender ct .
345+-- BL.fromStrict .
346+-- TE.encodeUtf8 =<< note "No body text"
347+-- (_xhrResponse_responseText x)
348+
349+-- return $ leftmost [fmap (evalResponse decodeResp) resp
350+-- , fmap (uncurry RequestFailure) badReq
351+-- ]
343352
344353performRequestsCT
345− :: (SupportsServantReflex t m,
346− MimeUnrender ct a, Traversable f)
354+ :: ( SupportsServantReflex t m
355+ -- , MimeUnrender ct a
356+ , FromJSON a
357+ , Traversable f
358+ )
347359 => Proxy ct
348360 -> Text
349361 -> Dynamic t (f (Req t))
350362 -> Dynamic t BaseUrl
351− -> ClientOptions
352363 -> Event t tag
353364 -> m (Event t (f (ReqResult tag a)))
354−performRequestsCT ct reqMeth reqs reqHost opts trigger = do
355− resps <- performRequests reqMeth reqs reqHost opts trigger
356− let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
357− first T.pack .
358− mimeUnrender ct $
359− BL.fromStrict x
360− decodeResp _ = Left "No body"
365+performRequestsCT _ reqMeth reqs reqHost trigger = do
366+ resps <- performRequests reqMeth reqs reqHost trigger
367+ -- let decodeResp x = first T.pack .
368+ -- mimeUnrender ct .
369+ -- BL.fromStrict .
370+ -- TE.encodeUtf8 =<< note "No body text"
371+ let decodeResp x = first T.pack
372+ . note "Failed to decode"
373+ . jsonDecode
374+ . JS.textToJSString
375+ =<< note "No body text" (_xhrResponse_responseText x)
361376 return $ fmap
362377 (\(t,rs) -> ffor rs $ \r -> case r of
363378 Left e -> RequestFailure t e
364− Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
379+ Right g -> evalResponse decodeResp (t,g)
365380 )
366381 resps
367382
@@ -372,11 +387,10 @@ performRequestsNoBody
372387 => Text
373388 -> Dynamic t (f (Req t))
374389 -> Dynamic t BaseUrl
375− -> ClientOptions
376390 -> Event t tag
377391 -> m (Event t (f (ReqResult tag NoContent)))
378−performRequestsNoBody reqMeth reqs reqHost opts trigger = do
379− resps <- performRequests reqMeth reqs reqHost opts trigger
392+performRequestsNoBody reqMeth reqs reqHost trigger = do
393+ resps <- performRequests reqMeth reqs reqHost trigger
380394 let decodeResp = const $ Right NoContent
381395 return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
382396 Left e -> RequestFailure tag e
@@ -388,9 +402,8 @@ evalResponse
388402 :: (XhrResponse -> Either Text a)
389403 -> (tag, XhrResponse)
390404 -> ReqResult tag a
391−evalResponse decode (tag, xhr) =
392− let status = _xhrResponse_status xhr
393− okStatus = status >= 200 && status < 400
405+evalResponse decodeRes (tag, xhr) =
406+ let okStatus = _xhrResponse_status xhr < 400
394407 errMsg = fromMaybe
395408 ("Empty response with error code " <>
396409 T.pack (show $ _xhrResponse_status xhr))
@@ -399,21 +412,11 @@ evalResponse decode (tag, xhr) =
399412 then either
400413 (\e -> ResponseFailure tag e xhr)
401414 (\v -> ResponseSuccess tag v xhr)
402− (decode xhr)
415+ (decodeRes xhr)
403416 else ResponseFailure tag errMsg xhr
404417 in respPayld
405418
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
411419
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'
417420
418421
419422note :: e -> Maybe a -> Either e a
@@ -422,10 +425,3 @@ note e = maybe (Left e) Right
422425fmapL :: (e -> e') -> Either e a -> Either e' a
423426fmapL _ (Right a) = Right a
424427fmapL f (Left e) = Left (f e)
425−
426−builderToText :: Builder.Builder -> T.Text
427−builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
428−
429−escape :: T.Text -> T.Text
430−escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
431−
src/Servant/Reflex.hs+107−204
@@ -1,23 +1,24 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE InstanceSigs #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE Rank2Types #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TupleSections #-}
14−{-# LANGUAGE TypeFamilies #-}
15−{-# LANGUAGE TypeOperators #-}
16−{-# LANGUAGE UndecidableInstances #-}
17−
18−#if MIN_VERSION_base(4,9,0)
19−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
20−#endif
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE InstanceSigs #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+{-# LANGUAGE MultiParamTypeClasses #-}
15+{-# LANGUAGE OverloadedStrings #-}
16+{-# LANGUAGE PolyKinds #-}
17+{-# LANGUAGE ScopedTypeVariables #-}
18+{-# LANGUAGE TupleSections #-}
19+{-# LANGUAGE TypeFamilies #-}
20+{-# LANGUAGE TypeOperators #-}
21+{-# LANGUAGE UndecidableInstances #-}
2122
2223-- #include "overlapping-compat.h"
2324-- | This module provides 'client' which can automatically generate
@@ -25,57 +26,47 @@
2526-- API.
2627module Servant.Reflex
2728 ( client
28− , clientWithOpts
29− , clientWithOptsAndResultHandler
30− , clientWithRoute
31− , clientWithRouteAndResultHandler
3229 , BuildHeaderKeysTo(..)
3330 , toHeaders
34− , HasClient
35− , Client
31+ , HasClient(..)
3632 , module Servant.Common.Req
3733 , module Servant.Common.BaseUrl
3834 ) where
3935
4036------------------------------------------------------------------------------
37+import Data.Aeson
4138import Control.Applicative
42−import qualified Data.CaseInsensitive as CI
43−import Data.Functor.Identity
44−import qualified Data.Map as Map
4539import Data.Monoid ((<>))
46−import Data.Proxy (Proxy (..))
4740import qualified Data.Set as Set
41+import qualified Data.Text.Encoding as E
42+import Data.CaseInsensitive (mk)
43+import Data.Functor.Identity
44+import Data.Proxy (Proxy (..))
45+import qualified Data.Map as Map
4846import Data.Text (Text)
4947import qualified Data.Text as T
50−import qualified Data.Text.Encoding as E
51−import GHC.Exts (Constraint)
5248import GHC.TypeLits (KnownSymbol, symbolVal)
53−import Servant.API ((:<|>) (..), (:>), BasicAuth,
54− BasicAuthData, BuildHeadersTo (..),
55− Capture, Header, Headers (..),
56− HttpVersion, IsSecure,
57− MimeRender (..), MimeUnrender,
49+import Servant.API ((:<|>)(..),(:>), BasicAuth,
50+ BasicAuthData, BuildHeadersTo(..),
51+ Capture, contentType, Header,
52+ Headers(..), HttpVersion, IsSecure,
53+ MimeRender(..), MimeUnrender,
5854 NoContent, QueryFlag, QueryParam,
59− QueryParams, Raw, ReflectMethod (..),
55+ QueryParams, Raw, ReflectMethod(..),
6056 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)
57+ ToHttpApiData(..), Vault, Verb)
58+
59+import Reflex.Dom (Dynamic, Event, Reflex,
60+ XhrRequest(..),
61+ XhrResponseHeaders(..),
62+ XhrResponse(..), attachPromptlyDynWith, constDyn, ffor, fmapMaybe,
63+ leftmost, performRequestsAsync,
64+ )
7265------------------------------------------------------------------------------
7366import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
7467 showBaseUrl,
7568 SupportsServantReflex)
76−import Servant.Common.Req (ClientOptions(..),
77− defaultClientOptions,
78− Req, ReqResult(..), QParam(..),
69+import Servant.Common.Req (Req, ReqResult(..), QParam(..),
7970 QueryPart(..), addHeader, authData,
8071 defReq, evalResponse, prependToPathParts,
8172 -- performRequestCT,
@@ -85,10 +76,9 @@ import Servant.Common.Req (ClientOptions(..),
8576 performSomeRequestsAsync,
8677 qParamToQueryPart, reqBody,
8778 reqSuccess, reqFailure,
88− reqMethod, respHeaders,
89− response,
79+ reqMethod, respHeaders, response,
9080 reqTag,
91− qParams, withCredentials)
81+ qParams)
9282
9383
9484-- * Accessing APIs as a Client
@@ -103,75 +93,28 @@ import Servant.Common.Req (ClientOptions(..),
10393-- >
10494-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
10595-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
106−-- > -> m (Event t (l, ReqResult Book)))
96+-- -> m (Event t (l, ReqResult Book)))
10797-- > (getAllBooks :<|> postNewBook) = client myApi host
10898-- > where host = constDyn $ BaseUrl Http "localhost" 8080
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
99+client :: (HasClient t m layout tag)
100+ => Proxy layout -> Proxy m -> Proxy tag -> Dynamic t BaseUrl -> Client t m layout tag
101+client p q t baseurl = clientWithRoute p q t defReq baseurl
141102
142103
143104-- | This class lets us define how each API combinator
144105-- influences the creation of an HTTP request. It's mostly
145106-- an internal class, you can just use 'client'.
146−class Monad m => HasClient t m layout (tag :: *) where
107+class HasClient t m layout (tag :: *) where
147108 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
109+ clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> Client t m layout tag
167110
168111
169112instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
170113 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
171114
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
115+ clientWithRoute Proxy q pTag req baseurl =
116+ clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>
117+ clientWithRoute (Proxy :: Proxy b) q pTag req baseurl
175118
176119
177120-- Capture. Example:
@@ -186,29 +129,32 @@ instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b)
186129-- -> m (Event t (l, ReqResult Book))
187130-- > getBook = client myApi (constDyn host)
188131
189−instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout tag)
132+instance (SupportsServantReflex t m, FromJSON a, ToHttpApiData a, HasClient t m sublayout tag)
190133 => HasClient t m (Capture capture a :> sublayout) tag where
191134
192135 type Client t m (Capture capture a :> sublayout) tag =
193136 Dynamic t (Either Text a) -> Client t m sublayout tag
194137
195− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
196− clientWithRouteAndResultHandler
197− (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
138+ clientWithRoute Proxy q t req baseurl val =
139+ clientWithRoute (Proxy :: Proxy sublayout)
140+ q t
141+ (prependToPathParts p req)
142+ baseurl
198143 where p = (fmap . fmap) (toUrlPiece) val
199144
200145
201146-- VERB (Returning content) --
202147instance {-# OVERLAPPABLE #-}
203148 -- Note [Non-Empty Content Types]
204− (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
149+ (FromJSON a, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
205150 ) => HasClient t m (Verb method status cts' a) tag where
206151 type Client t m (Verb method status cts' a) tag =
207152 Event t tag -> m (Event t (ReqResult tag a))
208153 -- TODO how to access input types here?
209154 -- ExceptT ServantError IO a
210− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
211− wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
155+ clientWithRoute Proxy _ _ req baseurl trigs =
156+ -- performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs
157+ fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl trigs
212158 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
213159 req' = req { reqMethod = method }
214160
@@ -221,33 +167,29 @@ instance {-# OVERLAPPING #-}
221167 Event t tag -> m (Event t (ReqResult tag NoContent))
222168 -- TODO: how to access input types here?
223169 -- ExceptT ServantError IO NoContent
224− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
225− wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
170+ clientWithRoute Proxy _ _ req baseurl =
171+ (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl
226172 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
227173
228174
229175toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
230176toHeaders r =
231− let hdrs = maybe []
232− (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
177+ let toBS = E.encodeUtf8
178+ hdrs = maybe []
179+ (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
233180 (Map.toList $ _xhrResponse_headers xhr))
234181 (response r)
235182 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
236183
237−
238184class BuildHeaderKeysTo hs where
239− buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
185+ buildHeaderKeysTo :: Proxy hs -> [T.Text]
240186
241187instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
242188 where buildHeaderKeysTo _ = []
243189
244190instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
245191 => BuildHeaderKeysTo ((Header h v) ': xs) where
246− buildHeaderKeysTo _ =
247− let
248− thisKey = CI.mk $ T.pack (symbolVal (Proxy :: Proxy h))
249− in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)
250−
192+ buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
251193
252194-- HEADERS Verb (Content) --
253195-- Headers combinator not treated in fully general case,
@@ -257,15 +199,16 @@ instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
257199instance {-# OVERLAPPABLE #-}
258200 -- Note [Non-Empty Content Types]
259201 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
202+ FromJSON a,
260203 ReflectMethod method, cts' ~ (ct ': cts),
261204 SupportsServantReflex t m
262205 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
263206 type Client t m (Verb method status cts' (Headers ls a)) tag =
264207 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
265− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
208+ clientWithRoute Proxy _ _ req baseurl trigs = do
266209 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
267− resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
268− wrap $ toHeaders <$> resp
210+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl trigs
211+ return $ toHeaders <$> resp
269212 where req' = req { respHeaders =
270213 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
271214 }
@@ -278,10 +221,10 @@ instance {-# OVERLAPPABLE #-}
278221 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
279222 type Client t m (Verb method status cts (Headers ls NoContent)) tag
280223 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
281− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
224+ clientWithRoute Proxy _ _ req baseurl trigs = do
282225 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
283− resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
284− wrap $ toHeaders <$> resp
226+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl trigs
227+ return $ toHeaders <$> resp
285228 where req' = req {respHeaders =
286229 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
287230 }
@@ -308,11 +251,11 @@ instance (KnownSymbol sym, ToHttpApiData a,
308251 type Client t m (Header sym a :> sublayout) tag =
309252 Dynamic t (Either Text a) -> Client t m sublayout tag
310253
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
254+ clientWithRoute Proxy q t req baseurl eVal =
255+ clientWithRoute (Proxy :: Proxy sublayout)
256+ q t
257+ (Servant.Common.Req.addHeader hname eVal req)
258+ baseurl
316259 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
317260
318261
@@ -326,21 +269,8 @@ instance HasClient t m sublayout tag
326269 type Client t m (HttpVersion :> sublayout) tag =
327270 Client t m sublayout tag
328271
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−
272+ clientWithRoute Proxy q t =
273+ clientWithRoute (Proxy :: Proxy sublayout) q t
344274
345275
346276-- | If you use a 'QueryParam' in one of your endpoints in your API,
@@ -376,9 +306,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
376306 Dynamic t (QParam a) -> Client t m sublayout tag
377307
378308 -- if mparam = Nothing, we don't add it to the query string
379− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
380− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
381− (req {qParams = paramPair : qParams req}) baseurl opts wrap
309+ clientWithRoute Proxy q t req baseurl mparam =
310+ clientWithRoute (Proxy :: Proxy sublayout) q t
311+ (req {qParams = paramPair : qParams req}) baseurl
382312
383313 where pname = symbolVal (Proxy :: Proxy sym)
384314 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -422,8 +352,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
422352 type Client t m (QueryParams sym a :> sublayout) tag =
423353 Dynamic t [a] -> Client t m sublayout tag
424354
425− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
426− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
355+ clientWithRoute Proxy q t req baseurl paramlist =
356+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
427357
428358 where req' = req { qParams = (T.pack pname, params') : qParams req }
429359 pname = symbolVal (Proxy :: Proxy sym)
@@ -462,8 +392,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
462392 type Client t m (QueryFlag sym :> sublayout) tag =
463393 Dynamic t Bool -> Client t m sublayout tag
464394
465− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
466− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
395+ clientWithRoute Proxy q t req baseurl flag =
396+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
467397
468398 where req' = req { qParams = thisPair : qParams req }
469399 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -477,7 +407,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
477407 -> Event t tag
478408 -> m (Event t (ReqResult tag ()))
479409
480− clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
410+ clientWithRoute _ _ _ _ baseurl xhrs triggers = do
481411
482412 let xhrs' = liftA2 (\x path -> case x of
483413 Left e -> Left e
@@ -488,7 +418,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
488418 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
489419
490420 resps <- performRequestsAsync okReq
491− wrap $ leftmost [ uncurry RequestFailure <$> badReq
421+ return $ leftmost [ uncurry RequestFailure <$> badReq
492422 , evalResponse (const $ Right ()) <$> resps
493423 ]
494424
@@ -519,8 +449,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
519449 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
520450 Dynamic t (Either Text a) -> Client t m sublayout tag
521451
522− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
523− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
452+ clientWithRoute Proxy q t req baseurl body =
453+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
524454 where req' = req { reqBody = bodyBytesCT }
525455 ctProxy = Proxy :: Proxy ct
526456 ctString = T.pack $ show $ contentType ctProxy
@@ -534,9 +464,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
534464instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
535465 type Client t m (path :> sublayout) tag = Client t m sublayout tag
536466
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
467+ clientWithRoute Proxy q t req baseurl =
468+ clientWithRoute (Proxy :: Proxy sublayout) q t
469+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl
540470
541471 where p = symbolVal (Proxy :: Proxy path)
542472
@@ -544,23 +474,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient
544474instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
545475 type Client t m (Vault :> api) tag = Client t m api tag
546476
547− clientWithRouteAndResultHandler Proxy =
548− clientWithRouteAndResultHandler (Proxy :: Proxy api)
477+ clientWithRoute Proxy q t req baseurl =
478+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
549479
550480
551481instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
552482 type Client t m (RemoteHost :> api) tag = Client t m api tag
553483
554− clientWithRouteAndResultHandler Proxy =
555− clientWithRouteAndResultHandler (Proxy :: Proxy api)
484+ clientWithRoute Proxy q t req baseurl =
485+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
556486
557487
558488
559489instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
560490 type Client t m (IsSecure :> api) tag = Client t m api tag
561491
562− clientWithRouteAndResultHandler Proxy =
563− clientWithRouteAndResultHandler (Proxy :: Proxy api)
492+ clientWithRoute Proxy q t req baseurl =
493+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
564494
565495
566496instance (HasClient t m api tag, Reflex t)
@@ -569,8 +499,8 @@ instance (HasClient t m api tag, Reflex t)
569499 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
570500 -> Client t m api tag
571501
572− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
573− clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
502+ clientWithRoute Proxy q t req baseurl authdata =
503+ clientWithRoute (Proxy :: Proxy api) q t req' baseurl
574504 where
575505 req' = req { authData = Just authdata }
576506
@@ -596,30 +526,3 @@ non-empty lists, but is otherwise more specific, no instance will be overall
596526more specific. This in turn generally means adding yet another instance (one
597527for empty and one for non-empty lists).
598528-}
599−
600−
601−-- SUPPORT FOR servant-auth --
602−
603−-- For JavaScript clients we should be sending/storing JSON web tokens in a
604−-- way that is inaccessible to JavaScript.
605−--
606−-- For @servant-auth@ this is done with HTTP-only cookies. In a Reflex-DOM
607−-- app this means the @servant-auth@ client should only verify that the API
608−-- supports Cookie-based authentication but do nothing with the token
609−-- directly.
610−
611−-- @HasCookieAuth auths@ is nominally a redundant constraint, but ensures
612−-- we're not trying to rely on cookies when the API does not use them.
613−instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where
614−
615− type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag
616− clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)
617−
618−
619−type family HasCookieAuth xs :: Constraint where
620− HasCookieAuth (Auth.Cookie ': xs) = ()
621− HasCookieAuth (x ': xs) = HasCookieAuth xs
622− HasCookieAuth '[] = CookieAuthNotEnabled
623−
624−class CookieAuthNotEnabled
625−
src/Servant/Reflex/Multi.hs+56−82
@@ -16,15 +16,12 @@
1616module Servant.Reflex.Multi (
1717 -- * Compute servant client functions
1818 clientA
19− , clientWithOptsA
2019 , BaseUrl(..)
2120 , Scheme(..)
2221
2322 -- * Build QueryParam arguments
2423 , QParam(..)
2524
26− -- * Access response data
27− , withCredentials
2825
2926 -- * Access response data
3027 , ReqResult(..)
@@ -37,45 +34,41 @@ module Servant.Reflex.Multi (
3734 ) where
3835
3936------------------------------------------------------------------------------
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)
37+import Data.Aeson
38+import Control.Applicative (liftA2)
39+import Data.Functor.Compose (Compose (..), getCompose)
40+import Data.Proxy (Proxy (..))
41+import qualified Data.Set as Set
42+import Data.Text (Text)
43+import qualified Data.Text as T
44+import qualified Data.Text.Encoding as E
45+import GHC.TypeLits (KnownSymbol, symbolVal)
46+import Servant.API ((:<|>) (..), (:>), BasicAuth,
47+ BasicAuthData, BuildHeadersTo (..),
48+ Capture, Header, Headers (..),
49+ HttpVersion, IsSecure, MimeRender (..),
50+ MimeUnrender, NoContent, QueryFlag,
51+ QueryParam, QueryParams, Raw,
52+ ReflectMethod (..), RemoteHost,
53+ ReqBody, ToHttpApiData (..), Vault,
54+ Verb, contentType)
55+
56+import Reflex.Dom (Dynamic, Event, Reflex,
57+ XhrRequest (..),
58+ XhrResponseHeaders (..),
59+ attachPromptlyDynWith, constDyn)
6460------------------------------------------------------------------------------
6561import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
6662 SupportsServantReflex)
67−import Servant.Common.Req (ClientOptions,
68− QParam (..), QueryPart (..), Req,
63+import Servant.Common.Req (QParam (..), QueryPart (..), Req,
6964 ReqResult (..), addHeader, authData,
70− defReq,
71− defaultClientOptions,
72− performRequestsCT,
65+ defReq, performRequestsCT,
7366 performRequestsNoBody,
7467 performSomeRequestsAsync,
7568 prependToPathParts, qParamToQueryPart,
7669 qParams, reqBody, reqFailure,
7770 reqMethod, reqSuccess, reqSuccess',
78− respHeaders, response, withCredentials)
71+ respHeaders, response)
7972import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
8073
8174
@@ -85,24 +78,14 @@ clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
8578 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
8679clientA p q f tag baseurl =
8780 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
88− defaultClientOptions
89−
9081
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
9982
10083------------------------------------------------------------------------------
10184class HasClientMulti t m layout f (tag :: *) where
10285 type ClientMulti t m layout f tag :: *
10386 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
10487 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
105− -> ClientOptions -> ClientMulti t m layout f tag
88+ -> ClientMulti t m layout f tag
10689
10790
10891------------------------------------------------------------------------------
@@ -110,9 +93,9 @@ instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>
11093 HasClientMulti t m (a :<|> b) f tag where
11194 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>
11295 ClientMulti t m b f tag
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
96+ clientWithRouteMulti Proxy q f tag reqs baseurl =
97+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl :<|>
98+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl
11699
117100
118101------------------------------------------------------------------------------
@@ -125,8 +108,8 @@ instance (SupportsServantReflex t m,
125108 type ClientMulti t m (Capture capture a :> sublayout) f tag =
126109 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
127110
128− clientWithRouteMulti _ q f tag reqs baseurl opts vals =
129− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
111+ clientWithRouteMulti _ q f tag reqs baseurl vals =
112+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
130113 where
131114 reqs' = (prependToPathParts <$> ps <*>) <$> reqs
132115 ps = (fmap . fmap . fmap) toUrlPiece vals
@@ -137,6 +120,7 @@ instance (SupportsServantReflex t m,
137120instance {-# OVERLAPPABLE #-}
138121 -- Note [Non-Empty Content Types]
139122 (MimeUnrender ct a,
123+ FromJSON a,
140124 ReflectMethod method, cts' ~ (ct ': cts),
141125 SupportsServantReflex t m,
142126 Applicative f,
@@ -146,8 +130,8 @@ instance {-# OVERLAPPABLE #-}
146130 type ClientMulti t m (Verb method status cts' a) f tag =
147131 Event t tag -> m (Event t (f (ReqResult tag a)))
148132
149− clientWithRouteMulti _ _ _ _ reqs baseurl opts =
150− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts
133+ clientWithRouteMulti _ _ _ _ reqs baseurl =
134+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
151135 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
152136 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
153137
@@ -161,8 +145,8 @@ instance {-# OVERLAPPING #-}
161145 Event t tag -> m (Event t (f (ReqResult tag NoContent)))
162146 -- TODO: how to access input types here?
163147 -- ExceptT ServantError IO NoContent
164− clientWithRouteMulti Proxy _ _ _ req baseurl opts =
165− performRequestsNoBody method req baseurl opts
148+ clientWithRouteMulti Proxy _ _ _ req baseurl =
149+ performRequestsNoBody method req baseurl
166150 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
167151
168152
@@ -170,15 +154,16 @@ instance {-# OVERLAPPING #-}
170154instance {-# OVERLAPPABLE #-}
171155 -- Note [Non-Empty Content Types]
172156 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
157+ FromJSON a,
173158 ReflectMethod method, cts' ~ (ct ': cts),
174159 SupportsServantReflex t m,
175160 Traversable f
176161 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where
177162 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =
178163 Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))
179− clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
164+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
180165 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
181− resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))
166+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl triggers :: m (Event t (f (ReqResult tag a)))
182167 return $ fmap toHeaders <$> resp
183168 where
184169 reqs' = fmap (\r ->
@@ -199,9 +184,9 @@ instance {-# OVERLAPPABLE #-}
199184 cts (Headers ls NoContent)) f tag where
200185 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag
201186 = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))
202− clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
187+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
203188 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
204− resp <- performRequestsNoBody method reqs' baseurl opts triggers
189+ resp <- performRequestsNoBody method reqs' baseurl triggers
205190 return $ fmap toHeaders <$> resp
206191 where reqs' = fmap (\req ->
207192 req {respHeaders = OnlyHeaders (Set.fromList
@@ -221,11 +206,11 @@ instance (KnownSymbol sym,
221206 type ClientMulti t m (Header sym a :> sublayout) f tag =
222207 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
223208
224− clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =
209+ clientWithRouteMulti Proxy f q tag reqs baseurl eVals =
225210 clientWithRouteMulti (Proxy :: Proxy sublayout) f
226211 q tag
227212 reqs'
228− baseurl opts
213+ baseurl
229214 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
230215 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
231216 <$> eVals <*>) <$> reqs
@@ -242,17 +227,6 @@ instance HasClientMulti t m sublayout f tag
242227 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
243228
244229
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−
256230------------------------------------------------------------------------------
257231instance (KnownSymbol sym,
258232 ToHttpApiData a,
@@ -266,9 +240,9 @@ instance (KnownSymbol sym,
266240
267241 -- if mparam = Nothing, we don't add it to the query string
268242 -- TODO: Check the above comment
269− clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =
243+ clientWithRouteMulti Proxy q f tag reqs baseurl mparams =
270244 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
271− reqs' baseurl opts
245+ reqs' baseurl
272246
273247 where pname = symbolVal (Proxy :: Proxy sym)
274248 p prm = QueryPartParam $ fmap qParamToQueryPart prm
@@ -289,8 +263,8 @@ instance (KnownSymbol sym,
289263 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
290264 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
291265
292− clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =
293− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
266+ clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =
267+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
294268
295269 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }
296270 pname = symbolVal (Proxy :: Proxy sym)
@@ -308,8 +282,8 @@ instance (KnownSymbol sym,
308282 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
309283 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
310284
311− clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =
312− clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts
285+ clientWithRouteMulti Proxy q f' tag reqs baseurl flags =
286+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl
313287
314288 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
315289 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
@@ -323,10 +297,10 @@ instance (SupportsServantReflex t m,
323297 -> Event t tag
324298 -> m (Event t (f (ReqResult tag ())))
325299
326− clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do
300+ clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do
327301 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
328302 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
329− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''
303+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync rawReqs''
330304 return resps
331305 where
332306 aux (tag, Right r) = ResponseSuccess tag () r
@@ -342,8 +316,8 @@ instance (MimeRender ct a,
342316 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
343317 Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
344318
345− clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
346− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
319+ clientWithRouteMulti Proxy q f tag reqs baseurl bodies =
320+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
347321 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
348322 ctProxy = Proxy :: Proxy ct
349323 ctString = T.pack $ show $ contentType ctProxy
@@ -394,8 +368,8 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
394368 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))
395369 -> ClientMulti t m api f tag
396370
397− clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =
398− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts
371+ clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =
372+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl
399373 where
400374 req' a r = r { authData = Just (constDyn a) }
401375 reqs' = liftA2 req' <$> authdatas <*> reqs
testdriver/test/Servant/ReflexSpec.hs+1−2
@@ -9,7 +9,6 @@ import qualified Data.Text as T
99import Data.Foldable
1010import Test.WebDriver.Commands.Wait
1111import Test.Hspec.WebDriver
12−import Test.Hspec.WebDriver (chromeCaps)
1312
1413
1514clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()
@@ -29,7 +28,7 @@ spec :: Spec
2928spec = do
3029 describe "servant-reflex tests" $ do
3130
32− session "test page" $ using [chromeCaps] $ do
31+ session "test page" $ using Chrome $ do
3332
3433 it "opens the page" $ runWD $
3534 openPage "http://localhost:8000"
testserver/API.hsmode 100644 → 120000+1−69
@@ -1,69 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TypeOperators #-}
4−
5−module API where
6−
7−import Data.Aeson
8−import Data.Aeson.Types (typeMismatch)
9−import Data.Text (Text)
10−import Servant.API
11−
12−newtype Question = Question { unQuestion :: Text } deriving (Show)
13−
14−instance ToJSON Question where
15− toJSON (Question txt) = object ["question" .= txt]
16−
17−instance FromJSON Question where
18− parseJSON (Object v) = Question <$> v .: "question"
19− parseJSON x = typeMismatch "Couldn't find key 'question'" x
20−
21−newtype Answer = Answer { unAnswer :: Text } deriving (Show)
22−
23−instance ToJSON Answer where
24− toJSON (Answer txt) = object ["answer" .= txt]
25−
26−instance FromJSON Answer where
27− parseJSON (Object v) = Answer <$> v .: "answer"
28− parseJSON x = typeMismatch "Couldn't find key 'answer'" x
29−
30−
31−-- | API spec for server, client, and docs
32−type API = "getunit" :> Get '[JSON] ()
33− :<|> "getint" :> Get '[JSON] Int
34− :<|> "sayhi" :> QueryParam "username" Text
35− :> QueryParams "greetings" Text
36− :> QueryFlag "gusto"
37− :> Get '[JSON] Text
38− :<|> "double" :> ReqBody '[JSON] Double
39− :> Post '[JSON] Double
40− :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
41− :<|> "qna" :> ReqBody '[JSON] Question
42− :> Post '[JSON] Answer
43− :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
44− :<|> Raw
45−
46−type GET = Get '[JSON] ()
47−
48−-- Imported the comprehensive API example for testing.
49−-- https://github.com/haskell-servant/servant/blob/master/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs
50−type ComprehensiveAPI =
51− GET :<|>
52− Get '[JSON] Int :<|>
53− Capture "foo" Int :> GET :<|>
54− Header "foo" Int :> GET :<|>
55− HttpVersion :> GET :<|>
56− IsSecure :> GET :<|>
57− QueryParam "foo" Int :> GET :<|>
58− QueryParams "foo" Int :> GET :<|>
59− QueryFlag "foo" :> GET :<|>
60−-- Raw :<|>
61− RemoteHost :> GET :<|>
62− ReqBody '[JSON] Int :> GET :<|>
63− Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>
64− "foo" :> GET :<|>
65− Vault :> GET :<|>
66− Verb 'POST 204 '[JSON] () :<|>
67− Verb 'POST 204 '[JSON] Int
68−-- This one isn't in scope
69−-- :<|> WithNamedContext "foo" '[] GET
@@ -0,0 +1 @@
1+../exec/API.hs
testserver/Main.hs+5−20
@@ -2,17 +2,14 @@
22{-# LANGUAGE DeriveGeneric #-}
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE TypeApplications #-}
65{-# LANGUAGE TypeFamilies #-}
76{-# LANGUAGE TypeOperators #-}
87
98import Control.Monad.IO.Class (liftIO)
10−import Control.Monad.Reader (reader)
119import Data.Aeson
1210import Data.Bool
1311import Data.Char (toUpper)
1412import qualified Data.List as L
15−import Data.Maybe (fromMaybe)
1613import Data.Monoid
1714import Data.Proxy
1815import Data.Text hiding (head, length, map,
@@ -27,7 +24,6 @@ import Snap.Http.Server
2724import Servant
2825import Servant.Server
2926-- import Snap.Util.FileServe
30−import System.Environment (lookupEnv)
3127import API
3228import Snap
3329
@@ -43,7 +39,7 @@ instance ToJSON Greet
4339testApi :: Proxy API
4440testApi = Proxy
4541
46−data App = App { appStaticDir :: String }
42+data App = App
4743
4844-- Server-side handlers.
4945--
@@ -51,10 +47,8 @@ data App = App { appStaticDir :: String }
5147-- that represents the API, are glued together using :<|>.
5248--
5349-- Each handler runs in the 'ExceptT ServantErr IO' monad.
54−server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
55−server = return () :<|> return 100 :<|> sayhi :<|> dbl
56− :<|> multi :<|> qna :<|> serveSecret
57− :<|> statics
50+server :: Server API (Handler App App)
51+server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> serveDirectory "static"
5852 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
5953 sayhi nm greetings withGusto = case nm of
6054 Nothing -> return ("Sorry, who are you?" :: Text)
@@ -75,27 +69,18 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl
7569 putStrLn $ "qna got: " ++ show q
7670 T.putStrLn $ unQuestion q
7771 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
8572
8673-- Turn the server into a WAI app. 'serve' is provided by servant,
8774-- more precisely by the Servant.Server module.
8875test :: Handler App App ()
89−test = serveSnapWithContext testApi
90− (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server
76+test = serveSnap testApi server
9177
9278initApp :: SnapletInit App App
9379initApp = makeSnaplet "myapp" "example" Nothing $ do
94− staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")
9580 addRoutes [("", test)
9681 ,("", serveDirectory "static")
9782 ]
98− return (App staticDir)
83+ return App
9984
10085-- Put this all to work!
10186main :: IO ()
testserver/run-wd-tests.shnew file+5
@@ -0,0 +1,5 @@
1+#!/usr/bin/env bash
2+
3+dist/build/back/back -p 8000 &
4+phantomjs --webdriver=127.0.0.1:4444 &
5+dist/build/spec/spec
testserver/testserver.cabal+7−8
@@ -19,14 +19,13 @@ executable back
1919 main-is: Main.hs
2020 -- other-modules:
2121 -- other-extensions:
22− build-depends: aeson >= 0.9 && < 1.5
23− , base >=4.8 && < 5
24− , mtl
25− , snap >= 1.0 && < 1.2
26− , snap-server >= 1.0 && < 1.2
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
2726 , snap-core >= 1.0 && < 1.1
28− , servant >= 0.16 && < 0.18
29− , servant-snap >= 0.8 && < 0.9
30− , text >= 1.0 && < 1.3
27+ , servant >= 0.8 && < 0.11
28+ , servant-snap >= 0.7.2 && < 0.8
29+ , text >= 1.2 && < 1.3
3130 -- hs-source-dirs:
3231 default-language: Haskell2010
testserver/tr.nixnew file+32
@@ -0,0 +1,32 @@
1+{ reflex-platform, ... }:
2+let
3+
4+ dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;
5+ cabal2nixResult = reflex-platform.cabal2nixResult;
6+ nixpkgs = (import <nixpkgs> {});
7+in
8+reflex-platform.ghc.override {
9+ overrides = self: super: {
10+ servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});
11+ snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap) {});
12+ io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});
13+ io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});
14+ heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});
15+ xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});
16+ snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});
17+ snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});
18+ snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});
19+ snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});
20+ hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});
21+
22+ # servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});
23+ # servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});
24+ # servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});
25+ # servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});
26+ # servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});
27+ # servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});
28+ # servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});
29+ # servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});
30+
31+ };
32+}
travis.nixdeleted−70
@@ -1,70 +0,0 @@
1−{
2− nativeCompiler ? "ghc",
3− # ^ Choose a GHC for compiling backend components (web server, selenium)
4− # (ghc, ghc8_0, ghc8_2, ghc8_4 or ghcHEAD)
5−
6− jsCompiler ? "ghcjs"
7− # ^ Choose a GHCJS for compiling the frontend
8− # (ghcjs, ghcjs8_0, ghcjs8_2 or ghcjs8_4)
9−
10−}:
11−
12−let
13−
14− reflexPlatform = import ./nix/reflex-platform.nix;
15−
16− lib = reflexPlatform.nixpkgs.haskell.lib;
17− do = funs: pkg: builtins.foldl' (a: b: b a) pkg funs;
18−
19− ghcjsPkgs = with lib; reflexPlatform.${jsCompiler}.override {
20− overrides = self: super: {
21− http-media = dontCheck super.http-media;
22− servant = dontCheck super.servant;
23− lens-aeson = dontCheck super.lens-aeson;
24− servant-reflex = lib.appendConfigureFlag
25− (self.callPackage ./default.nix {}) "-fExample";
26− };
27− };
28−
29− ghcPkgs = with lib; reflexPlatform.${nativeCompiler}.override {
30− overrides = self: super: {
31− servant-snap = dontCheck ((import ./nix/servant-snap.nix {}) self super);
32− testdriver = self.callCabal2nix "testdriver" ./testdriver {};
33− testserver = import nix/testserver.nix ghcjsPkgs.servant-reflex self super;
34− servant-reflex = self.callPackage ./default.nix {};
35− };
36− };
37−
38− testresults = import ./nix/testresults.nix
39− { inherit reflexPlatform;
40− inherit (ghcPkgs) testserver testdriver;
41− inherit (reflexPlatform.nixpkgs) curl;
42− phantomjs = reflexPlatform.nixpkgs.phantomjs2;
43− };
44−
45−in
46− rec {
47−
48− inherit reflexPlatform ghcPkgs ghcjsPkgs;
49−
50− build = ghcjsPkgs.servant-reflex;
51− buildGhc = ghcPkgs.servant-reflex;
52− testserver = ghcPkgs.testserver;
53− testdriver = ghcPkgs.testdriver;
54− inherit testresults;
55−
56− cabalBuild = reflexPlatform.${jsCompiler}.shellFor {
57− name = "servant-reflex-cabal-builder";
58−
59− packages = p: [
60− build
61− ];
62−
63− shellHook = ''
64− cabal configure --ghcjs -f Example
65− cabal build
66− exec/toSite.sh
67− exit $?
68− '';
69− };
70− }