git.iko.soy/servant-reflex
on cab484b help sign in
f76dbeb
swap
0 ahead, 68 behind
.gitignore−2
since splitsnapshots
unifiedsplit
@@ -7,5 +7,3 @@ log
7*.stats
7*.stats
8out
8out
9/.stack-work/
9/.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
1+sudo: required
2−nix: 2.3.6
2+
3−sudo: require
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+
4
21
5before_install:
22before_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
7
26
8−before_script:
27+install:
9− - sudo systemctl restart nix-daemon.service
28+ - cabal --version
10− - git config --global user.email "travis-ci@example.com"
29+ - BENCH=${BENCH---enable-benchmarks}
11− - git config --global user.name "Travis-CI"
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
12
45
13script:
46script:
14− - nix-build travis.nix -A build
47+ - git config --global user.email "travis-ci@example.com"
15− - nix-build travis.nix -A buildGhc
48+ - git config --global user.name "Travis-CI"
16− - nix-build travis.nix -A testserver
49+ - ./build.sh
17− - nix-build travis.nix -A testresults
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 @@
4
4
5## `servant-reflex` lets you share your `servant` APIs with the frontend
5## `servant-reflex` lets you share your `servant` APIs with the frontend
6
6
7−Keeping your frontend in sync with your API server can be difficult - when the
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−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
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.
13−requests by hand, API endpoints are available behind `reflex`'s FRP semantics.
9+
14
10
15
11
16## Example
12## Example
17
13
18−We have a webservice API defined in a module where both the server (compiled
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:
19−with ghc) and the frontend (compiled with ghcjs) can see it:
20
15
21```haskell
16```haskell
22type API = "getint" :> Get '[JSON] Int
17type API = "getint" :> Get '[JSON] Int
@@ -29,8 +24,7 @@ type API = "getint" :> Get '[JSON] Int
29 :<|> Raw
24 :<|> Raw
30```
25```
31
26
32−`servant-reflex` then computes client functions that can query the API through
27+`servant-reflex` then computes client functions that can query the API through an `XhrRequest`.
33−an `XhrRequest`.
34
28
35```haskell
29```haskell
36
30
@@ -43,16 +37,7 @@ an `XhrRequest`.
43 (constDyn (BasePath "/"))
37 (constDyn (BasePath "/"))
44```
38```
45
39
46−These client functions are computed from your API type. They manage
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.
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.
56
41
57```haskell
42```haskell
58 -- No need to write these functions. servant-reflex creates them for you!
43 -- 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
77 -> m (Event t (ReqResult () Double))
62 -> m (Event t (ReqResult () Double))
78```
63```
79
64
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)
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:
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:
87
66
88```haskell
67```haskell
89 -- ... continued ...
68 -- ... continued ...
@@ -101,8 +80,7 @@ elimination functions to filter the result type you care about, like this:
101 dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])
80 dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])
102```
81```
103
82
104−This example builds some input fields to enter API parameters, buttons to
83+This example builds some input fields to enter API parameters, buttons to trigger the API calls, and text elements to show the results:
105−trigger the API calls, and text elements to show the results:
106
84
107```haskell
85```haskell
108 elClass "div" "int-demo" $ do
86 elClass "div" "int-demo" $ do
@@ -125,53 +103,47 @@ trigger the API calls, and text elements to show the results:
125 display =<< holdDyn Nothing outputDouble
103 display =<< holdDyn Nothing outputDouble
126```
104```
127
105
128−For a great introduction to recative DOM building, see the
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.
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.
133
107
134
108
135## Building the library and test server
109## Building the library and test server
136
110
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).
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:
142−To build these components, we will use the nix packages for the testserver. It
112+
143−manages the frontend build as a dependency.
113+
114+First build the library:
144
115
145```
116```
146−nix build -f travis.nix testserver -o server
117+git submodule update --init --recursive
118+./build.sh
147```
119```
148
120
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:
150
131
151```
132```
152−STATIC_DIR=server/static server/back -p 8000
133+cd testserver
134+dist/build/back/back -p 8001
153```
135```
154
136
155−Browse to [http://localhost:8000](http://localhost:8000) and click around.
137+And simply browse to `localhost:8001`
156−Open the firefox or chrome developer tools and examine the XHR activity
157−under the Network tab.
158
138
159−**For a larger example of a project that shares types between backend and
139+**For a larger example of a project that shares types between backend and frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
160−frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
161
140
162
141
163## Tagging requests
142## Tagging requests
164
143
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
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.
167−times and aren't automatically paired up, but you can recover the
168−relationship by tagging the requests.
169
145
170−So far we have used an `Event t ()` to trigger sending a request. If we choose
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:
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:
175
147
176```haskell
148```haskell
177 ...
149 ...
@@ -201,10 +173,7 @@ its request. Imagine we wanted to display not just the last "double" from
201
173
202## Simultaneous requests
174## Simultaneous requests
203
175
204−`Servant.Reflex.Multi` provides an alternative client-generation function
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:
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:
208
177
209```haskell
178```haskell
210sayHi
179sayHi
@@ -215,10 +184,4 @@ sayHi
215 -> m (Event t (f (ReqResult tag Text)))
184 -> m (Event t (f (ReqResult tag Text)))
216```
185```
217
186
218−The dynamic params are each wrapped in `f`. For every firing of the trigger
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.
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.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−
290.3
10.3
30---
2---
31
3
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] ()
40 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
40 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
41 :<|> "qna" :> ReqBody '[JSON] Question
41 :<|> "qna" :> ReqBody '[JSON] Question
42 :> Post '[JSON] Answer
42 :> Post '[JSON] Answer
43− :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
44 :<|> Raw
43 :<|> Raw
45
44
46type GET = Get '[JSON] ()
45type GET = Get '[JSON] ()
exec/Example.hs+6−27
@@ -1,4 +1,3 @@
1−{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
4{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
@@ -15,14 +14,12 @@ import Control.Monad.Fix (MonadFix)
15import Data.Monoid (First(..), (<>))
14import Data.Monoid (First(..), (<>))
16import Data.Text (Text)
15import Data.Text (Text)
17import qualified Data.Text as T
16import qualified Data.Text as T
18−import qualified Data.Text.Encoding as T
19import GHC.TypeLits
17import GHC.TypeLits
20import Servant.API
18import Servant.API
21import API
19import API
22import Data.Proxy
20import Data.Proxy
23import Text.Read (readMaybe)
21import Text.Read (readMaybe)
24−import Reflex.Dom.Core hiding (run, mainWidget)
22+import Reflex.Dom hiding (run)
25−import Reflex.Dom (mainWidget)
26------------------------------------------------------------------------------
23------------------------------------------------------------------------------
27import Servant.Reflex
24import Servant.Reflex
28import Servant.Reflex.Multi
25import Servant.Reflex.Multi
@@ -46,7 +43,7 @@ runMulti :: forall t m. (SupportsServantReflex t m,
46runMulti = do
43runMulti = do
47 url <- baseUrlWidget
44 url <- baseUrlWidget
48 el "br" blank
45 el "br" blank
49− let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =
46+ let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ ) =
50 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
47 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
51
48
52 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
49 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
@@ -69,12 +66,9 @@ runMulti = do
69 textInput def
66 textInput def
70 gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
67 gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
71 b <- button "Go"
68 b <- button "Go"
72− r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)
69+ r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts) (constDyn [True, False]) (1 <$ b)
73− (constDyn [True, False]) (1 <$ b)
74−
75− dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .
76− fmap reqSuccess <$> r')
77
70
71+ dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes . fmap reqSuccess <$> r')
78
72
79 return ()
73 return ()
80
74
@@ -97,11 +91,8 @@ run = mdo
97 el "br" (return ())
91 el "br" (return ())
98
92
99 -- Name the computed API client functions
93 -- Name the computed API client functions
100− let tweakRequest = ClientOptions $ \r -> do
101− return $ r & withCredentials .~ True
102− let (getUnit :<|> getInt :<|> sayhi :<|> dbl
94+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> doRaw) =
103− :<|> multi :<|> qna :<|> secret :<|> doRaw) =
104− clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest
95+ client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url
105
96
106 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
97 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
107
98
@@ -186,18 +177,6 @@ run = mdo
186 el "p" $
177 el "p" $
187 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
178 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
188
179
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−
201showXhrResponse :: XhrResponse -> Text
180showXhrResponse :: XhrResponse -> Text
202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
181showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
203 T.unlines ["stat: " <> tShow stat
182 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 @@
1Name: servant-reflex
1Name: servant-reflex
2−Version: 0.3.6
2+Version: 0.3.1
3−Synopsis: servant API generator for reflex apps
3+Synopsis: Servant reflex API generator
4−Description: Generate reflex-compatible client functions from servant API descriptions
4+Description: Servant reflex API generator
5−License: BSD3
5+License: AllRightsReserved
6License-file: LICENSE.md
6License-file: LICENSE.md
7Author: Greg Hale, Doug Beardsley
7Author: Greg Hale, Doug Beardsley
8Maintainer: imalsogreg@gmail.com
8Maintainer: imalsogreg@gmail.com
@@ -17,35 +17,37 @@ Flag Example
17
17
18library
18library
19 exposed-modules:
19 exposed-modules:
20− Servant.Common.BaseUrl
21− Servant.Common.Req
22 Servant.Reflex
20 Servant.Reflex
23 Servant.Reflex.Multi
21 Servant.Reflex.Multi
24
22
23+ other-modules:
24+ Servant.Common.BaseUrl
25+ Servant.Common.Req
26+
25 hs-source-dirs: src
27 hs-source-dirs: src
26 build-depends:
28 build-depends:
27− base >= 4.8 && < 5,
29+ base >= 4.8 && < 4.10,
28 bytestring >= 0.10 && < 0.11,
30 bytestring >= 0.10 && < 0.11,
29 case-insensitive >= 1.2.0.4 && < 1.3,
31 case-insensitive >= 1.2.0.4 && < 1.3,
30− containers >= 0.5.6 && < 0.7,
32+ containers >= 0.5.6 && < 0.6,
31 data-default >= 0.5 && < 0.8,
33 data-default >= 0.5 && < 0.8,
32− exceptions >= 0.8 && < 0.11,
34+ exceptions >= 0.8 && < 0.9,
33 ghcjs-dom >= 0.2 && < 0.10,
35 ghcjs-dom >= 0.2 && < 0.10,
34− http-api-data >= 0.3.6 && < 0.5,
36+ http-api-data >= 0.2 && < 0.4,
35− http-media >= 0.6 && < 0.9,
37+ http-media >= 0.6 && < 0.7,
36 jsaddle >= 0.8 && < 0.10,
38 jsaddle >= 0.8 && < 0.10,
37 mtl >= 2.2.1 && < 2.3,
39 mtl >= 2.2.1 && < 2.3,
38 network-uri >= 2.6 && < 2.7,
40 network-uri >= 2.6 && < 2.7,
39− reflex >= 0.5 && < 0.9,
41+ reflex >= 0.5 && < 0.6,
40− reflex-dom-core >= 0.6 && < 0.7,
42+ reflex-dom == 0.4 && < 0.5,
41 safe >= 0.3.9 && < 0.4,
43 safe >= 0.3.9 && < 0.4,
42− servant >= 0.16 && < 0.18,
44+ servant >= 0.8 && < 0.11,
43− servant-auth >= 0.2.1 && < 0.4,
45+ servant-auth >= 0.2.7 && < 0.2.8,
44 string-conversions >= 0.4 && < 0.5,
46 string-conversions >= 0.4 && < 0.5,
45 text >= 1.2 && < 1.3,
47 text >= 1.2 && < 1.3,
46 transformers >= 0.4 && < 0.6
48 transformers >= 0.4 && < 0.6
47
49
48− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
50+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
49
51
50 default-language: Haskell2010
52 default-language: Haskell2010
51
53
@@ -54,16 +56,7 @@ executable example
54 buildable: True
56 buildable: True
55 else
57 else
56 buildable: False
58 buildable: False
57− build-depends:
59+ build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text
58− aeson,
59− reflex,
60− servant-reflex,
61− base,
62− scientific,
63− servant,
64− reflex-dom,
65− reflex-dom-core,
66− text
67 default-language: Haskell2010
60 default-language: Haskell2010
68 main-is: Example.hs
61 main-is: Example.hs
69 other-modules: API
62 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
28import GHC.Generics
28import GHC.Generics
29import Language.Javascript.JSaddle.Monad (MonadJSM)
29import Language.Javascript.JSaddle.Monad (MonadJSM)
30import Reflex
30import Reflex
31−import Reflex.Dom.Core
31+import Reflex.Dom
32import Text.Read
32import Text.Read
33
33
34
34
@@ -85,14 +85,15 @@ baseUrlWidget = elClass "div" "base-url" $ do
85 where pathWidget :: m (Dynamic t BaseUrl)
85 where pathWidget :: m (Dynamic t BaseUrl)
86 pathWidget = do
86 pathWidget = do
87 text "Url base path"
87 text "Url base path"
88− t <- inputElement def
88+ t <- textInput (def {_textInputConfig_attributes =
89+ constDyn ("placeholder" =: "/a/b")})
89 return $ BasePath <$> value t
90 return $ BasePath <$> value t
90 fullUrlWidget :: m (Dynamic t BaseUrl)
91 fullUrlWidget :: m (Dynamic t BaseUrl)
91 fullUrlWidget = do
92 fullUrlWidget = do
92 schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def
93 schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def
93− srv <- inputElement def
94+ srv <- textInput def {_textInputConfig_attributes = constDyn $ "placeholder" =: "example.com"}
94 text ":"
95 text ":"
95− prt <- inputElement def
96+ prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}
96 port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))
97 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" }
98 return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path
99 return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path
src/Servant/Common/Req.hs+92−105
@@ -4,22 +4,18 @@
4{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TupleSections #-}
8{-# LANGUAGE TupleSections #-}
10
9
11module Servant.Common.Req where
10module Servant.Common.Req where
12
11
13-------------------------------------------------------------------------------
12-------------------------------------------------------------------------------
14−import Control.Applicative (liftA2, liftA3)
15−import Control.Arrow ((&&&))
16import Control.Concurrent
13import Control.Concurrent
14+import Control.Applicative (liftA2, liftA3)
17import Control.Monad (join)
15import Control.Monad (join)
18import Control.Monad.IO.Class (MonadIO, liftIO)
16import Control.Monad.IO.Class (MonadIO, liftIO)
19import Data.Bifunctor (first)
17import Data.Bifunctor (first)
20−import qualified Data.ByteString.Builder as Builder
21import qualified Data.ByteString.Lazy.Char8 as BL
18import qualified Data.ByteString.Lazy.Char8 as BL
22−import Data.ByteString (ByteString)
23import qualified Data.Map as Map
19import qualified Data.Map as Map
24import Data.Maybe (catMaybes, fromMaybe)
20import Data.Maybe (catMaybes, fromMaybe)
25import Data.Functor.Compose
21import Data.Functor.Compose
@@ -29,9 +25,8 @@ import Data.Text (Text)
29import qualified Data.Text as T
25import qualified Data.Text as T
30import qualified Data.Text.Encoding as TE
26import qualified Data.Text.Encoding as TE
31import Data.Traversable (forM)
27import Data.Traversable (forM)
32−import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
28+import Language.Javascript.JSaddle.Monad (JSM, MonadJSM)
33−import qualified Network.URI as N
34−import Reflex.Dom.Core hiding (tag)
29+import Reflex.Dom hiding (tag)
35import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
30import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
36 SupportsServantReflex)
31 SupportsServantReflex)
37import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
32import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
@@ -52,23 +47,6 @@ data ReqResult tag a
52 -- ^ A failure to construct the request tagged with 'tag' at trigger time
47 -- ^ A failure to construct the request tagged with 'tag' at trigger time
53 deriving (Functor)
48 deriving (Functor)
54
49
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'
72
50
73------------------------------------------------------------------------------
51------------------------------------------------------------------------------
74-- | Simple filter/accessor for successful responses, when you want to
52-- | Simple filter/accessor for successful responses, when you want to
@@ -93,13 +71,6 @@ reqFailure (ResponseFailure _ s _) = Just s
93reqFailure (RequestFailure _ s) = Just s
71reqFailure (RequestFailure _ s) = Just s
94reqFailure _ = Nothing
72reqFailure _ = Nothing
95
73
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−
103
74
104------------------------------------------------------------------------------
75------------------------------------------------------------------------------
105-- | Simple filter/accessor for the raw XHR response
76-- | Simple filter/accessor for the raw XHR response
@@ -167,7 +138,7 @@ reqToReflexRequest
167 => Text
138 => Text
168 -> Dynamic t BaseUrl
139 -> Dynamic t BaseUrl
169 -> Req t
140 -> Req t
170− -> Dynamic t (Either Text (XhrRequest XhrPayload))
141+ -> (Dynamic t (Either Text (XhrRequest XhrPayload)))
171reqToReflexRequest reqMeth reqHost req =
142reqToReflexRequest reqMeth reqHost req =
172 let t :: Dynamic t [Either Text Text]
143 let t :: Dynamic t [Either Text Text]
173 t = sequence $ reverse $ reqPathParts req
144 t = sequence $ reverse $ reqPathParts req
@@ -179,22 +150,18 @@ reqToReflexRequest reqMeth reqHost req =
179 urlParts = fmap sequence t
150 urlParts = fmap sequence t
180
151
181 urlPath :: Dynamic t (Either Text Text)
152 urlPath :: Dynamic t (Either Text Text)
182− urlPath = (fmap.fmap)
153+ urlPath = (fmap.fmap) (T.intercalate "/") urlParts
183− (T.intercalate "/" . fmap escape)
184− urlParts
185
154
186 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
155 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
187 queryPartString (pName, qp) = case qp of
156 queryPartString (pName, qp) = case qp of
188 QueryPartParam p -> ffor p $ \case
157 QueryPartParam p -> ffor p $ \case
189 Left e -> Just (Left e)
158 Left e -> Just (Left e)
190− Right (Just a) -> Just (Right $ pName <> "=" <> escape a)
159+ Right (Just a) -> Just (Right $ pName <> "=" <> a)
191 Right Nothing -> Nothing
160 Right Nothing -> Nothing
192 QueryPartParams ps -> ffor ps $ \pStrings ->
161 QueryPartParams ps -> ffor ps $ \pStrings ->
193 if null pStrings
162 if null pStrings
194 then Nothing
163 then Nothing
195− else Just . Right
196− . T.intercalate "&"
197− $ fmap (\p -> pName <> "=" <> escape p) pStrings
164+ else Just $ Right (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) pStrings))
198 QueryPartFlag fl -> ffor fl $ \case
165 QueryPartFlag fl -> ffor fl $ \case
199 True -> Just $ Right pName
166 True -> Just $ Right pName
200 False -> Nothing
167 False -> Nothing
@@ -229,10 +196,10 @@ reqToReflexRequest reqMeth reqHost req =
229 Right $ XhrRequestConfig
196 Right $ XhrRequestConfig
230 { _xhrRequestConfig_sendData = bytesToPayload bBytes
197 { _xhrRequestConfig_sendData = bytesToPayload bBytes
231 , _xhrRequestConfig_headers =
198 , _xhrRequestConfig_headers =
232− Map.insert "Content-Type" bCT (Map.fromList hs)
199+ Map.insert "Content-Type" bCT (Map.fromList hs)
233 , _xhrRequestConfig_user = Nothing
200 , _xhrRequestConfig_user = Nothing
234 , _xhrRequestConfig_password = Nothing
201 , _xhrRequestConfig_password = Nothing
235− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
202+ , _xhrRequestConfig_responseType = Nothing
236 , _xhrRequestConfig_withCredentials = False
203 , _xhrRequestConfig_withCredentials = False
237 , _xhrRequestConfig_responseHeaders = def
204 , _xhrRequestConfig_responseHeaders = def
238 }
205 }
@@ -244,8 +211,8 @@ reqToReflexRequest reqMeth reqHost req =
244 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
211 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
245 , _xhrRequestConfig_user = Nothing
212 , _xhrRequestConfig_user = Nothing
246 , _xhrRequestConfig_password = Nothing
213 , _xhrRequestConfig_password = Nothing
247− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
214+ , _xhrRequestConfig_responseType = Nothing
248− , _xhrRequestConfig_sendData = mempty
215+ , _xhrRequestConfig_sendData = ""
249 , _xhrRequestConfig_withCredentials = False
216 , _xhrRequestConfig_withCredentials = False
250 }
217 }
251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
218 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
@@ -272,29 +239,21 @@ reqToReflexRequest reqMeth reqHost req =
272displayHttpRequest :: Text -> Text
239displayHttpRequest :: Text -> Text
273displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
240displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
274
241
275−-- | This function performs the request
242+-- | This function actually performs the request.
276performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
243performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
277 => Text
244 => Text
278 -> Dynamic t (f (Req t))
245 -> Dynamic t (f (Req t))
279 -> Dynamic t BaseUrl
246 -> Dynamic t BaseUrl
280− -> ClientOptions
281 -> Event t tag
247 -> Event t tag
282 -> m (Event t (tag, f (Either Text XhrResponse)))
248 -> m (Event t (tag, f (Either Text XhrResponse)))
283−performRequests reqMeth rs reqHost opts trigger = do
249+performRequests reqMeth rs reqHost trigger = do
284− let xhrReqs =
250+ -- let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))
285− join $ (\(fxhr :: f (Req t)) -> sequence $
286− reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
251+ let xhrReqs = join $ (\(fxhr :: f (Req t)) -> sequence $ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
287−
288− -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
289− reqs = attachPromptlyDynWith
290− (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
252+ let reqs = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
291−
292− resps <- performSomeRequestsAsync opts reqs
253+ resps <- performSomeRequestsAsync reqs
293 return $ getCompose <$> resps
254 return $ getCompose <$> resps
294
255
295−-- | Issues a collection of requests when the supplied Event fires.
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.
296−-- When ALL requests from a given firing complete, the results are
297−-- collected and returned via the return Event.
298performSomeRequestsAsync
257performSomeRequestsAsync
299 :: (MonadIO (Performable m),
258 :: (MonadIO (Performable m),
300 MonadJSM (Performable m),
259 MonadJSM (Performable m),
@@ -302,25 +261,20 @@ performSomeRequestsAsync
302 PerformEvent t m,
261 PerformEvent t m,
303 TriggerEvent t m,
262 TriggerEvent t m,
304 Traversable f,
263 Traversable f,
305− IsXhrPayload a,
264+ IsXhrPayload a)
306− Show a
307− )
308− => ClientOptions
309− -> Event t (f (Either Text (XhrRequest a)))
265+ => Event t (f (Either Text (XhrRequest a)))
310 -> m (Event t (f (Either Text XhrResponse)))
266 -> m (Event t (f (Either Text XhrResponse)))
311−performSomeRequestsAsync opts =
312− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
267+performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return
313
268
314
269
315------------------------------------------------------------------------------
270------------------------------------------------------------------------------
316-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
271-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
317-- that accepts 'f (Either e (XhrRequestb))' events
272-- that accepts 'f (Either e (XhrRequestb))' events
318performSomeRequestsAsync'
273performSomeRequestsAsync'
319− :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
274+ :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
320− => ClientOptions
321− -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
275+ => (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
322 -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
276 -> 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
277+performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
324 rs <- hrs
278 rs <- hrs
325 resps <- forM rs $ \r -> case r of
279 resps <- forM rs $ \r -> case r of
326 Left e -> do
280 Left e -> do
@@ -328,17 +282,70 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs
328 return resp
282 return resp
329 Right r' -> do
283 Right r' -> do
330 resp <- liftIO newEmptyMVar
284 resp <- liftIO newEmptyMVar
331− r'' <- liftJSM $ (optsRequestFixup opts) r'
332− _ <- newXhr r'' $ liftIO . putMVar resp . Right
285+ _ <- newXhr r' $ liftIO . putMVar resp . Right
333 return resp
286 return resp
334 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
287 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
335 return ()
288 return ()
336
289
337
290
338
291
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+
339−type XhrPayload = ByteString
311+type XhrPayload = T.Text
340bytesToPayload :: BL.ByteString -> XhrPayload
312bytesToPayload :: BL.ByteString -> XhrPayload
341−bytesToPayload = BL.toStrict
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+-- ]
342
349
343
350
344performRequestsCT
351performRequestsCT
@@ -348,20 +355,19 @@ performRequestsCT
348 -> Text
355 -> Text
349 -> Dynamic t (f (Req t))
356 -> Dynamic t (f (Req t))
350 -> Dynamic t BaseUrl
357 -> Dynamic t BaseUrl
351− -> ClientOptions
352 -> Event t tag
358 -> Event t tag
353 -> m (Event t (f (ReqResult tag a)))
359 -> m (Event t (f (ReqResult tag a)))
354−performRequestsCT ct reqMeth reqs reqHost opts trigger = do
360+performRequestsCT ct reqMeth reqs reqHost trigger = do
355− resps <- performRequests reqMeth reqs reqHost opts trigger
361+ resps <- performRequests reqMeth reqs reqHost trigger
356− let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
357− first T.pack .
362+ let decodeResp x = first T.pack .
358− mimeUnrender ct $
363+ mimeUnrender ct .
359− BL.fromStrict x
364+ BL.fromStrict .
360− decodeResp _ = Left "No body"
365+ TE.encodeUtf8 =<< note "No body text"
366+ (_xhrResponse_responseText x)
361 return $ fmap
367 return $ fmap
362 (\(t,rs) -> ffor rs $ \r -> case r of
368 (\(t,rs) -> ffor rs $ \r -> case r of
363 Left e -> RequestFailure t e
369 Left e -> RequestFailure t e
364− Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
370+ Right g -> evalResponse decodeResp (t,g)
365 )
371 )
366 resps
372 resps
367
373
@@ -372,11 +378,10 @@ performRequestsNoBody
372 => Text
378 => Text
373 -> Dynamic t (f (Req t))
379 -> Dynamic t (f (Req t))
374 -> Dynamic t BaseUrl
380 -> Dynamic t BaseUrl
375− -> ClientOptions
376 -> Event t tag
381 -> Event t tag
377 -> m (Event t (f (ReqResult tag NoContent)))
382 -> m (Event t (f (ReqResult tag NoContent)))
378−performRequestsNoBody reqMeth reqs reqHost opts trigger = do
383+performRequestsNoBody reqMeth reqs reqHost trigger = do
379− resps <- performRequests reqMeth reqs reqHost opts trigger
384+ resps <- performRequests reqMeth reqs reqHost trigger
380 let decodeResp = const $ Right NoContent
385 let decodeResp = const $ Right NoContent
381 return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
386 return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
382 Left e -> RequestFailure tag e
387 Left e -> RequestFailure tag e
@@ -389,8 +394,7 @@ evalResponse
389 -> (tag, XhrResponse)
394 -> (tag, XhrResponse)
390 -> ReqResult tag a
395 -> ReqResult tag a
391evalResponse decode (tag, xhr) =
396evalResponse decode (tag, xhr) =
392− let status = _xhrResponse_status xhr
397+ let okStatus = _xhrResponse_status xhr < 400
393− okStatus = status >= 200 && status < 400
394 errMsg = fromMaybe
398 errMsg = fromMaybe
395 ("Empty response with error code " <>
399 ("Empty response with error code " <>
396 T.pack (show $ _xhrResponse_status xhr))
400 T.pack (show $ _xhrResponse_status xhr))
@@ -403,17 +407,7 @@ evalResponse decode (tag, xhr) =
403 else ResponseFailure tag errMsg xhr
407 else ResponseFailure tag errMsg xhr
404 in respPayld
408 in respPayld
405
409
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
411
410
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'
417
411
418
412
419note :: e -> Maybe a -> Either e a
413note :: e -> Maybe a -> Either e a
@@ -422,10 +416,3 @@ note e = maybe (Left e) Right
422fmapL :: (e -> e') -> Either e a -> Either e' a
416fmapL :: (e -> e') -> Either e a -> Either e' a
423fmapL _ (Right a) = Right a
417fmapL _ (Right a) = Right a
424fmapL f (Left e) = Left (f e)
418fmapL 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+82−154
@@ -8,7 +8,6 @@
8{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
10{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE Rank2Types #-}
12{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE TupleSections #-}
12{-# LANGUAGE TupleSections #-}
14{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeFamilies #-}
@@ -25,57 +24,48 @@
25-- API.
24-- API.
26module Servant.Reflex
25module Servant.Reflex
27 ( client
26 ( client
28− , clientWithOpts
29− , clientWithOptsAndResultHandler
30− , clientWithRoute
31− , clientWithRouteAndResultHandler
32 , BuildHeaderKeysTo(..)
27 , BuildHeaderKeysTo(..)
33 , toHeaders
28 , toHeaders
34− , HasClient
29+ , HasClient(..)
35− , Client
36 , module Servant.Common.Req
30 , module Servant.Common.Req
37 , module Servant.Common.BaseUrl
31 , module Servant.Common.BaseUrl
38 ) where
32 ) where
39
33
40------------------------------------------------------------------------------
34------------------------------------------------------------------------------
41import Control.Applicative
35import Control.Applicative
42−import qualified Data.CaseInsensitive as CI
43−import Data.Functor.Identity
44−import qualified Data.Map as Map
45import Data.Monoid ((<>))
36import Data.Monoid ((<>))
46−import Data.Proxy (Proxy (..))
47import qualified Data.Set as Set
37import qualified Data.Set as Set
38+import qualified Data.Text.Encoding as E
39+import Data.CaseInsensitive (mk)
40+import Data.Functor.Identity
41+import Data.Proxy (Proxy (..))
42+import qualified Data.Map as Map
48import Data.Text (Text)
43import Data.Text (Text)
49import qualified Data.Text as T
44import qualified Data.Text as T
50−import qualified Data.Text.Encoding as E
51import GHC.Exts (Constraint)
45import GHC.Exts (Constraint)
52import GHC.TypeLits (KnownSymbol, symbolVal)
46import GHC.TypeLits (KnownSymbol, symbolVal)
53−import Servant.API ((:<|>) (..), (:>), BasicAuth,
47+import Servant.API ((:<|>)(..),(:>), BasicAuth,
54− BasicAuthData, BuildHeadersTo (..),
48+ BasicAuthData, BuildHeadersTo(..),
55− Capture, Header, Headers (..),
49+ Capture, contentType, Header,
56− HttpVersion, IsSecure,
50+ Headers(..), HttpVersion, IsSecure,
57− MimeRender (..), MimeUnrender,
51+ MimeRender(..), MimeUnrender,
58 NoContent, QueryFlag, QueryParam,
52 NoContent, QueryFlag, QueryParam,
59− QueryParams, Raw, ReflectMethod (..),
53+ QueryParams, Raw, ReflectMethod(..),
60 RemoteHost, ReqBody,
54 RemoteHost, ReqBody,
61− ToHttpApiData (..), Vault, Verb,
55+ ToHttpApiData(..), Vault, Verb)
62− contentType)
63−import Servant.API.Description (Summary)
64import qualified Servant.Auth as Auth
56import qualified Servant.Auth as Auth
65
57
66−import Reflex.Dom.Core (Dynamic, Event, Reflex,
58+import Reflex.Dom (Dynamic, Event, Reflex,
67− XhrRequest (..), XhrResponse (..),
59+ XhrRequest(..),
68− XhrResponseHeaders (..),
60+ XhrResponseHeaders(..),
69− attachPromptlyDynWith, constDyn, ffor,
61+ XhrResponse(..), attachPromptlyDynWith, constDyn, ffor, fmapMaybe,
70− fmapMaybe, leftmost,
71− performRequestsAsync)
62+ leftmost, performRequestsAsync,
63+ )
72------------------------------------------------------------------------------
64------------------------------------------------------------------------------
73import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
65import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
74 showBaseUrl,
66 showBaseUrl,
75 SupportsServantReflex)
67 SupportsServantReflex)
76−import Servant.Common.Req (ClientOptions(..),
77− defaultClientOptions,
78− Req, ReqResult(..), QParam(..),
68+import Servant.Common.Req (Req, ReqResult(..), QParam(..),
79 QueryPart(..), addHeader, authData,
69 QueryPart(..), addHeader, authData,
80 defReq, evalResponse, prependToPathParts,
70 defReq, evalResponse, prependToPathParts,
81 -- performRequestCT,
71 -- performRequestCT,
@@ -85,10 +75,9 @@ import Servant.Common.Req (ClientOptions(..),
85 performSomeRequestsAsync,
75 performSomeRequestsAsync,
86 qParamToQueryPart, reqBody,
76 qParamToQueryPart, reqBody,
87 reqSuccess, reqFailure,
77 reqSuccess, reqFailure,
88− reqMethod, respHeaders,
78+ reqMethod, respHeaders, response,
89− response,
90 reqTag,
79 reqTag,
91− qParams, withCredentials)
80+ qParams)
92
81
93
82
94-- * Accessing APIs as a Client
83-- * Accessing APIs as a Client
@@ -103,75 +92,28 @@ import Servant.Common.Req (ClientOptions(..),
103-- >
92-- >
104-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
93-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
105-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
94-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
106−-- > -> m (Event t (l, ReqResult Book)))
95+-- -> m (Event t (l, ReqResult Book)))
107-- > (getAllBooks :<|> postNewBook) = client myApi host
96-- > (getAllBooks :<|> postNewBook) = client myApi host
108-- > where host = constDyn $ BaseUrl Http "localhost" 8080
97-- > where host = constDyn $ BaseUrl Http "localhost" 8080
109−client
110− :: (HasClient t m layout tag)
98+client :: (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
99+ => Proxy layout -> Proxy m -> Proxy tag -> Dynamic t BaseUrl -> Client t m layout tag
126−clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
100+client 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
141
101
142
102
143-- | This class lets us define how each API combinator
103-- | This class lets us define how each API combinator
144-- influences the creation of an HTTP request. It's mostly
104-- influences the creation of an HTTP request. It's mostly
145-- an internal class, you can just use 'client'.
105-- an internal class, you can just use 'client'.
146−class Monad m => HasClient t m layout (tag :: *) where
106+class HasClient t m layout (tag :: *) where
147 type Client t m layout tag :: *
107 type Client t m layout tag :: *
148− clientWithRoute
108+ clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> Client t m layout tag
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
167
109
168
110
169instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
111instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
170 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
112 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
171
113
172− clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =
114+ clientWithRoute Proxy q pTag req baseurl =
173− clientWithRouteAndResultHandler (Proxy :: Proxy a) q pTag req baseurl opts wrap :<|>
115+ clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>
174− clientWithRouteAndResultHandler (Proxy :: Proxy b) q pTag req baseurl opts wrap
116+ clientWithRoute (Proxy :: Proxy b) q pTag req baseurl
175
117
176
118
177-- Capture. Example:
119-- Capture. Example:
@@ -192,9 +134,11 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
192 type Client t m (Capture capture a :> sublayout) tag =
134 type Client t m (Capture capture a :> sublayout) tag =
193 Dynamic t (Either Text a) -> Client t m sublayout tag
135 Dynamic t (Either Text a) -> Client t m sublayout tag
194
136
195− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
137+ clientWithRoute Proxy q t req baseurl val =
196− clientWithRouteAndResultHandler
138+ clientWithRoute (Proxy :: Proxy sublayout)
139+ q t
197− (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
140+ (prependToPathParts p req)
141+ baseurl
198 where p = (fmap . fmap) (toUrlPiece) val
142 where p = (fmap . fmap) (toUrlPiece) val
199
143
200
144
@@ -207,8 +151,9 @@ instance {-# OVERLAPPABLE #-}
207 Event t tag -> m (Event t (ReqResult tag a))
151 Event t tag -> m (Event t (ReqResult tag a))
208 -- TODO how to access input types here?
152 -- TODO how to access input types here?
209 -- ExceptT ServantError IO a
153 -- ExceptT ServantError IO a
210− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
154+ clientWithRoute Proxy _ _ req baseurl trigs =
155+ -- performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs
211− wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
156+ fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl trigs
212 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
157 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
213 req' = req { reqMethod = method }
158 req' = req { reqMethod = method }
214
159
@@ -221,33 +166,29 @@ instance {-# OVERLAPPING #-}
221 Event t tag -> m (Event t (ReqResult tag NoContent))
166 Event t tag -> m (Event t (ReqResult tag NoContent))
222 -- TODO: how to access input types here?
167 -- TODO: how to access input types here?
223 -- ExceptT ServantError IO NoContent
168 -- ExceptT ServantError IO NoContent
224− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
169+ clientWithRoute Proxy _ _ req baseurl =
225− wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
170+ (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl
226 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
171 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
227
172
228
173
229toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
174toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
230toHeaders r =
175toHeaders r =
176+ let toBS = E.encodeUtf8
231− let hdrs = maybe []
177+ hdrs = maybe []
232− (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
178+ (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
233 (Map.toList $ _xhrResponse_headers xhr))
179 (Map.toList $ _xhrResponse_headers xhr))
234 (response r)
180 (response r)
235 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
181 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
236
182
237−
238class BuildHeaderKeysTo hs where
183class BuildHeaderKeysTo hs where
239− buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
184+ buildHeaderKeysTo :: Proxy hs -> [T.Text]
240
185
241instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
186instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
242 where buildHeaderKeysTo _ = []
187 where buildHeaderKeysTo _ = []
243
188
244instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
189instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
245 => BuildHeaderKeysTo ((Header h v) ': xs) where
190 => 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)
191+ buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
250−
251
192
252-- HEADERS Verb (Content) --
193-- HEADERS Verb (Content) --
253-- Headers combinator not treated in fully general case,
194-- Headers combinator not treated in fully general case,
@@ -262,10 +203,10 @@ instance {-# OVERLAPPABLE #-}
262 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
203 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
263 type Client t m (Verb method status cts' (Headers ls a)) tag =
204 type Client t m (Verb method status cts' (Headers ls a)) tag =
264 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
205 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
265− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
206+ clientWithRoute Proxy _ _ req baseurl trigs = do
266 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
207 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
267− resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
208+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl trigs
268− wrap $ toHeaders <$> resp
209+ return $ toHeaders <$> resp
269 where req' = req { respHeaders =
210 where req' = req { respHeaders =
270 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
211 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
271 }
212 }
@@ -278,10 +219,10 @@ instance {-# OVERLAPPABLE #-}
278 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
219 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
279 type Client t m (Verb method status cts (Headers ls NoContent)) tag
220 type Client t m (Verb method status cts (Headers ls NoContent)) tag
280 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
221 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
281− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
222+ clientWithRoute Proxy _ _ req baseurl trigs = do
282 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
223 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
283− resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
224+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl trigs
284− wrap $ toHeaders <$> resp
225+ return $ toHeaders <$> resp
285 where req' = req {respHeaders =
226 where req' = req {respHeaders =
286 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
227 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
287 }
228 }
@@ -308,11 +249,11 @@ instance (KnownSymbol sym, ToHttpApiData a,
308 type Client t m (Header sym a :> sublayout) tag =
249 type Client t m (Header sym a :> sublayout) tag =
309 Dynamic t (Either Text a) -> Client t m sublayout tag
250 Dynamic t (Either Text a) -> Client t m sublayout tag
310
251
311− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =
252+ clientWithRoute Proxy q t req baseurl eVal =
312− clientWithRouteAndResultHandler
313− (Proxy :: Proxy sublayout) q t
253+ clientWithRoute (Proxy :: Proxy sublayout)
254+ q t
314− (Servant.Common.Req.addHeader hname eVal req)
255+ (Servant.Common.Req.addHeader hname eVal req)
315− baseurl opts wrap
256+ baseurl
316 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
257 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
317
258
318
259
@@ -326,21 +267,8 @@ instance HasClient t m sublayout tag
326 type Client t m (HttpVersion :> sublayout) tag =
267 type Client t m (HttpVersion :> sublayout) tag =
327 Client t m sublayout tag
268 Client t m sublayout tag
328
269
329− clientWithRouteAndResultHandler Proxy =
270+ clientWithRoute Proxy q t =
330− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
271+ clientWithRoute (Proxy :: Proxy sublayout) q t
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−
344
272
345
273
346-- | If you use a 'QueryParam' in one of your endpoints in your API,
274-- | If you use a 'QueryParam' in one of your endpoints in your API,
@@ -376,9 +304,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
376 Dynamic t (QParam a) -> Client t m sublayout tag
304 Dynamic t (QParam a) -> Client t m sublayout tag
377
305
378 -- if mparam = Nothing, we don't add it to the query string
306 -- if mparam = Nothing, we don't add it to the query string
379− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
307+ clientWithRoute Proxy q t req baseurl mparam =
380− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
308+ clientWithRoute (Proxy :: Proxy sublayout) q t
381− (req {qParams = paramPair : qParams req}) baseurl opts wrap
309+ (req {qParams = paramPair : qParams req}) baseurl
382
310
383 where pname = symbolVal (Proxy :: Proxy sym)
311 where pname = symbolVal (Proxy :: Proxy sym)
384 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
312 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -422,8 +350,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
422 type Client t m (QueryParams sym a :> sublayout) tag =
350 type Client t m (QueryParams sym a :> sublayout) tag =
423 Dynamic t [a] -> Client t m sublayout tag
351 Dynamic t [a] -> Client t m sublayout tag
424
352
425− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
353+ clientWithRoute Proxy q t req baseurl paramlist =
426− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
354+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
427
355
428 where req' = req { qParams = (T.pack pname, params') : qParams req }
356 where req' = req { qParams = (T.pack pname, params') : qParams req }
429 pname = symbolVal (Proxy :: Proxy sym)
357 pname = symbolVal (Proxy :: Proxy sym)
@@ -462,8 +390,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
462 type Client t m (QueryFlag sym :> sublayout) tag =
390 type Client t m (QueryFlag sym :> sublayout) tag =
463 Dynamic t Bool -> Client t m sublayout tag
391 Dynamic t Bool -> Client t m sublayout tag
464
392
465− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
393+ clientWithRoute Proxy q t req baseurl flag =
466− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
394+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
467
395
468 where req' = req { qParams = thisPair : qParams req }
396 where req' = req { qParams = thisPair : qParams req }
469 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
397 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -477,7 +405,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
477 -> Event t tag
405 -> Event t tag
478 -> m (Event t (ReqResult tag ()))
406 -> m (Event t (ReqResult tag ()))
479
407
480− clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
408+ clientWithRoute _ _ _ _ baseurl xhrs triggers = do
481
409
482 let xhrs' = liftA2 (\x path -> case x of
410 let xhrs' = liftA2 (\x path -> case x of
483 Left e -> Left e
411 Left e -> Left e
@@ -488,7 +416,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
488 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
416 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
489
417
490 resps <- performRequestsAsync okReq
418 resps <- performRequestsAsync okReq
491− wrap $ leftmost [ uncurry RequestFailure <$> badReq
419+ return $ leftmost [ uncurry RequestFailure <$> badReq
492 , evalResponse (const $ Right ()) <$> resps
420 , evalResponse (const $ Right ()) <$> resps
493 ]
421 ]
494
422
@@ -519,8 +447,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
519 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
447 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
520 Dynamic t (Either Text a) -> Client t m sublayout tag
448 Dynamic t (Either Text a) -> Client t m sublayout tag
521
449
522− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
450+ clientWithRoute Proxy q t req baseurl body =
523− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
451+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
524 where req' = req { reqBody = bodyBytesCT }
452 where req' = req { reqBody = bodyBytesCT }
525 ctProxy = Proxy :: Proxy ct
453 ctProxy = Proxy :: Proxy ct
526 ctString = T.pack $ show $ contentType ctProxy
454 ctString = T.pack $ show $ contentType ctProxy
@@ -534,9 +462,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
534instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
462instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
535 type Client t m (path :> sublayout) tag = Client t m sublayout tag
463 type Client t m (path :> sublayout) tag = Client t m sublayout tag
536
464
537− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =
465+ clientWithRoute Proxy q t req baseurl =
538− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
466+ clientWithRoute (Proxy :: Proxy sublayout) q t
539− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap
467+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl
540
468
541 where p = symbolVal (Proxy :: Proxy path)
469 where p = symbolVal (Proxy :: Proxy path)
542
470
@@ -544,23 +472,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient
544instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
472instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
545 type Client t m (Vault :> api) tag = Client t m api tag
473 type Client t m (Vault :> api) tag = Client t m api tag
546
474
547− clientWithRouteAndResultHandler Proxy =
475+ clientWithRoute Proxy q t req baseurl =
548− clientWithRouteAndResultHandler (Proxy :: Proxy api)
476+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
549
477
550
478
551instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
479instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
552 type Client t m (RemoteHost :> api) tag = Client t m api tag
480 type Client t m (RemoteHost :> api) tag = Client t m api tag
553
481
554− clientWithRouteAndResultHandler Proxy =
482+ clientWithRoute Proxy q t req baseurl =
555− clientWithRouteAndResultHandler (Proxy :: Proxy api)
483+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
556
484
557
485
558
486
559instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
487instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
560 type Client t m (IsSecure :> api) tag = Client t m api tag
488 type Client t m (IsSecure :> api) tag = Client t m api tag
561
489
562− clientWithRouteAndResultHandler Proxy =
490+ clientWithRoute Proxy q t req baseurl =
563− clientWithRouteAndResultHandler (Proxy :: Proxy api)
491+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
564
492
565
493
566instance (HasClient t m api tag, Reflex t)
494instance (HasClient t m api tag, Reflex t)
@@ -569,8 +497,8 @@ instance (HasClient t m api tag, Reflex t)
569 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
497 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
570 -> Client t m api tag
498 -> Client t m api tag
571
499
572− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
500+ clientWithRoute Proxy q t req baseurl authdata =
573− clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
501+ clientWithRoute (Proxy :: Proxy api) q t req' baseurl
574 where
502 where
575 req' = req { authData = Just authdata }
503 req' = req { authData = Just authdata }
576
504
@@ -613,7 +541,7 @@ for empty and one for non-empty lists).
613instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where
541instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where
614
542
615 type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag
543 type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag
616− clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)
544+ clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)
617
545
618
546
619type family HasCookieAuth xs :: Constraint where
547type family HasCookieAuth xs :: Constraint where
src/Servant/Reflex/Multi.hs+53−82
@@ -16,15 +16,12 @@
16module Servant.Reflex.Multi (
16module Servant.Reflex.Multi (
17 -- * Compute servant client functions
17 -- * Compute servant client functions
18 clientA
18 clientA
19− , clientWithOptsA
20 , BaseUrl(..)
19 , BaseUrl(..)
21 , Scheme(..)
20 , Scheme(..)
22
21
23 -- * Build QueryParam arguments
22 -- * Build QueryParam arguments
24 , QParam(..)
23 , QParam(..)
25
24
26− -- * Access response data
27− , withCredentials
28
25
29 -- * Access response data
26 -- * Access response data
30 , ReqResult(..)
27 , ReqResult(..)
@@ -37,45 +34,40 @@ module Servant.Reflex.Multi (
37 ) where
34 ) where
38
35
39------------------------------------------------------------------------------
36------------------------------------------------------------------------------
40−import Control.Applicative (liftA2)
37+import Control.Applicative (liftA2)
41−import Data.Functor.Compose (Compose (..), getCompose)
38+import Data.Functor.Compose (Compose (..), getCompose)
42−import Data.Proxy (Proxy (..))
39+import Data.Proxy (Proxy (..))
43−import qualified Data.Set as Set
40+import qualified Data.Set as Set
44−import Data.Text (Text)
41+import Data.Text (Text)
45−import qualified Data.Text as T
42+import qualified Data.Text as T
46−import qualified Data.Text.Encoding as E
43+import qualified Data.Text.Encoding as E
47−import GHC.TypeLits (KnownSymbol, symbolVal)
44+import GHC.TypeLits (KnownSymbol, symbolVal)
48−import Servant.API ((:<|>) (..), (:>), BasicAuth,
45+import Servant.API ((:<|>) (..), (:>), BasicAuth,
49− BasicAuthData, BuildHeadersTo (..),
46+ BasicAuthData, BuildHeadersTo (..),
50− Capture, Header, Headers (..),
47+ Capture, Header, Headers (..),
51− HttpVersion, IsSecure,
48+ HttpVersion, IsSecure, MimeRender (..),
52− MimeRender (..), MimeUnrender,
53− NoContent, QueryFlag, QueryParam,
49+ MimeUnrender, NoContent, QueryFlag,
54− QueryParams, Raw, ReflectMethod (..),
50+ QueryParam, QueryParams, Raw,
55− RemoteHost, ReqBody,
51+ ReflectMethod (..), RemoteHost,
56− ToHttpApiData (..), Vault, Verb,
52+ ReqBody, ToHttpApiData (..), Vault,
57− contentType)
53+ Verb, contentType)
58−import Servant.API.Description (Summary)
54+
59−
60−import Reflex.Dom.Core (Dynamic, Event, Reflex,
55+import Reflex.Dom (Dynamic, Event, Reflex,
61− XhrRequest (..),
56+ XhrRequest (..),
62− XhrResponseHeaders (..),
57+ XhrResponseHeaders (..),
63− attachPromptlyDynWith, constDyn)
58+ attachPromptlyDynWith, constDyn)
64------------------------------------------------------------------------------
59------------------------------------------------------------------------------
65import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
60import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
66 SupportsServantReflex)
61 SupportsServantReflex)
67−import Servant.Common.Req (ClientOptions,
68− QParam (..), QueryPart (..), Req,
62+import Servant.Common.Req (QParam (..), QueryPart (..), Req,
69 ReqResult (..), addHeader, authData,
63 ReqResult (..), addHeader, authData,
70− defReq,
71− defaultClientOptions,
72− performRequestsCT,
64+ defReq, performRequestsCT,
73 performRequestsNoBody,
65 performRequestsNoBody,
74 performSomeRequestsAsync,
66 performSomeRequestsAsync,
75 prependToPathParts, qParamToQueryPart,
67 prependToPathParts, qParamToQueryPart,
76 qParams, reqBody, reqFailure,
68 qParams, reqBody, reqFailure,
77 reqMethod, reqSuccess, reqSuccess',
69 reqMethod, reqSuccess, reqSuccess',
78− respHeaders, response, withCredentials)
70+ respHeaders, response)
79import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
71import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
80
72
81
73
@@ -85,24 +77,14 @@ clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
85 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
77 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
86clientA p q f tag baseurl =
78clientA p q f tag baseurl =
87 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
79 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
88− defaultClientOptions
89−
90
80
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
99
81
100------------------------------------------------------------------------------
82------------------------------------------------------------------------------
101class HasClientMulti t m layout f (tag :: *) where
83class HasClientMulti t m layout f (tag :: *) where
102 type ClientMulti t m layout f tag :: *
84 type ClientMulti t m layout f tag :: *
103 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
85 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
104 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
86 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
105− -> ClientOptions -> ClientMulti t m layout f tag
87+ -> ClientMulti t m layout f tag
106
88
107
89
108------------------------------------------------------------------------------
90------------------------------------------------------------------------------
@@ -110,9 +92,9 @@ instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>
110 HasClientMulti t m (a :<|> b) f tag where
92 HasClientMulti t m (a :<|> b) f tag where
111 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>
93 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>
112 ClientMulti t m b f tag
94 ClientMulti t m b f tag
113− clientWithRouteMulti Proxy q f tag reqs baseurl opts =
95+ clientWithRouteMulti Proxy q f tag reqs baseurl =
114− clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>
96+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl :<|>
115− clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts
97+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl
116
98
117
99
118------------------------------------------------------------------------------
100------------------------------------------------------------------------------
@@ -125,8 +107,8 @@ instance (SupportsServantReflex t m,
125 type ClientMulti t m (Capture capture a :> sublayout) f tag =
107 type ClientMulti t m (Capture capture a :> sublayout) f tag =
126 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
108 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
127
109
128− clientWithRouteMulti _ q f tag reqs baseurl opts vals =
110+ clientWithRouteMulti _ q f tag reqs baseurl vals =
129− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
111+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
130 where
112 where
131 reqs' = (prependToPathParts <$> ps <*>) <$> reqs
113 reqs' = (prependToPathParts <$> ps <*>) <$> reqs
132 ps = (fmap . fmap . fmap) toUrlPiece vals
114 ps = (fmap . fmap . fmap) toUrlPiece vals
@@ -146,8 +128,8 @@ instance {-# OVERLAPPABLE #-}
146 type ClientMulti t m (Verb method status cts' a) f tag =
128 type ClientMulti t m (Verb method status cts' a) f tag =
147 Event t tag -> m (Event t (f (ReqResult tag a)))
129 Event t tag -> m (Event t (f (ReqResult tag a)))
148
130
149− clientWithRouteMulti _ _ _ _ reqs baseurl opts =
131+ clientWithRouteMulti _ _ _ _ reqs baseurl =
150− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts
132+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
151 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
133 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
152 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
134 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
153
135
@@ -161,8 +143,8 @@ instance {-# OVERLAPPING #-}
161 Event t tag -> m (Event t (f (ReqResult tag NoContent)))
143 Event t tag -> m (Event t (f (ReqResult tag NoContent)))
162 -- TODO: how to access input types here?
144 -- TODO: how to access input types here?
163 -- ExceptT ServantError IO NoContent
145 -- ExceptT ServantError IO NoContent
164− clientWithRouteMulti Proxy _ _ _ req baseurl opts =
146+ clientWithRouteMulti Proxy _ _ _ req baseurl =
165− performRequestsNoBody method req baseurl opts
147+ performRequestsNoBody method req baseurl
166 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
148 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
167
149
168
150
@@ -176,9 +158,9 @@ instance {-# OVERLAPPABLE #-}
176 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where
158 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where
177 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =
159 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =
178 Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))
160 Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))
179− clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
161+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
180 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
162 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)))
163+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl triggers :: m (Event t (f (ReqResult tag a)))
182 return $ fmap toHeaders <$> resp
164 return $ fmap toHeaders <$> resp
183 where
165 where
184 reqs' = fmap (\r ->
166 reqs' = fmap (\r ->
@@ -199,9 +181,9 @@ instance {-# OVERLAPPABLE #-}
199 cts (Headers ls NoContent)) f tag where
181 cts (Headers ls NoContent)) f tag where
200 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag
182 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag
201 = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))
183 = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))
202− clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
184+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
203 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
185 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
204− resp <- performRequestsNoBody method reqs' baseurl opts triggers
186+ resp <- performRequestsNoBody method reqs' baseurl triggers
205 return $ fmap toHeaders <$> resp
187 return $ fmap toHeaders <$> resp
206 where reqs' = fmap (\req ->
188 where reqs' = fmap (\req ->
207 req {respHeaders = OnlyHeaders (Set.fromList
189 req {respHeaders = OnlyHeaders (Set.fromList
@@ -221,11 +203,11 @@ instance (KnownSymbol sym,
221 type ClientMulti t m (Header sym a :> sublayout) f tag =
203 type ClientMulti t m (Header sym a :> sublayout) f tag =
222 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
204 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
223
205
224− clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =
206+ clientWithRouteMulti Proxy f q tag reqs baseurl eVals =
225 clientWithRouteMulti (Proxy :: Proxy sublayout) f
207 clientWithRouteMulti (Proxy :: Proxy sublayout) f
226 q tag
208 q tag
227 reqs'
209 reqs'
228− baseurl opts
210+ baseurl
229 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
211 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
230 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
212 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
231 <$> eVals <*>) <$> reqs
213 <$> eVals <*>) <$> reqs
@@ -242,17 +224,6 @@ instance HasClientMulti t m sublayout f tag
242 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
224 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
243
225
244
226
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−
256------------------------------------------------------------------------------
227------------------------------------------------------------------------------
257instance (KnownSymbol sym,
228instance (KnownSymbol sym,
258 ToHttpApiData a,
229 ToHttpApiData a,
@@ -266,9 +237,9 @@ instance (KnownSymbol sym,
266
237
267 -- if mparam = Nothing, we don't add it to the query string
238 -- if mparam = Nothing, we don't add it to the query string
268 -- TODO: Check the above comment
239 -- TODO: Check the above comment
269− clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =
240+ clientWithRouteMulti Proxy q f tag reqs baseurl mparams =
270 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
241 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
271− reqs' baseurl opts
242+ reqs' baseurl
272
243
273 where pname = symbolVal (Proxy :: Proxy sym)
244 where pname = symbolVal (Proxy :: Proxy sym)
274 p prm = QueryPartParam $ fmap qParamToQueryPart prm
245 p prm = QueryPartParam $ fmap qParamToQueryPart prm
@@ -289,8 +260,8 @@ instance (KnownSymbol sym,
289 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
260 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
290 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
261 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
291
262
292− clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =
263+ clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =
293− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
264+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
294
265
295 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }
266 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }
296 pname = symbolVal (Proxy :: Proxy sym)
267 pname = symbolVal (Proxy :: Proxy sym)
@@ -308,8 +279,8 @@ instance (KnownSymbol sym,
308 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
279 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
309 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
280 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
310
281
311− clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =
282+ clientWithRouteMulti Proxy q f' tag reqs baseurl flags =
312− clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts
283+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl
313
284
314 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
285 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
315 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
286 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
@@ -323,10 +294,10 @@ instance (SupportsServantReflex t m,
323 -> Event t tag
294 -> Event t tag
324 -> m (Event t (f (ReqResult tag ())))
295 -> m (Event t (f (ReqResult tag ())))
325
296
326− clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do
297+ clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do
327 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
298 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
328 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
299 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
329− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''
300+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync rawReqs''
330 return resps
301 return resps
331 where
302 where
332 aux (tag, Right r) = ResponseSuccess tag () r
303 aux (tag, Right r) = ResponseSuccess tag () r
@@ -342,8 +313,8 @@ instance (MimeRender ct a,
342 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
313 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
343 Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
314 Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
344
315
345− clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
316+ clientWithRouteMulti Proxy q f tag reqs baseurl bodies =
346− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
317+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
347 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
318 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
348 ctProxy = Proxy :: Proxy ct
319 ctProxy = Proxy :: Proxy ct
349 ctString = T.pack $ show $ contentType ctProxy
320 ctString = T.pack $ show $ contentType ctProxy
@@ -394,8 +365,8 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
394 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))
365 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))
395 -> ClientMulti t m api f tag
366 -> ClientMulti t m api f tag
396
367
397− clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =
368+ clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =
398− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts
369+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl
399 where
370 where
400 req' a r = r { authData = Just (constDyn a) }
371 req' a r = r { authData = Just (constDyn a) }
401 reqs' = liftA2 req' <$> authdatas <*> reqs
372 reqs' = liftA2 req' <$> authdatas <*> reqs
testdriver/test/Servant/ReflexSpec.hs+1−2
@@ -9,7 +9,6 @@ import qualified Data.Text as T
9import Data.Foldable
9import Data.Foldable
10import Test.WebDriver.Commands.Wait
10import Test.WebDriver.Commands.Wait
11import Test.Hspec.WebDriver
11import Test.Hspec.WebDriver
12−import Test.Hspec.WebDriver (chromeCaps)
13
12
14
13
15clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()
14clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()
@@ -29,7 +28,7 @@ spec :: Spec
29spec = do
28spec = do
30 describe "servant-reflex tests" $ do
29 describe "servant-reflex tests" $ do
31
30
32− session "test page" $ using [chromeCaps] $ do
31+ session "test page" $ using Chrome $ do
33
32
34 it "opens the page" $ runWD $
33 it "opens the page" $ runWD $
35 openPage "http://localhost:8000"
34 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 @@
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE PolyKinds #-}
4{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE TypeApplications #-}
6{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
8
7
9import Control.Monad.IO.Class (liftIO)
8import Control.Monad.IO.Class (liftIO)
10−import Control.Monad.Reader (reader)
11import Data.Aeson
9import Data.Aeson
12import Data.Bool
10import Data.Bool
13import Data.Char (toUpper)
11import Data.Char (toUpper)
14import qualified Data.List as L
12import qualified Data.List as L
15−import Data.Maybe (fromMaybe)
16import Data.Monoid
13import Data.Monoid
17import Data.Proxy
14import Data.Proxy
18import Data.Text hiding (head, length, map,
15import Data.Text hiding (head, length, map,
@@ -27,7 +24,6 @@ import Snap.Http.Server
27import Servant
24import Servant
28import Servant.Server
25import Servant.Server
29-- import Snap.Util.FileServe
26-- import Snap.Util.FileServe
30−import System.Environment (lookupEnv)
31import API
27import API
32import Snap
28import Snap
33
29
@@ -43,7 +39,7 @@ instance ToJSON Greet
43testApi :: Proxy API
39testApi :: Proxy API
44testApi = Proxy
40testApi = Proxy
45
41
46−data App = App { appStaticDir :: String }
42+data App = App
47
43
48-- Server-side handlers.
44-- Server-side handlers.
49--
45--
@@ -51,10 +47,8 @@ data App = App { appStaticDir :: String }
51-- that represents the API, are glued together using :<|>.
47-- that represents the API, are glued together using :<|>.
52--
48--
53-- Each handler runs in the 'ExceptT ServantErr IO' monad.
49-- Each handler runs in the 'ExceptT ServantErr IO' monad.
54−server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
50+server :: Server API (Handler App App)
55−server = return () :<|> return 100 :<|> sayhi :<|> dbl
51+server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> serveDirectory "static"
56− :<|> multi :<|> qna :<|> serveSecret
57− :<|> statics
58 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
52 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
59 sayhi nm greetings withGusto = case nm of
53 sayhi nm greetings withGusto = case nm of
60 Nothing -> return ("Sorry, who are you?" :: Text)
54 Nothing -> return ("Sorry, who are you?" :: Text)
@@ -75,27 +69,18 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl
75 putStrLn $ "qna got: " ++ show q
69 putStrLn $ "qna got: " ++ show q
76 T.putStrLn $ unQuestion q
70 T.putStrLn $ unQuestion q
77 return $ Answer $ unQuestion q
71 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
85
72
86-- Turn the server into a WAI app. 'serve' is provided by servant,
73-- Turn the server into a WAI app. 'serve' is provided by servant,
87-- more precisely by the Servant.Server module.
74-- more precisely by the Servant.Server module.
88test :: Handler App App ()
75test :: Handler App App ()
89−test = serveSnapWithContext testApi
76+test = serveSnap testApi server
90− (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server
91
77
92initApp :: SnapletInit App App
78initApp :: SnapletInit App App
93initApp = makeSnaplet "myapp" "example" Nothing $ do
79initApp = makeSnaplet "myapp" "example" Nothing $ do
94− staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")
95 addRoutes [("", test)
80 addRoutes [("", test)
96 ,("", serveDirectory "static")
81 ,("", serveDirectory "static")
97 ]
82 ]
98− return (App staticDir)
83+ return App
99
84
100-- Put this all to work!
85-- Put this all to work!
101main :: IO ()
86main :: 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
19 main-is: Main.hs
19 main-is: Main.hs
20 -- other-modules:
20 -- other-modules:
21 -- other-extensions:
21 -- other-extensions:
22− build-depends: aeson >= 0.9 && < 1.5
22+ build-depends: aeson >= 0.9 && < 1.1
23− , base >=4.8 && < 5
23+ , base >=4.8 && <4.10
24− , mtl
25− , snap >= 1.0 && < 1.2
24+ , snap >= 1.0 && < 1.1
26− , snap-server >= 1.0 && < 1.2
25+ , snap-server >= 1.0 && < 1.1
27 , snap-core >= 1.0 && < 1.1
26 , snap-core >= 1.0 && < 1.1
28− , servant >= 0.16 && < 0.18
27+ , servant >= 0.8 && < 0.11
29− , servant-snap >= 0.8 && < 0.9
28+ , servant-snap >= 0.7.2 && < 0.8
30− , text >= 1.0 && < 1.3
29+ , text >= 1.2 && < 1.3
31 -- hs-source-dirs:
30 -- hs-source-dirs:
32 default-language: Haskell2010
31 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− }