git.iko.soy/servant-reflex
on master help sign in
swap
f76dbeb78 ahead, 2 behind
.gitignore+2−1
since splitsnapshots
unifiedsplit
@@ -6,5 +6,6 @@ log
6*.webapp
6*.webapp
7*.stats
7*.stats
8out
8out
9−reflex-platform
10/.stack-work/
9/.stack-work/
10+TAGS
11+dist-newstyle
.gitmodules−15
@@ -1,15 +0,0 @@
1−[submodule "deps/reflex-dom"]
2− path = deps/reflex-dom
3− url = https://github.com/reflex-frp/reflex-dom.git
4−[submodule "deps/reflex"]
5− path = deps/reflex
6− url = https://github.com/reflex-frp/reflex.git
7−[submodule "deps/http-api-data"]
8− path = deps/http-api-data
9− url = https://github.com/fizruk/http-api-data
10−[submodule "deps/servant"]
11− path = deps/servant
12− url = https://github.com/haskell-servant/servant
13−[submodule "deps/servant-snap"]
14− path = deps/servant-snap
15− url = https://github.com/haskell-servant/servant-snap
.travis.yml+12−57
@@ -1,62 +1,17 @@
1−sudo: required
1+language: nix
2−
2+nix: 2.3.6
3−before_cache:
3+sudo: require
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−
21
4
22before_install:
5before_install:
23− - unset CC
6+ - sudo cp -rT $TRAVIS_BUILD_DIR/nix /etc/nix
24− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
25− - git submodule update --init --recursive
26
7
27−install:
8+before_script:
28− - cabal --version
9+ - sudo systemctl restart nix-daemon.service
29− - BENCH=${BENCH---enable-benchmarks}
10+ - git config --global user.email "travis-ci@example.com"
30− - TEST=${TEST---enable-tests}
11+ - git config --global user.name "Travis-CI"
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− - git clone https://github.com/reflex-frp/reflex-platform
39− - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
40− - reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal configure -fExample && cabal build"
41− - reflex-platform/work-on ghc ./testdriver --command "cd testdriver && cabal configure && cabal build"
42− - cd testserver && dist/build/back/back -p 8000 &
43− - sleep 3
44− - phantomjs --webdriver=127.0.0.1:4444 &
45− - sleep 3
46
12
47script:
13script:
48− - git config --global user.email "travis-ci@example.com"
14+ - nix-build travis.nix -A build
49− - git config --global user.name "Travis-CI"
15+ - nix-build travis.nix -A buildGhc
50− - ./build.sh
16+ - nix-build travis.nix -A testserver
51− # - testdriver/dist/build/spec/spec
17+ - nix-build travis.nix -A testresults
52−
53−cache:
54− directories:
55− - /nix
56− - $HOME/.cabal/packages
57− - $HOME/.cabal/store
58−
59−env:
60− global:
61− - ENCRYPTION_LABEL: "3c89d919c82e"
62− - COMMIT_AUTHOR_EMAIL: "imalsogreg@gmail.com"
changelog.md → ChangeLog.mdrenamed+28
@@ -1,3 +1,31 @@
1+0.3.5
2+-----
3+
4+ - Require reflex-dom-core >= 0.6 (for internal handling of case-insensitive headers)
5+ - Require servant >= 0.16
6+ - Eliminate use of deprecated widgets from reflex-dom-core
7+ - Bump the version of reflex-platform used in nix-shell and test suite
8+
9+0.3.4
10+-----
11+
12+Add selenium-based test suite
13+
14+0.3.3
15+-----
16+
17+- Fix encoding issue: Explicitly escape reserved characters from path pieces and query parameters
18+
19+
20+0.3.2
21+-----
22+
23+- **Addition of 'Servant.Reflex.Common.Req.ClientOpts'** which
24+allows the users to apply a final adjustment to Requests before
25+thery are sent, such as setting the 'withCredentials' flag
26+or print the Request to the console for debugging
27+[PR #47](https://github.com/imalsogreg/servant-reflex/pull/47)
28+
10.3
290.3
2---
30---
3
31
README.md+70−33
@@ -4,14 +4,19 @@
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 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.
7+Keeping your frontend in sync with your API server can be difficult - when the
8+API changes its input parameters or return type, XHR requests from the
9+frontend will fail at runtime. If your API is defined by
10+[servant](https://haskell-servant.readthedocs.io) combinators, you can use
11+`servant-reflex` to share the API between the server and frontend.
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.
12+Syncronization between is checked at compile time, and rather than building XHR
9−
13+requests by hand, API endpoints are available behind `reflex`'s FRP semantics.
10
14
11
15
12## Example
16## Example
13
17
14−We have a webservice API defined in a module where both the server (compiled with ghc) and the frontend (compiled with ghcjs) can see it:
18+We have a webservice API defined in a module where both the server (compiled
19+with ghc) and the frontend (compiled with ghcjs) can see it:
15
20
16```haskell
21```haskell
17type API = "getint" :> Get '[JSON] Int
22type API = "getint" :> Get '[JSON] Int
@@ -24,7 +29,8 @@ type API = "getint" :> Get '[JSON] Int
24 :<|> Raw
29 :<|> Raw
25```
30```
26
31
27−`servant-reflex` then computes client functions that can query the API through an `XhrRequest`.
32+`servant-reflex` then computes client functions that can query the API through
33+an `XhrRequest`.
28
34
29```haskell
35```haskell
30
36
@@ -37,7 +43,16 @@ type API = "getint" :> Get '[JSON] Int
37 (constDyn (BasePath "/"))
43 (constDyn (BasePath "/"))
38```
44```
39
45
40−These client functions are computed from your API type. They manage serialization, XhrRequest generation, and deserialization for you. `a` parameters used in URL captures become `Dynamic t (Either Text a)` parameters in the client functions. 'QueryFlag', 'QueryParams' and 'QueryParam' API parameters map to 'Dynamic t Bool', 'Dynamic t [a]' and 'Dynamic t (QParam a)' respectively. These parameters to the client function are wrapped with failure possibility to allow you to indicate at any time whether input validation for that parameter has failed and no valid XHR request can be generated. The final parameter is a trigger event for the XHR request. The return value `Event t (ReqResult a)` contains responses from the API server.
46+These client functions are computed from your API type. They manage
47+serialization, `XhrRequest` generation, and deserialization for you. `a`
48+parameters used in URL captures become `Dynamic t (Either Text a)` parameters
49+in the client functions. `QueryFlag`, `QueryParams` and `QueryParam` API
50+parameters map to `Dynamic t Bool`, `Dynamic t [a]` and `Dynamic t (QParam a)`
51+respectively. These parameters to the client function are wrapped with failure
52+possibility to allow you to indicate at any time whether input validation for
53+that parameter has failed and no valid XHR request can be generated. The final
54+parameter is a trigger event for the XHR request. The return value
55+`Event t (ReqResult a)` contains responses from the API server.
41
56
42```haskell
57```haskell
43 -- No need to write these functions. servant-reflex creates them for you!
58 -- No need to write these functions. servant-reflex creates them for you!
@@ -62,7 +77,13 @@ These client functions are computed from your API type. They manage serializatio
62 -> m (Event t (ReqResult () Double))
77 -> m (Event t (ReqResult () Double))
63```
78```
64
79
80+`ReqResult tag a` is defined in
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:
81+[`Servant.Common.Req`](https://github.com/imalsogreg/servant-reflex/blob/6d866e338edb9bf6fd8f8d5083ff0187b4d8c0d2/src/Servant/Common/Req.hs#L40-L42)
82+and reports whether or not your request was sent (if validation fails, the
83+request won't be sent), and how decoding of the response went. You can pattern
84+match on these explicitly, but usually you'll want to use
85+`fmapMaybe :: (a -> Maybe b) -> Event t a -> Event t b` and one of the
86+elimination functions to filter the result type you care about, like this:
66
87
67```haskell
88```haskell
68 -- ... continued ...
89 -- ... continued ...
@@ -80,7 +101,8 @@ These client functions are computed from your API type. They manage serializatio
80 dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])
101 dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])
81```
102```
82
103
83−This example builds some input fields to enter API parameters, buttons to trigger the API calls, and text elements to show the results:
104+This example builds some input fields to enter API parameters, buttons to
105+trigger the API calls, and text elements to show the results:
84
106
85```haskell
107```haskell
86 elClass "div" "int-demo" $ do
108 elClass "div" "int-demo" $ do
@@ -103,47 +125,53 @@ This example builds some input fields to enter API parameters, buttons to trigge
103 display =<< holdDyn Nothing outputDouble
125 display =<< holdDyn Nothing outputDouble
104```
126```
105
127
106−For a great introduction to recative DOM building, see the [README](https://github.com/reflex-frp/reflex-platform) for the `reflex-platform`. For more information about servant, see their [documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to the respective authors of these fabulous libraries.
128+For a great introduction to recative DOM building, see the
129+[README](https://github.com/reflex-frp/reflex-platform) for the
130+`reflex-platform`. For more information about servant, see their
131+[documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to
132+the respective authors of these fabulous libraries.
107
133
108
134
109## Building the library and test server
135## Building the library and test server
110
136
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
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:
141+([testserver/](https://github.com/imalsogreg/servant-reflex/tree/master/testserver).
112−
142+To build these components, we will use the nix packages for the testserver. It
113−
143+manages the frontend build as a dependency.
114−First build the library:
115
144
116```
145```
117−git submodule update --init --recursive
146+nix build -f travis.nix testserver -o server
118−./build.sh
119```
147```
120
148
121−Then build the test server:
149+Point it at the static directory and run it:
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:
131
150
132```
151```
133−cd testserver
152+STATIC_DIR=server/static server/back -p 8000
134−dist/build/back/back -p 8001
135```
153```
136
154
137−And simply browse to `localhost:8001`
155+Browse to [http://localhost:8000](http://localhost:8000) and click around.
156+Open the firefox or chrome developer tools and examine the XHR activity
157+under the Network tab.
138
158
139−**For a larger example of a project that shares types between backend and frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
159+**For a larger example of a project that shares types between backend and
160+frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
140
161
141
162
142## Tagging requests
163## Tagging requests
143
164
165+The input and the return type of a client function like `getDouble` are both
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.
166+event streams. The individual input events and responses occur at different
167+times and aren't automatically paired up, but you can recover the
168+relationship by tagging the requests.
145
169
146−So far we have used an `Event t ()` to trigger sending a request. If we choose e.g. `Double` for the third `Proxy` argument to `client`, then `Event t Double` will be used to trigger requests, and each `ReqResult` will carry the tag of its request. Imagine we wanted to display not just the last "double" from `doubleIt`, but a whole table of valid inputs and their doubled responses:
170+So far we have used an `Event t ()` to trigger sending a request. If we choose
171+e.g. `Double` for the third `Proxy` argument to `client`, then `Event t Double`
172+will be used to trigger requests, and each `ReqResult` will carry the tag of
173+its request. Imagine we wanted to display not just the last "double" from
174+`doubleIt`, but a whole table of valid inputs and their doubled responses:
147
175
148```haskell
176```haskell
149 ...
177 ...
@@ -173,7 +201,10 @@ So far we have used an `Event t ()` to trigger sending a request. If we choose e
173
201
174## Simultaneous requests
202## Simultaneous requests
175
203
176−'Servant.Reflex.Multi' provides an alternative client-generation function called 'clientA' (client applicative). Choose a container type that has both `Applicative` and `Traversable` instances, and pass it to `clientA` through another 'Proxy'. Our `sayHi` client function will then have this type:
204+`Servant.Reflex.Multi` provides an alternative client-generation function
205+called `clientA` (client applicative). Choose a container type that has both
206+`Applicative` and `Traversable` instances, and pass it to `clientA` through
207+another `Proxy`. Our `sayHi` client function will then have this type:
177
208
178```haskell
209```haskell
179sayHi
210sayHi
@@ -184,4 +215,10 @@ sayHi
184 -> m (Event t (f (ReqResult tag Text)))
215 -> m (Event t (f (ReqResult tag Text)))
185```
216```
186
217
187−The dynamic params are each wrapped in `f`. For every firing of the trigger event `tag`, all of these parameters will be combined according to `f`'s applicative instance (when `f` is `[]`, you will get all combinations of all parameters taken together as a request; when `f` is 'ZipList', the Nth elemens of each parameters list will be taken together as a request). Using this interface, you can trigger many XHR's from a single event occurence, and expect the responses to be structured the same way as the requests.
218+The dynamic params are each wrapped in `f`. For every firing of the trigger
219+event `tag`, all of these parameters will be combined according to `f`'s
220+`Applicative` instance (when `f` is `[]`, you will get all combinations of
221+all parameters taken together as a request; when `f` is `ZipList`, the Nth
222+elemens of each parameters list will be taken together as a request). Using
223+this interface, you can trigger many XHR's from a single event occurence, and
224+expect the responses to be structured the same way as the requests.
build.shdeleted−3
@@ -1,3 +0,0 @@
1−#!/usr/bin/env bash
2−
3−reflex-platform/work-on ./overrides.nix ./. --run "cabal configure --ghcjs && cabal build && exec/toSite.sh"
default.nixnew file+21
@@ -0,0 +1,21 @@
1+{ mkDerivation, base, bytestring, case-insensitive, containers
2+, data-default, exceptions, ghcjs-dom, http-api-data, http-media
3+, jsaddle, mtl, network-uri, reflex, reflex-dom, reflex-dom-core
4+, safe, servant, servant-auth, stdenv, string-conversions, text
5+, transformers
6+}:
7+mkDerivation {
8+ pname = "servant-reflex";
9+ version = "0.3.6";
10+ src = ./.;
11+ isLibrary = true;
12+ isExecutable = true;
13+ libraryHaskellDepends = [
14+ base bytestring case-insensitive containers data-default exceptions
15+ ghcjs-dom http-api-data http-media jsaddle mtl network-uri reflex
16+ reflex-dom reflex-dom-core safe servant servant-auth string-conversions
17+ text transformers
18+ ];
19+ description = "servant API generator for reflex apps";
20+ license = stdenv.lib.licenses.bsd3;
21+}
deps/http-api-datadeleted−1

Submodule changed.

deps/reflexdeleted−1

Submodule changed.

deps/reflex-domdeleted−1

Submodule changed.

deps/servantdeleted−1

Submodule changed.

deps/servant-snapdeleted−1

Submodule changed.

exec/API.hs+1
@@ -40,6 +40,7 @@ type API = "getunit" :> Get '[JSON] ()
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
43 :<|> Raw
44 :<|> Raw
44
45
45type GET = Get '[JSON] ()
46type GET = Get '[JSON] ()
exec/Example.hs+45−25
@@ -1,3 +1,4 @@
1+{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
@@ -14,12 +15,14 @@ import Control.Monad.Fix (MonadFix)
14import Data.Monoid (First(..), (<>))
15import Data.Monoid (First(..), (<>))
15import Data.Text (Text)
16import Data.Text (Text)
16import qualified Data.Text as T
17import qualified Data.Text as T
18+import qualified Data.Text.Encoding as T
17import GHC.TypeLits
19import GHC.TypeLits
18import Servant.API
20import Servant.API
19import API
21import API
20import Data.Proxy
22import Data.Proxy
21import Text.Read (readMaybe)
23import Text.Read (readMaybe)
22−import Reflex.Dom
24+import Reflex.Dom.Core hiding (run, mainWidget)
25+import Reflex.Dom (mainWidget)
23------------------------------------------------------------------------------
26------------------------------------------------------------------------------
24import Servant.Reflex
27import Servant.Reflex
25import Servant.Reflex.Multi
28import Servant.Reflex.Multi
@@ -30,7 +33,6 @@ api = Proxy
30
33
31main :: IO ()
34main :: IO ()
32main = mainWidget $ do
35main = mainWidget $ do
33− el "h1" $ text "Wowzers!"
34 divClass "example-base" run
36 divClass "example-base" run
35 divClass "example-multi" runMulti
37 divClass "example-multi" runMulti
36
38
@@ -44,7 +46,7 @@ runMulti :: forall t m. (SupportsServantReflex t m,
44runMulti = do
46runMulti = do
45 url <- baseUrlWidget
47 url <- baseUrlWidget
46 el "br" blank
48 el "br" blank
47− let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ ) =
49+ let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =
48 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
50 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
49
51
50 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
52 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
@@ -65,11 +67,14 @@ runMulti = do
65 grts <- fmap (fmap T.words . value) $ divClass "" $ do
67 grts <- fmap (fmap T.words . value) $ divClass "" $ do
66 text "Greetings"
68 text "Greetings"
67 textInput def
69 textInput def
68− gust <- fmap value $ divClass "gusto-input" $ checkbox False def
70+ gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
69 b <- button "Go"
71 b <- button "Go"
70− r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) grts) (constDyn [True, False]) (1 <$ b)
72+ r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)
73+ (constDyn [True, False]) (1 <$ b)
74+
75+ dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .
76+ fmap reqSuccess <$> r')
71
77
72− dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes . fmap reqSuccess <$> r')
73
78
74 return ()
79 return ()
75
80
@@ -92,8 +97,11 @@ run = mdo
92 el "br" (return ())
97 el "br" (return ())
93
98
94 -- Name the computed API client functions
99 -- Name the computed API client functions
100+ let tweakRequest = ClientOptions $ \r -> do
101+ return $ r & withCredentials .~ True
95− let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> doRaw) =
102+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl
103+ :<|> multi :<|> qna :<|> secret :<|> doRaw) =
96− client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url
104+ clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest
97
105
98 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
106 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
99
107
@@ -104,11 +112,11 @@ run = mdo
104 unitResponse <- getUnit $ tag (current reqCount) unitBtn
112 unitResponse <- getUnit $ tag (current reqCount) unitBtn
105 intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn
113 intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn
106
114
107− score <- foldDyn (+) 0 (fmapMaybe reqSuccess intResponse)
115+ score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))
108
116
109− r <- holdDyn "Waiting" $ showXhrResponse <$>
117+ r <- holdDyn "Waiting" $ fmap showXhrResponse $
110− leftmost [fmapMaybe response unitResponse
118+ leftmost [fmapMaybe response (unitResponse)
111− ,fmapMaybe response intResponse
119+ ,fmapMaybe response (intResponse)
112 ]
120 ]
113 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score
121 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score
114 return (unitBtn, intBtn)
122 return (unitBtn, intBtn)
@@ -117,14 +125,14 @@ run = mdo
117
125
118 text "Name"
126 text "Name"
119 el "br" $ return ()
127 el "br" $ return ()
120− inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ textInput def
128+ inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ (textInput def)
121 let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp
129 let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp
122 el "br" $ return ()
130 el "br" $ return ()
123
131
124 text "Greetings (space-separated)"
132 text "Greetings (space-separated)"
125 el "br" $ return ()
133 el "br" $ return ()
126 greetings <- fmap (fmap T.words . value) $
134 greetings <- fmap (fmap T.words . value) $
127− divClass "greetings-input" $ textInput def
135+ divClass "greetings-input" $ (textInput def)
128
136
129 el "br" $ return ()
137 el "br" $ return ()
130
138
@@ -136,23 +144,23 @@ run = mdo
136
144
137 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)
145 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)
138 divClass "greeting-response" $ dynText =<<
146 divClass "greeting-response" $ dynText =<<
139− holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess resp
147+ holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)
140− , fmapMaybe reqFailure resp])
148+ , fmapMaybe reqFailure (resp)])
141 return sayHiClicks
149 return sayHiClicks
142
150
143 dblBtn <- elClass "div" "demo-group" $ do
151 dblBtn <- elClass "div" "demo-group" $ do
144 text "A Double to double"
152 text "A Double to double"
145 el "br" $ return ()
153 el "br" $ return ()
146 dblinp <- fmap value $ divClass "double-input" $ textInput def
154 dblinp <- fmap value $ divClass "double-input" $ textInput def
147− dblBtn <- divClass "double-button" $ button "Double it"
155+ (dblBtn) <- divClass "double-button" $ button "Double it"
148− dblResp <- dbl ((note "read failure" . readMaybe . T.unpack) <$>
156+ dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
149 dblinp) (tag (current reqCount) dblBtn)
157 dblinp) (tag (current reqCount) dblBtn)
150 divClass "double-errors" $ dynText =<<
158 divClass "double-errors" $ dynText =<<
151− holdDyn "(no errors)" (fmapMaybe reqFailure dblResp)
159+ holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))
152 el "br" (return ())
160 el "br" (return ())
153 divClass "double-result" $ el "p" $ dynText =<<
161 divClass "double-result" $ el "p" $ dynText =<<
154− holdDyn "No number yet" (tShow <$>
162+ holdDyn "No number yet" (fmap tShow $
155− fmapMaybe reqSuccess dblResp)
163+ fmapMaybe reqSuccess (dblResp))
156 return dblBtn
164 return dblBtn
157
165
158 mpGo <- elClass "div" "demo-group" $ do
166 mpGo <- elClass "div" "demo-group" $ do
@@ -160,9 +168,9 @@ run = mdo
160 b <- value <$> checkbox False def
168 b <- value <$> checkbox False def
161 mpGo <- button "Test"
169 mpGo <- button "Test"
162 multiResp <- multi b (tag (current reqCount) mpGo)
170 multiResp <- multi b (tag (current reqCount) mpGo)
163− dynText =<< holdDyn "No res yet" (tShow <$>
171+ dynText =<< holdDyn "No res yet" (fmap tShow $
164− fmapMaybe reqSuccess
172+ fmapMaybe reqSuccess $
165− multiResp)
173+ (multiResp))
166 return mpGo
174 return mpGo
167
175
168 return ()
176 return ()
@@ -172,12 +180,24 @@ run = mdo
172 elClass "div" "demo-group" $ do
180 elClass "div" "demo-group" $ do
173 text "JSON Unicode encoding test"
181 text "JSON Unicode encoding test"
174 txt <- value <$> textInput def
182 txt <- value <$> textInput def
175− ev <- (1 <$) <$> button "Question"
183+ ev <- fmap (1 <$) $ button "Question"
176 let dQ = Right . Question <$> traceDyn "will send: " txt
184 let dQ = Right . Question <$> traceDyn "will send: " txt
177 rr <- qna dQ ev
185 rr <- qna dQ ev
178 el "p" $
186 el "p" $
179 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
187 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
180
188
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+
181showXhrResponse :: XhrResponse -> Text
201showXhrResponse :: XhrResponse -> Text
182showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
183 T.unlines ["stat: " <> tShow stat
203 T.unlines ["stat: " <> tShow stat
nix/nix.confnew file+3
@@ -0,0 +1,3 @@
1+substituters = https://cache.nixos.org/ https://nixcache.reflex-frp.org/
2+trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=
3+trusted-users = travis
nix/reflex-platform.nixnew file+7
@@ -0,0 +1,7 @@
1+let
2+ rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;
3+in import (builtins.fetchTarball
4+ {
5+ url = "https://github.com/reflex-frp/reflex-platform/archive/${rev}.tar.gz";
6+ sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;
7+ }) {}
nix/servant-snap.nixnew file+7
@@ -0,0 +1,7 @@
1+# Servant-snap is marked broken in nixpkgs
2+{ nixpkgs ? import <nixpkgs> {}}: self: super:
3+self.callCabal2nix "servant-snap" (nixpkgs.fetchgit {
4+ url = "https://github.com/haskell-servant/servant-snap.git";
5+ rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";
6+ sha256 = "sha256-fzzQGwG8Ko72OO/kwLMG52eNZSt3F2dxhNgM9gaO4yQ=";
7+}) {}
nix/testresults.nixnew file+17
@@ -0,0 +1,17 @@
1+{ curl, reflexPlatform, testdriver, testserver, phantomjs }:
2+
3+reflexPlatform.nixpkgs.pkgs.runCommand "runWebdriveTest.sh" {} ''
4+ echo About to phantom
5+ ${phantomjs}/bin/phantomjs --webdriver=127.0.0.1:4444 &
6+ sleep 3
7+ echo About to Server
8+ STATIC_DIR=${testserver}/static ${testserver}/back -q --no-access-log --no-error-log -p 8000 &
9+ sleep 3
10+ ${curl}/bin/curl localhost:8000
11+ ${curl}/bin/curl localhost:8000/runmain.js
12+ echo About to testdrive
13+ ${testdriver}/bin/spec > $out 2>&1
14+ echo Done
15+ trap "exit" INT TERM
16+ trap "kill 0" EXIT
17+ ''
nix/testserver.nixnew file+9
@@ -0,0 +1,9 @@
1+servant-reflex: self: super:
2+
3+(self.callCabal2nix "testserver" ../testserver {}).overrideDerivation (drv: {
4+ postInstall = ''
5+ cp dist/build/back/back $out/back
6+ mkdir $out/static
7+ cp ${servant-reflex}/bin/example.jsexe/* $out/static/
8+ '';
9+})
overrides-ghc.nixdeleted−19
@@ -1,19 +0,0 @@
1−{ reflex-platform, ... }:
2−let
3− dc = reflex-platform.lib.dontCheck;
4− c2n = reflex-platform.cabal2nixResult;
5−in reflex-platform.ghc.override {
6− overrides = self: super: {
7− servant-snap = dc (self.callPackage (c2n deps/servant-snap) {});
8− snap = dc (self.callPackage (c2n deps/servant-snap/deps/snap) {});
9− snap-server = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-server) {});
10− io-streams = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams) {});
11− io-streams-haproxy = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});
12− heist = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});
13− xmlhtml = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
14− snap-core = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-core) {});
15− servant = dc (self.callPackage (c2n deps/servant/servant) {});
16− Glob = dc super.Glob;
17− http-api-data = dc (self.callPackage (c2n deps/http-api-data) {});
18− };
19−}
overrides.nixdeleted−13
@@ -1,13 +0,0 @@
1−{ reflex-platform, ... }:
2−let
3−
4− dc = reflex-platform.lib.dontCheck;
5− c2n = reflex-platform.cabal2nixResult;
6−
7−in
8−reflex-platform.ghcjs.override {
9− overrides = self: super: {
10− servant = dc (self.callPackage (c2n deps/servant/servant) {});
11− http-api-data = dc (self.callPackage (c2n deps/http-api-data) {});
12− };
13−}
servant-reflex.cabal+28−19
@@ -1,8 +1,8 @@
1Name: servant-reflex
1Name: servant-reflex
2−Version: 0.3
2+Version: 0.3.6
3−Synopsis: Servant reflex API generator
3+Synopsis: servant API generator for reflex apps
4−Description: Servant reflex API generator
4+Description: Generate reflex-compatible client functions from servant API descriptions
5−License: AllRightsReserved
5+License: BSD3
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,35 @@ Flag Example
17
17
18library
18library
19 exposed-modules:
19 exposed-modules:
20− Servant.Reflex
21− Servant.Reflex.Multi
22−
23− other-modules:
24 Servant.Common.BaseUrl
20 Servant.Common.BaseUrl
25 Servant.Common.Req
21 Servant.Common.Req
22+ Servant.Reflex
23+ Servant.Reflex.Multi
26
24
27 hs-source-dirs: src
25 hs-source-dirs: src
28 build-depends:
26 build-depends:
29− base >= 4.8 && < 4.10,
27+ base >= 4.8 && < 5,
30 bytestring >= 0.10 && < 0.11,
28 bytestring >= 0.10 && < 0.11,
31 case-insensitive >= 1.2.0.4 && < 1.3,
29 case-insensitive >= 1.2.0.4 && < 1.3,
32− containers >= 0.5.6 && < 0.6,
30+ containers >= 0.5.6 && < 0.7,
33 data-default >= 0.5 && < 0.8,
31 data-default >= 0.5 && < 0.8,
34− exceptions >= 0.8 && < 0.9,
32+ exceptions >= 0.8 && < 0.11,
35− ghcjs-dom >= 0.2 && < 0.3,
33+ ghcjs-dom >= 0.2 && < 0.10,
36− http-api-data >= 0.2 && < 0.4,
34+ http-api-data >= 0.3.6 && < 0.5,
37− http-media >= 0.6 && < 0.7,
35+ http-media >= 0.6 && < 0.9,
36+ jsaddle >= 0.8 && < 0.10,
38 mtl >= 2.2.1 && < 2.3,
37 mtl >= 2.2.1 && < 2.3,
39 network-uri >= 2.6 && < 2.7,
38 network-uri >= 2.6 && < 2.7,
40− reflex >= 0.5 && < 0.6,
39+ reflex >= 0.5 && < 0.9,
41− reflex-dom == 0.4 && < 0.5,
40+ reflex-dom-core >= 0.6 && < 0.7,
42 safe >= 0.3.9 && < 0.4,
41 safe >= 0.3.9 && < 0.4,
43− servant >= 0.8 && < 0.11,
42+ servant >= 0.16 && < 0.18,
43+ servant-auth >= 0.2.1 && < 0.4,
44 string-conversions >= 0.4 && < 0.5,
44 string-conversions >= 0.4 && < 0.5,
45 text >= 1.2 && < 1.3,
45 text >= 1.2 && < 1.3,
46 transformers >= 0.4 && < 0.6
46 transformers >= 0.4 && < 0.6
47
47
48− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
48+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
49
49
50 default-language: Haskell2010
50 default-language: Haskell2010
51
51
@@ -54,7 +54,16 @@ executable example
54 buildable: True
54 buildable: True
55 else
55 else
56 buildable: False
56 buildable: False
57− build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text
57+ build-depends:
58+ aeson,
59+ reflex,
60+ servant-reflex,
61+ base,
62+ scientific,
63+ servant,
64+ reflex-dom,
65+ reflex-dom-core,
66+ text
58 default-language: Haskell2010
67 default-language: Haskell2010
59 main-is: Example.hs
68 main-is: Example.hs
60 other-modules: API
69 other-modules: API
shell.nixnew file+1
@@ -0,0 +1 @@
1+(import ./travis.nix {nativeCompiler = "ghc";}).ghcPkgs.servant-reflex.env
src/Servant/Common/BaseUrl.hs+8−8
@@ -20,18 +20,19 @@ module Servant.Common.BaseUrl (
20) where
20) where
21
21
22import Control.Monad (join)
22import Control.Monad (join)
23−import Control.Monad.IO.Class (MonadIO)
23+-- import Control.Monad.IO.Class (MonadIO)
24import Control.Monad.Fix (MonadFix)
24import Control.Monad.Fix (MonadFix)
25import Data.Monoid ((<>))
25import Data.Monoid ((<>))
26import Data.Text (Text)
26import Data.Text (Text)
27import qualified Data.Text as T
27import qualified Data.Text as T
28import GHC.Generics
28import GHC.Generics
29+import Language.Javascript.JSaddle.Monad (MonadJSM)
29import Reflex
30import Reflex
30−import Reflex.Dom
31+import Reflex.Dom.Core
31import Text.Read
32import Text.Read
32
33
33
34
34−type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadIO (Performable m))
35+type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadJSM (Performable m))
35
36
36-- | URI scheme to use
37-- | URI scheme to use
37data Scheme =
38data Scheme =
@@ -84,15 +85,14 @@ baseUrlWidget = elClass "div" "base-url" $ do
84 where pathWidget :: m (Dynamic t BaseUrl)
85 where pathWidget :: m (Dynamic t BaseUrl)
85 pathWidget = do
86 pathWidget = do
86 text "Url base path"
87 text "Url base path"
87− t <- textInput (def {_textInputConfig_attributes =
88+ t <- inputElement def
88− constDyn ("placeholder" =: "/a/b")})
89 return $ BasePath <$> value t
89 return $ BasePath <$> value t
90 fullUrlWidget :: m (Dynamic t BaseUrl)
90 fullUrlWidget :: m (Dynamic t BaseUrl)
91 fullUrlWidget = do
91 fullUrlWidget = do
92 schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def
92 schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def
93− srv <- textInput def {_textInputConfig_attributes = constDyn $ "placeholder" =: "example.com"}
93+ srv <- inputElement def
94 text ":"
94 text ":"
95− prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}
95+ prt <- inputElement def
96 port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))
96 port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))
97− path <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "a/b" }
97+ path <- inputElement def
98 return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path
98 return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path
src/Servant/Common/Req.hs+106−91
@@ -4,18 +4,22 @@
4{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TupleSections #-}
9{-# LANGUAGE TupleSections #-}
9
10
10module Servant.Common.Req where
11module Servant.Common.Req where
11
12
12-------------------------------------------------------------------------------
13-------------------------------------------------------------------------------
13−import Control.Concurrent
14import Control.Applicative (liftA2, liftA3)
14import Control.Applicative (liftA2, liftA3)
15+import Control.Arrow ((&&&))
16+import Control.Concurrent
15import Control.Monad (join)
17import Control.Monad (join)
16import Control.Monad.IO.Class (MonadIO, liftIO)
18import Control.Monad.IO.Class (MonadIO, liftIO)
17import Data.Bifunctor (first)
19import Data.Bifunctor (first)
20+import qualified Data.ByteString.Builder as Builder
18import qualified Data.ByteString.Lazy.Char8 as BL
21import qualified Data.ByteString.Lazy.Char8 as BL
22+import Data.ByteString (ByteString)
19import qualified Data.Map as Map
23import qualified Data.Map as Map
20import Data.Maybe (catMaybes, fromMaybe)
24import Data.Maybe (catMaybes, fromMaybe)
21import Data.Functor.Compose
25import Data.Functor.Compose
@@ -25,7 +29,9 @@ import Data.Text (Text)
25import qualified Data.Text as T
29import qualified Data.Text as T
26import qualified Data.Text.Encoding as TE
30import qualified Data.Text.Encoding as TE
27import Data.Traversable (forM)
31import Data.Traversable (forM)
32+import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
33+import qualified Network.URI as N
28−import Reflex.Dom hiding (tag)
34+import Reflex.Dom.Core hiding (tag)
29import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
35import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
30 SupportsServantReflex)
36 SupportsServantReflex)
31import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
37import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
@@ -46,6 +52,23 @@ data ReqResult tag a
46 -- ^ A failure to construct the request tagged with 'tag' at trigger time
52 -- ^ A failure to construct the request tagged with 'tag' at trigger time
47 deriving (Functor)
53 deriving (Functor)
48
54
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'
49
72
50------------------------------------------------------------------------------
73------------------------------------------------------------------------------
51-- | Simple filter/accessor for successful responses, when you want to
74-- | Simple filter/accessor for successful responses, when you want to
@@ -70,6 +93,13 @@ reqFailure (ResponseFailure _ s _) = Just s
70reqFailure (RequestFailure _ s) = Just s
93reqFailure (RequestFailure _ s) = Just s
71reqFailure _ = Nothing
94reqFailure _ = Nothing
72
95
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+
73
103
74------------------------------------------------------------------------------
104------------------------------------------------------------------------------
75-- | Simple filter/accessor for the raw XHR response
105-- | Simple filter/accessor for the raw XHR response
@@ -137,7 +167,7 @@ reqToReflexRequest
137 => Text
167 => Text
138 -> Dynamic t BaseUrl
168 -> Dynamic t BaseUrl
139 -> Req t
169 -> Req t
140− -> (Dynamic t (Either Text (XhrRequest XhrPayload)))
170+ -> Dynamic t (Either Text (XhrRequest XhrPayload))
141reqToReflexRequest reqMeth reqHost req =
171reqToReflexRequest reqMeth reqHost req =
142 let t :: Dynamic t [Either Text Text]
172 let t :: Dynamic t [Either Text Text]
143 t = sequence $ reverse $ reqPathParts req
173 t = sequence $ reverse $ reqPathParts req
@@ -149,18 +179,22 @@ reqToReflexRequest reqMeth reqHost req =
149 urlParts = fmap sequence t
179 urlParts = fmap sequence t
150
180
151 urlPath :: Dynamic t (Either Text Text)
181 urlPath :: Dynamic t (Either Text Text)
152− urlPath = (fmap.fmap) (T.intercalate "/") urlParts
182+ urlPath = (fmap.fmap)
183+ (T.intercalate "/" . fmap escape)
184+ urlParts
153
185
154 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
186 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
155 queryPartString (pName, qp) = case qp of
187 queryPartString (pName, qp) = case qp of
156 QueryPartParam p -> ffor p $ \case
188 QueryPartParam p -> ffor p $ \case
157 Left e -> Just (Left e)
189 Left e -> Just (Left e)
158− Right (Just a) -> Just (Right $ pName <> "=" <> a)
190+ Right (Just a) -> Just (Right $ pName <> "=" <> escape a)
159 Right Nothing -> Nothing
191 Right Nothing -> Nothing
160 QueryPartParams ps -> ffor ps $ \pStrings ->
192 QueryPartParams ps -> ffor ps $ \pStrings ->
161 if null pStrings
193 if null pStrings
162 then Nothing
194 then Nothing
195+ else Just . Right
196+ . T.intercalate "&"
163− else Just $ Right (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) pStrings))
197+ $ fmap (\p -> pName <> "=" <> escape p) pStrings
164 QueryPartFlag fl -> ffor fl $ \case
198 QueryPartFlag fl -> ffor fl $ \case
165 True -> Just $ Right pName
199 True -> Just $ Right pName
166 False -> Nothing
200 False -> Nothing
@@ -195,10 +229,10 @@ reqToReflexRequest reqMeth reqHost req =
195 Right $ XhrRequestConfig
229 Right $ XhrRequestConfig
196 { _xhrRequestConfig_sendData = bytesToPayload bBytes
230 { _xhrRequestConfig_sendData = bytesToPayload bBytes
197 , _xhrRequestConfig_headers =
231 , _xhrRequestConfig_headers =
198− Map.insert "Content-Type" bCT (Map.fromList hs)
232+ Map.insert "Content-Type" bCT (Map.fromList hs)
199 , _xhrRequestConfig_user = Nothing
233 , _xhrRequestConfig_user = Nothing
200 , _xhrRequestConfig_password = Nothing
234 , _xhrRequestConfig_password = Nothing
201− , _xhrRequestConfig_responseType = Nothing
235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
202 , _xhrRequestConfig_withCredentials = False
236 , _xhrRequestConfig_withCredentials = False
203 , _xhrRequestConfig_responseHeaders = def
237 , _xhrRequestConfig_responseHeaders = def
204 }
238 }
@@ -210,8 +244,8 @@ reqToReflexRequest reqMeth reqHost req =
210 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
244 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
211 , _xhrRequestConfig_user = Nothing
245 , _xhrRequestConfig_user = Nothing
212 , _xhrRequestConfig_password = Nothing
246 , _xhrRequestConfig_password = Nothing
213− , _xhrRequestConfig_responseType = Nothing
247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
214− , _xhrRequestConfig_sendData = ""
248+ , _xhrRequestConfig_sendData = mempty
215 , _xhrRequestConfig_withCredentials = False
249 , _xhrRequestConfig_withCredentials = False
216 }
250 }
217 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
@@ -238,41 +272,55 @@ reqToReflexRequest reqMeth reqHost req =
238displayHttpRequest :: Text -> Text
272displayHttpRequest :: Text -> Text
239displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
273displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
240
274
241−-- | This function actually performs the request.
275+-- | This function performs the request
242performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
276performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
243 => Text
277 => Text
244 -> Dynamic t (f (Req t))
278 -> Dynamic t (f (Req t))
245 -> Dynamic t BaseUrl
279 -> Dynamic t BaseUrl
280+ -> ClientOptions
246 -> Event t tag
281 -> Event t tag
247 -> m (Event t (tag, f (Either Text XhrResponse)))
282 -> m (Event t (tag, f (Either Text XhrResponse)))
248−performRequests reqMeth rs reqHost trigger = do
283+performRequests reqMeth rs reqHost opts trigger = do
249− -- let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))
284+ let xhrReqs =
285+ join $ (\(fxhr :: f (Req t)) -> sequence $
250− let xhrReqs = join $ (\(fxhr :: f (Req t)) -> sequence $ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
286+ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
287+
288+ -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
289+ reqs = attachPromptlyDynWith
251− let reqs = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
290+ (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
291+
252− resps <- performSomeRequestsAsync reqs
292+ resps <- performSomeRequestsAsync opts reqs
253 return $ getCompose <$> resps
293 return $ getCompose <$> resps
254
294
255−-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.
295+-- | Issues a collection of requests when the supplied Event fires.
296+-- When ALL requests from a given firing complete, the results are
297+-- collected and returned via the return Event.
256performSomeRequestsAsync
298performSomeRequestsAsync
257 :: (MonadIO (Performable m),
299 :: (MonadIO (Performable m),
300+ MonadJSM (Performable m),
258 HasWebView (Performable m),
301 HasWebView (Performable m),
259 PerformEvent t m,
302 PerformEvent t m,
260 TriggerEvent t m,
303 TriggerEvent t m,
261 Traversable f,
304 Traversable f,
262− IsXhrPayload a)
305+ IsXhrPayload a,
306+ Show a
307+ )
308+ => ClientOptions
263− => Event t (f (Either Text (XhrRequest a)))
309+ -> Event t (f (Either Text (XhrRequest a)))
264 -> m (Event t (f (Either Text XhrResponse)))
310 -> m (Event t (f (Either Text XhrResponse)))
311+performSomeRequestsAsync opts =
265−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return
312+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
266
313
267
314
268------------------------------------------------------------------------------
315------------------------------------------------------------------------------
269-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
316-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
270-- that accepts 'f (Either e (XhrRequestb))' events
317-- that accepts 'f (Either e (XhrRequestb))' events
271performSomeRequestsAsync'
318performSomeRequestsAsync'
272− :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
319+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
320+ => ClientOptions
273− => (XhrRequest b -> (a -> IO ()) -> Performable m XMLHttpRequest)
321+ -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
274 -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
322 -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
275−performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
323+performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
276 rs <- hrs
324 rs <- hrs
277 resps <- forM rs $ \r -> case r of
325 resps <- forM rs $ \r -> case r of
278 Left e -> do
326 Left e -> do
@@ -280,70 +328,17 @@ performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb ->
280 return resp
328 return resp
281 Right r' -> do
329 Right r' -> do
282 resp <- liftIO newEmptyMVar
330 resp <- liftIO newEmptyMVar
331+ r'' <- liftJSM $ (optsRequestFixup opts) r'
283− _ <- newXhr r' $ liftIO . putMVar resp . Right
332+ _ <- newXhr r'' $ liftIO . putMVar resp . Right
284 return resp
333 return resp
285 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
334 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
286 return ()
335 return ()
287
336
288
337
289
338
290−-- | This function actually performs the request.
291−performRequest :: forall t m tag .(SupportsServantReflex t m)
292− => Text
293− -> (Req t)
294− -> Dynamic t BaseUrl
295− -> Event t tag
296− -> m (Event t (tag, XhrResponse), Event t (tag, Text))
297−performRequest reqMeth req reqHost trigger = do
298−
299− let xhrReq = reqToReflexRequest reqMeth reqHost req
300− let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger
301− okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) e) reqs
302− badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) e) reqs
303−
304− resps <- performRequestsAsync okReqs
305−
306− return (resps, badReqs)
307−
308−
309−type XhrPayload = T.Text
339+type XhrPayload = ByteString
310bytesToPayload :: BL.ByteString -> XhrPayload
340bytesToPayload :: BL.ByteString -> XhrPayload
311−bytesToPayload = TE.decodeUtf8 . BL.toStrict
341+bytesToPayload = BL.toStrict
312−
313−
314−-- performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)
315−-- => Text
316−-- -> Req t
317−-- -> Dynamic t BaseUrl
318−-- -> Event t tag -> m (Event t (ReqResult tag NoContent))
319−-- performRequestNoBody reqMeth req reqHost trigger = do
320−-- (resp, badReq) <- performRequest reqMeth req reqHost trigger
321−-- let decodeResp = const $ Right NoContent
322−-- return $ leftmost [ fmap (evalResponse decodeResp) resp
323−-- , fmap (uncurry RequestFailure) badReq
324−-- ]
325−
326−
327−-- performRequestCT
328−-- :: (SupportsServantReflex t m,
329−-- MimeUnrender ct a)
330−-- => Proxy ct
331−-- -> Text
332−-- -> Req t
333−-- -> Dynamic t BaseUrl
334−-- -> Event t tag
335−-- -> m (Event t (ReqResult tag a))
336−-- performRequestCT ct reqMeth req reqHost trigger = do
337−-- (resp, badReq) <- performRequest reqMeth req reqHost trigger
338−-- let decodeResp x = first T.pack .
339−-- mimeUnrender ct .
340−-- BL.fromStrict .
341−-- TE.encodeUtf8 =<< note "No body text"
342−-- (_xhrResponse_responseText x)
343−
344−-- return $ leftmost [fmap (evalResponse decodeResp) resp
345−-- , fmap (uncurry RequestFailure) badReq
346−-- ]
347
342
348
343
349performRequestsCT
344performRequestsCT
@@ -353,19 +348,20 @@ performRequestsCT
353 -> Text
348 -> Text
354 -> Dynamic t (f (Req t))
349 -> Dynamic t (f (Req t))
355 -> Dynamic t BaseUrl
350 -> Dynamic t BaseUrl
351+ -> ClientOptions
356 -> Event t tag
352 -> Event t tag
357 -> m (Event t (f (ReqResult tag a)))
353 -> m (Event t (f (ReqResult tag a)))
358−performRequestsCT ct reqMeth reqs reqHost trigger = do
354+performRequestsCT ct reqMeth reqs reqHost opts trigger = do
359− resps <- performRequests reqMeth reqs reqHost trigger
355+ resps <- performRequests reqMeth reqs reqHost opts trigger
356+ let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
360− let decodeResp x = first T.pack .
357+ first T.pack .
361− mimeUnrender ct .
358+ mimeUnrender ct $
362− BL.fromStrict .
359+ BL.fromStrict x
363− TE.encodeUtf8 =<< note "No body text"
360+ decodeResp _ = Left "No body"
364− (_xhrResponse_responseText x)
365 return $ fmap
361 return $ fmap
366 (\(t,rs) -> ffor rs $ \r -> case r of
362 (\(t,rs) -> ffor rs $ \r -> case r of
367 Left e -> RequestFailure t e
363 Left e -> RequestFailure t e
368− Right g -> evalResponse decodeResp (t,g)
364+ Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
369 )
365 )
370 resps
366 resps
371
367
@@ -376,10 +372,11 @@ performRequestsNoBody
376 => Text
372 => Text
377 -> Dynamic t (f (Req t))
373 -> Dynamic t (f (Req t))
378 -> Dynamic t BaseUrl
374 -> Dynamic t BaseUrl
375+ -> ClientOptions
379 -> Event t tag
376 -> Event t tag
380 -> m (Event t (f (ReqResult tag NoContent)))
377 -> m (Event t (f (ReqResult tag NoContent)))
381−performRequestsNoBody reqMeth reqs reqHost trigger = do
378+performRequestsNoBody reqMeth reqs reqHost opts trigger = do
382− resps <- performRequests reqMeth reqs reqHost trigger
379+ resps <- performRequests reqMeth reqs reqHost opts trigger
383 let decodeResp = const $ Right NoContent
380 let decodeResp = const $ Right NoContent
384 return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
381 return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
385 Left e -> RequestFailure tag e
382 Left e -> RequestFailure tag e
@@ -392,7 +389,8 @@ evalResponse
392 -> (tag, XhrResponse)
389 -> (tag, XhrResponse)
393 -> ReqResult tag a
390 -> ReqResult tag a
394evalResponse decode (tag, xhr) =
391evalResponse decode (tag, xhr) =
395− let okStatus = _xhrResponse_status xhr < 400
392+ let status = _xhrResponse_status xhr
393+ okStatus = status >= 200 && status < 400
396 errMsg = fromMaybe
394 errMsg = fromMaybe
397 ("Empty response with error code " <>
395 ("Empty response with error code " <>
398 T.pack (show $ _xhrResponse_status xhr))
396 T.pack (show $ _xhrResponse_status xhr))
@@ -405,7 +403,17 @@ evalResponse decode (tag, xhr) =
405 else ResponseFailure tag errMsg xhr
403 else ResponseFailure tag errMsg xhr
406 in respPayld
404 in respPayld
407
405
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
408
411
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'
409
417
410
418
411note :: e -> Maybe a -> Either e a
419note :: e -> Maybe a -> Either e a
@@ -414,3 +422,10 @@ note e = maybe (Left e) Right
414fmapL :: (e -> e') -> Either e a -> Either e' a
422fmapL :: (e -> e') -> Either e a -> Either e' a
415fmapL _ (Right a) = Right a
423fmapL _ (Right a) = Right a
416fmapL f (Left e) = Left (f e)
424fmapL 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+222−113
@@ -1,17 +1,23 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
2+{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE InstanceSigs #-}
7+{-# LANGUAGE InstanceSigs #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE OverloadedStrings #-}
9−{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE Rank2Types #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE TupleSections #-}
13+{-# LANGUAGE TupleSections #-}
12−{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE TypeOperators #-}
14−{-# LANGUAGE UndecidableInstances #-}
16+{-# LANGUAGE UndecidableInstances #-}
17+
18+#if MIN_VERSION_base(4,9,0)
19+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
20+#endif
15
21
16-- #include "overlapping-compat.h"
22-- #include "overlapping-compat.h"
17-- | This module provides 'client' which can automatically generate
23-- | This module provides 'client' which can automatically generate
@@ -19,55 +25,70 @@
19-- API.
25-- API.
20module Servant.Reflex
26module Servant.Reflex
21 ( client
27 ( client
28+ , clientWithOpts
29+ , clientWithOptsAndResultHandler
30+ , clientWithRoute
31+ , clientWithRouteAndResultHandler
22 , BuildHeaderKeysTo(..)
32 , BuildHeaderKeysTo(..)
23 , toHeaders
33 , toHeaders
24− , HasClient(..)
34+ , HasClient
35+ , Client
25 , module Servant.Common.Req
36 , module Servant.Common.Req
26 , module Servant.Common.BaseUrl
37 , module Servant.Common.BaseUrl
27 ) where
38 ) where
28
39
29------------------------------------------------------------------------------
40------------------------------------------------------------------------------
30import Control.Applicative
41import Control.Applicative
31−import Data.CaseInsensitive (mk)
42+import qualified Data.CaseInsensitive as CI
32import Data.Functor.Identity
43import Data.Functor.Identity
33−import qualified Data.Map as Map
44+import qualified Data.Map as Map
34−import Data.Monoid ((<>))
45+import Data.Monoid ((<>))
35−import Data.Proxy (Proxy (..))
46+import Data.Proxy (Proxy (..))
36−import qualified Data.Set as Set
47+import qualified Data.Set as Set
37−import Data.Text (Text)
48+import Data.Text (Text)
38−import qualified Data.Text as T
49+import qualified Data.Text as T
39−import qualified Data.Text.Encoding as E
50+import qualified Data.Text.Encoding as E
51+import GHC.Exts (Constraint)
40−import GHC.TypeLits (KnownSymbol, symbolVal)
52+import GHC.TypeLits (KnownSymbol, symbolVal)
41−import Servant.API ((:<|>) (..), (:>), BasicAuth,
53+import Servant.API ((:<|>) (..), (:>), BasicAuth,
42− BasicAuthData, BuildHeadersTo (..),
54+ BasicAuthData, BuildHeadersTo (..),
43− Capture, Header, Headers (..),
55+ Capture, Header, Headers (..),
44− HttpVersion, IsSecure, MimeRender (..),
56+ HttpVersion, IsSecure,
57+ MimeRender (..), MimeUnrender,
45− MimeUnrender, NoContent, QueryFlag,
58+ NoContent, QueryFlag, QueryParam,
46− QueryParam, QueryParams, Raw,
59+ QueryParams, Raw, ReflectMethod (..),
47− ReflectMethod (..), RemoteHost,
60+ RemoteHost, ReqBody,
48− ReqBody, ToHttpApiData (..), Vault,
61+ ToHttpApiData (..), Vault, Verb,
49− Verb, contentType)
62+ contentType)
50−
63+import Servant.API.Description (Summary)
64+import qualified Servant.Auth as Auth
65+
51−import Reflex.Dom (Dynamic, Event, Reflex,
66+import Reflex.Dom.Core (Dynamic, Event, Reflex,
52− XhrRequest (..), XhrResponse (..),
67+ XhrRequest (..), XhrResponse (..),
53− XhrResponseHeaders (..),
68+ XhrResponseHeaders (..),
54− attachPromptlyDynWith, constDyn, ffor,
69+ attachPromptlyDynWith, constDyn, ffor,
55− fmapMaybe, leftmost,
70+ fmapMaybe, leftmost,
56− performRequestsAsync)
71+ performRequestsAsync)
57------------------------------------------------------------------------------
72------------------------------------------------------------------------------
58−import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
73+import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
59− SupportsServantReflex, baseUrlWidget,
60− showBaseUrl)
74+ showBaseUrl,
75+ SupportsServantReflex)
61−import Servant.Common.Req (QParam (..), QueryPart (..), Req,
76+import Servant.Common.Req (ClientOptions(..),
77+ defaultClientOptions,
78+ Req, ReqResult(..), QParam(..),
62− ReqResult (..), addHeader, authData,
79+ QueryPart(..), addHeader, authData,
63− defReq, evalResponse,
80+ defReq, evalResponse, prependToPathParts,
81+ -- performRequestCT,
64− performRequestsCT,
82+ performRequestsCT,
83+ -- performRequestNoBody,
65− performRequestsNoBody,
84+ performRequestsNoBody,
66− performSomeRequestsAsync,
85+ performSomeRequestsAsync,
67− prependToPathParts, qParamToQueryPart,
86+ qParamToQueryPart, reqBody,
68− qParams, reqBody, reqFailure,
87+ reqSuccess, reqFailure,
69− reqMethod, reqSuccess, reqTag,
88+ reqMethod, respHeaders,
70− respHeaders, response)
89+ response,
90+ reqTag,
91+ qParams, withCredentials)
71
92
72
93
73-- * Accessing APIs as a Client
94-- * Accessing APIs as a Client
@@ -82,28 +103,75 @@ import Servant.Common.Req (QParam (..), QueryPart (..), Req,
82-- >
103-- >
83-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
104-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
84-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
105-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
85−-- -> m (Event t (l, ReqResult Book)))
106+-- > -> m (Event t (l, ReqResult Book)))
86-- > (getAllBooks :<|> postNewBook) = client myApi host
107-- > (getAllBooks :<|> postNewBook) = client myApi host
87-- > where host = constDyn $ BaseUrl Http "localhost" 8080
108-- > where host = constDyn $ BaseUrl Http "localhost" 8080
109+client
88−client :: (HasClient t m layout tag)
110+ :: (HasClient t m layout tag)
111+ => Proxy layout
112+ -> Proxy m
113+ -> Proxy tag
114+ -> Dynamic t BaseUrl
115+ -> Client t m layout tag
116+client p q t baseurl = clientWithRoute p q t defReq baseurl defaultClientOptions
117+
118+clientWithOpts
119+ :: (HasClient t m layout tag)
120+ => Proxy layout
121+ -> Proxy m
122+ -> Proxy tag
123+ -> Dynamic t BaseUrl
124+ -> ClientOptions
89− => Proxy layout -> Proxy m -> Proxy tag -> Dynamic t BaseUrl -> Client t m layout tag
125+ -> Client t m layout tag
90−client p q t = clientWithRoute p q t defReq
126+clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
127+
128+-- | Like 'clientWithOpts' but allows passing a function which will process the
129+-- result event in some way. This can be used to handle errors in a uniform way
130+-- across call sites.
131+clientWithOptsAndResultHandler
132+ :: (HasClient t m layout tag)
133+ => Proxy layout
134+ -> Proxy m
135+ -> Proxy tag
136+ -> Dynamic t BaseUrl
137+ -> ClientOptions
138+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
139+ -> Client t m layout tag
140+clientWithOptsAndResultHandler p q t = clientWithRouteAndResultHandler p q t defReq
91
141
92
142
93-- | This class lets us define how each API combinator
143-- | This class lets us define how each API combinator
94-- influences the creation of an HTTP request. It's mostly
144-- influences the creation of an HTTP request. It's mostly
95-- an internal class, you can just use 'client'.
145-- an internal class, you can just use 'client'.
96−class HasClient t m layout (tag :: *) where
146+class Monad m => HasClient t m layout (tag :: *) where
97 type Client t m layout tag :: *
147 type Client t m layout tag :: *
98− clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> Client t m layout tag
148+ clientWithRoute
149+ :: Proxy layout
150+ -> Proxy m
151+ -> Proxy tag
152+ -> Req t
153+ -> Dynamic t BaseUrl
154+ -> ClientOptions
155+ -> Client t m layout tag
156+ clientWithRoute l m t r b o = clientWithRouteAndResultHandler l m t r b o return
157+
158+ clientWithRouteAndResultHandler
159+ :: Proxy layout
160+ -> Proxy m
161+ -> Proxy tag
162+ -> Req t
163+ -> Dynamic t BaseUrl
164+ -> ClientOptions
165+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
166+ -> Client t m layout tag
99
167
100
168
101instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
169instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
102 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
170 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
103
171
104− clientWithRoute Proxy q pTag req baseurl =
172+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =
105− clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>
173+ clientWithRouteAndResultHandler (Proxy :: Proxy a) q pTag req baseurl opts wrap :<|>
106− clientWithRoute (Proxy :: Proxy b) q pTag req baseurl
174+ clientWithRouteAndResultHandler (Proxy :: Proxy b) q pTag req baseurl opts wrap
107
175
108
176
109-- Capture. Example:
177-- Capture. Example:
@@ -124,12 +192,10 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
124 type Client t m (Capture capture a :> sublayout) tag =
192 type Client t m (Capture capture a :> sublayout) tag =
125 Dynamic t (Either Text a) -> Client t m sublayout tag
193 Dynamic t (Either Text a) -> Client t m sublayout tag
126
194
127− clientWithRoute Proxy q t req baseurl val =
195+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
128− clientWithRoute (Proxy :: Proxy sublayout)
196+ clientWithRouteAndResultHandler
129− q t
130− (prependToPathParts p req)
197+ (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
131− baseurl
132− where p = (fmap . fmap) toUrlPiece val
198+ where p = (fmap . fmap) (toUrlPiece) val
133
199
134
200
135-- VERB (Returning content) --
201-- VERB (Returning content) --
@@ -141,9 +207,8 @@ instance {-# OVERLAPPABLE #-}
141 Event t tag -> m (Event t (ReqResult tag a))
207 Event t tag -> m (Event t (ReqResult tag a))
142 -- TODO how to access input types here?
208 -- TODO how to access input types here?
143 -- ExceptT ServantError IO a
209 -- ExceptT ServantError IO a
144− clientWithRoute Proxy _ _ req baseurl trigs =
210+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
145− -- performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs
146− fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl trigs
211+ wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
147 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
212 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
148 req' = req { reqMethod = method }
213 req' = req { reqMethod = method }
149
214
@@ -156,29 +221,33 @@ instance {-# OVERLAPPING #-}
156 Event t tag -> m (Event t (ReqResult tag NoContent))
221 Event t tag -> m (Event t (ReqResult tag NoContent))
157 -- TODO: how to access input types here?
222 -- TODO: how to access input types here?
158 -- ExceptT ServantError IO NoContent
223 -- ExceptT ServantError IO NoContent
159− clientWithRoute Proxy _ _ req baseurl =
224+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
160− (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl
225+ wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
161 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
226 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
162
227
163
228
164toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
229toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
165toHeaders r =
230toHeaders r =
166− let toBS = E.encodeUtf8
167− hdrs = maybe []
231+ let hdrs = maybe []
168− (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
232+ (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
169 (Map.toList $ _xhrResponse_headers xhr))
233 (Map.toList $ _xhrResponse_headers xhr))
170 (response r)
234 (response r)
171 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
235 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
172
236
237+
173class BuildHeaderKeysTo hs where
238class BuildHeaderKeysTo hs where
174− buildHeaderKeysTo :: Proxy hs -> [T.Text]
239+ buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
175
240
176instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
241instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
177 where buildHeaderKeysTo _ = []
242 where buildHeaderKeysTo _ = []
178
243
179instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
244instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
180 => BuildHeaderKeysTo ((Header h v) ': xs) where
245 => BuildHeaderKeysTo ((Header h v) ': xs) where
246+ buildHeaderKeysTo _ =
247+ let
248+ thisKey = CI.mk $ T.pack (symbolVal (Proxy :: Proxy h))
181− buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
249+ in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)
250+
182
251
183-- HEADERS Verb (Content) --
252-- HEADERS Verb (Content) --
184-- Headers combinator not treated in fully general case,
253-- Headers combinator not treated in fully general case,
@@ -193,10 +262,10 @@ instance {-# OVERLAPPABLE #-}
193 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
262 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
194 type Client t m (Verb method status cts' (Headers ls a)) tag =
263 type Client t m (Verb method status cts' (Headers ls a)) tag =
195 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
264 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
196− clientWithRoute Proxy _ _ req baseurl trigs = do
265+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
197 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
266 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
198− resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl trigs
267+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
199− return $ toHeaders <$> resp
268+ wrap $ toHeaders <$> resp
200 where req' = req { respHeaders =
269 where req' = req { respHeaders =
201 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
270 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
202 }
271 }
@@ -209,10 +278,10 @@ instance {-# OVERLAPPABLE #-}
209 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
278 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
210 type Client t m (Verb method status cts (Headers ls NoContent)) tag
279 type Client t m (Verb method status cts (Headers ls NoContent)) tag
211 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
280 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
212− clientWithRoute Proxy _ _ req baseurl trigs = do
281+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
213 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
282 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
214− resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl trigs
283+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
215− return $ toHeaders <$> resp
284+ wrap $ toHeaders <$> resp
216 where req' = req {respHeaders =
285 where req' = req {respHeaders =
217 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
286 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
218 }
287 }
@@ -239,11 +308,11 @@ instance (KnownSymbol sym, ToHttpApiData a,
239 type Client t m (Header sym a :> sublayout) tag =
308 type Client t m (Header sym a :> sublayout) tag =
240 Dynamic t (Either Text a) -> Client t m sublayout tag
309 Dynamic t (Either Text a) -> Client t m sublayout tag
241
310
242− clientWithRoute Proxy q t req baseurl eVal =
311+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =
312+ clientWithRouteAndResultHandler
243− clientWithRoute (Proxy :: Proxy sublayout)
313+ (Proxy :: Proxy sublayout) q t
244− q t
245− (Servant.Common.Req.addHeader hname eVal req)
314+ (Servant.Common.Req.addHeader hname eVal req)
246− baseurl
315+ baseurl opts wrap
247 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
316 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
248
317
249
318
@@ -257,8 +326,21 @@ instance HasClient t m sublayout tag
257 type Client t m (HttpVersion :> sublayout) tag =
326 type Client t m (HttpVersion :> sublayout) tag =
258 Client t m sublayout tag
327 Client t m sublayout tag
259
328
260− clientWithRoute Proxy =
329+ clientWithRouteAndResultHandler Proxy =
330+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
331+
332+-- | Using a 'Summary' combinator in your API doesn't affect the client
333+-- functions.
334+instance (HasClient t m sublayout tag, KnownSymbol sym)
335+ => HasClient t m (Summary sym :> sublayout) tag where
336+
337+ type Client t m (Summary sym :> sublayout) tag =
338+ Client t m sublayout tag
339+
340+ clientWithRouteAndResultHandler Proxy =
261− clientWithRoute (Proxy :: Proxy sublayout)
341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
342+
343+
262
344
263
345
264-- | If you use a 'QueryParam' in one of your endpoints in your API,
346-- | If you use a 'QueryParam' in one of your endpoints in your API,
@@ -294,9 +376,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
294 Dynamic t (QParam a) -> Client t m sublayout tag
376 Dynamic t (QParam a) -> Client t m sublayout tag
295
377
296 -- if mparam = Nothing, we don't add it to the query string
378 -- if mparam = Nothing, we don't add it to the query string
297− clientWithRoute Proxy q t req baseurl mparam =
379+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
298− clientWithRoute (Proxy :: Proxy sublayout) q t
380+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
299− (req {qParams = paramPair : qParams req}) baseurl
381+ (req {qParams = paramPair : qParams req}) baseurl opts wrap
300
382
301 where pname = symbolVal (Proxy :: Proxy sym)
383 where pname = symbolVal (Proxy :: Proxy sym)
302 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
384 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -340,8 +422,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
340 type Client t m (QueryParams sym a :> sublayout) tag =
422 type Client t m (QueryParams sym a :> sublayout) tag =
341 Dynamic t [a] -> Client t m sublayout tag
423 Dynamic t [a] -> Client t m sublayout tag
342
424
343− clientWithRoute Proxy q t req baseurl paramlist =
425+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
344− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
426+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
345
427
346 where req' = req { qParams = (T.pack pname, params') : qParams req }
428 where req' = req { qParams = (T.pack pname, params') : qParams req }
347 pname = symbolVal (Proxy :: Proxy sym)
429 pname = symbolVal (Proxy :: Proxy sym)
@@ -380,8 +462,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
380 type Client t m (QueryFlag sym :> sublayout) tag =
462 type Client t m (QueryFlag sym :> sublayout) tag =
381 Dynamic t Bool -> Client t m sublayout tag
463 Dynamic t Bool -> Client t m sublayout tag
382
464
383− clientWithRoute Proxy q t req baseurl flag =
465+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
384− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
466+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
385
467
386 where req' = req { qParams = thisPair : qParams req }
468 where req' = req { qParams = thisPair : qParams req }
387 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
469 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -395,7 +477,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
395 -> Event t tag
477 -> Event t tag
396 -> m (Event t (ReqResult tag ()))
478 -> m (Event t (ReqResult tag ()))
397
479
398− clientWithRoute _ _ _ _ baseurl xhrs triggers = do
480+ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
399
481
400 let xhrs' = liftA2 (\x path -> case x of
482 let xhrs' = liftA2 (\x path -> case x of
401 Left e -> Left e
483 Left e -> Left e
@@ -406,7 +488,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
406 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
488 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
407
489
408 resps <- performRequestsAsync okReq
490 resps <- performRequestsAsync okReq
409− return $ leftmost [ uncurry RequestFailure <$> badReq
491+ wrap $ leftmost [ uncurry RequestFailure <$> badReq
410 , evalResponse (const $ Right ()) <$> resps
492 , evalResponse (const $ Right ()) <$> resps
411 ]
493 ]
412
494
@@ -437,8 +519,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
437 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
519 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
438 Dynamic t (Either Text a) -> Client t m sublayout tag
520 Dynamic t (Either Text a) -> Client t m sublayout tag
439
521
440− clientWithRoute Proxy q t req baseurl body =
522+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
441− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
523+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
442 where req' = req { reqBody = bodyBytesCT }
524 where req' = req { reqBody = bodyBytesCT }
443 ctProxy = Proxy :: Proxy ct
525 ctProxy = Proxy :: Proxy ct
444 ctString = T.pack $ show $ contentType ctProxy
526 ctString = T.pack $ show $ contentType ctProxy
@@ -452,9 +534,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
452instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
534instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
453 type Client t m (path :> sublayout) tag = Client t m sublayout tag
535 type Client t m (path :> sublayout) tag = Client t m sublayout tag
454
536
455− clientWithRoute Proxy q t req =
537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =
456− clientWithRoute (Proxy :: Proxy sublayout) q t
538+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
457− (prependToPathParts (pure (Right $ T.pack p)) req)
539+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap
458
540
459 where p = symbolVal (Proxy :: Proxy path)
541 where p = symbolVal (Proxy :: Proxy path)
460
542
@@ -462,23 +544,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient
462instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
544instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
463 type Client t m (Vault :> api) tag = Client t m api tag
545 type Client t m (Vault :> api) tag = Client t m api tag
464
546
465− clientWithRoute Proxy =
547+ clientWithRouteAndResultHandler Proxy =
466− clientWithRoute (Proxy :: Proxy api)
548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
467
549
468
550
469instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
551instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
470 type Client t m (RemoteHost :> api) tag = Client t m api tag
552 type Client t m (RemoteHost :> api) tag = Client t m api tag
471
553
472− clientWithRoute Proxy =
554+ clientWithRouteAndResultHandler Proxy =
473− clientWithRoute (Proxy :: Proxy api)
555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
474
556
475
557
476
558
477instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
559instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
478 type Client t m (IsSecure :> api) tag = Client t m api tag
560 type Client t m (IsSecure :> api) tag = Client t m api tag
479
561
480− clientWithRoute Proxy =
562+ clientWithRouteAndResultHandler Proxy =
481− clientWithRoute (Proxy :: Proxy api)
563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
482
564
483
565
484instance (HasClient t m api tag, Reflex t)
566instance (HasClient t m api tag, Reflex t)
@@ -487,8 +569,8 @@ instance (HasClient t m api tag, Reflex t)
487 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
569 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
488 -> Client t m api tag
570 -> Client t m api tag
489
571
490− clientWithRoute Proxy q t req baseurl authdata =
572+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
491− clientWithRoute (Proxy :: Proxy api) q t req' baseurl
573+ clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
492 where
574 where
493 req' = req { authData = Just authdata }
575 req' = req { authData = Just authdata }
494
576
@@ -514,3 +596,30 @@ non-empty lists, but is otherwise more specific, no instance will be overall
514more specific. This in turn generally means adding yet another instance (one
596more specific. This in turn generally means adding yet another instance (one
515for empty and one for non-empty lists).
597for empty and one for non-empty lists).
516-}
598-}
599+
600+
601+-- SUPPORT FOR servant-auth --
602+
603+-- For JavaScript clients we should be sending/storing JSON web tokens in a
604+-- way that is inaccessible to JavaScript.
605+--
606+-- For @servant-auth@ this is done with HTTP-only cookies. In a Reflex-DOM
607+-- app this means the @servant-auth@ client should only verify that the API
608+-- supports Cookie-based authentication but do nothing with the token
609+-- directly.
610+
611+-- @HasCookieAuth auths@ is nominally a redundant constraint, but ensures
612+-- we're not trying to rely on cookies when the API does not use them.
613+instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where
614+
615+ type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag
616+ clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)
617+
618+
619+type family HasCookieAuth xs :: Constraint where
620+ HasCookieAuth (Auth.Cookie ': xs) = ()
621+ HasCookieAuth (x ': xs) = HasCookieAuth xs
622+ HasCookieAuth '[] = CookieAuthNotEnabled
623+
624+class CookieAuthNotEnabled
625+
src/Servant/Reflex/Multi.hs+82−53
@@ -16,12 +16,15 @@
16module Servant.Reflex.Multi (
16module Servant.Reflex.Multi (
17 -- * Compute servant client functions
17 -- * Compute servant client functions
18 clientA
18 clientA
19+ , clientWithOptsA
19 , BaseUrl(..)
20 , BaseUrl(..)
20 , Scheme(..)
21 , Scheme(..)
21
22
22 -- * Build QueryParam arguments
23 -- * Build QueryParam arguments
23 , QParam(..)
24 , QParam(..)
24
25
26+ -- * Access response data
27+ , withCredentials
25
28
26 -- * Access response data
29 -- * Access response data
27 , ReqResult(..)
30 , ReqResult(..)
@@ -34,40 +37,45 @@ module Servant.Reflex.Multi (
34 ) where
37 ) where
35
38
36------------------------------------------------------------------------------
39------------------------------------------------------------------------------
37−import Control.Applicative (liftA2)
40+import Control.Applicative (liftA2)
38−import Data.Functor.Compose (Compose (..), getCompose)
41+import Data.Functor.Compose (Compose (..), getCompose)
39−import Data.Proxy (Proxy (..))
42+import Data.Proxy (Proxy (..))
40−import qualified Data.Set as Set
43+import qualified Data.Set as Set
41−import Data.Text (Text)
44+import Data.Text (Text)
42−import qualified Data.Text as T
45+import qualified Data.Text as T
43−import qualified Data.Text.Encoding as E
46+import qualified Data.Text.Encoding as E
44−import GHC.TypeLits (KnownSymbol, symbolVal)
47+import GHC.TypeLits (KnownSymbol, symbolVal)
45−import Servant.API ((:<|>) (..), (:>), BasicAuth,
48+import Servant.API ((:<|>) (..), (:>), BasicAuth,
46− BasicAuthData, BuildHeadersTo (..),
49+ BasicAuthData, BuildHeadersTo (..),
47− Capture, Header, Headers (..),
50+ Capture, Header, Headers (..),
48− HttpVersion, IsSecure, MimeRender (..),
51+ HttpVersion, IsSecure,
52+ MimeRender (..), MimeUnrender,
49− MimeUnrender, NoContent, QueryFlag,
53+ NoContent, QueryFlag, QueryParam,
50− QueryParam, QueryParams, Raw,
54+ QueryParams, Raw, ReflectMethod (..),
51− ReflectMethod (..), RemoteHost,
55+ RemoteHost, ReqBody,
52− ReqBody, ToHttpApiData (..), Vault,
56+ ToHttpApiData (..), Vault, Verb,
53− Verb, contentType)
57+ contentType)
54−
58+import Servant.API.Description (Summary)
59+
55−import Reflex.Dom (Dynamic, Event, Reflex,
60+import Reflex.Dom.Core (Dynamic, Event, Reflex,
56− XhrRequest (..),
61+ XhrRequest (..),
57− XhrResponseHeaders (..),
62+ XhrResponseHeaders (..),
58− attachPromptlyDynWith, constDyn)
63+ attachPromptlyDynWith, constDyn)
59------------------------------------------------------------------------------
64------------------------------------------------------------------------------
60import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
65import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
61 SupportsServantReflex)
66 SupportsServantReflex)
67+import Servant.Common.Req (ClientOptions,
62−import Servant.Common.Req (QParam (..), QueryPart (..), Req,
68+ QParam (..), QueryPart (..), Req,
63 ReqResult (..), addHeader, authData,
69 ReqResult (..), addHeader, authData,
70+ defReq,
71+ defaultClientOptions,
64− defReq, performRequestsCT,
72+ performRequestsCT,
65 performRequestsNoBody,
73 performRequestsNoBody,
66 performSomeRequestsAsync,
74 performSomeRequestsAsync,
67 prependToPathParts, qParamToQueryPart,
75 prependToPathParts, qParamToQueryPart,
68 qParams, reqBody, reqFailure,
76 qParams, reqBody, reqFailure,
69 reqMethod, reqSuccess, reqSuccess',
77 reqMethod, reqSuccess, reqSuccess',
70− respHeaders, response)
78+ respHeaders, response, withCredentials)
71import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
79import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
72
80
73
81
@@ -77,14 +85,24 @@ clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
77 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
85 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
78clientA p q f tag baseurl =
86clientA p q f tag baseurl =
79 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
87 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
88+ defaultClientOptions
89+
80
90
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
81
99
82------------------------------------------------------------------------------
100------------------------------------------------------------------------------
83class HasClientMulti t m layout f (tag :: *) where
101class HasClientMulti t m layout f (tag :: *) where
84 type ClientMulti t m layout f tag :: *
102 type ClientMulti t m layout f tag :: *
85 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
103 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
86 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
104 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
87− -> ClientMulti t m layout f tag
105+ -> ClientOptions -> ClientMulti t m layout f tag
88
106
89
107
90------------------------------------------------------------------------------
108------------------------------------------------------------------------------
@@ -92,9 +110,9 @@ instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>
92 HasClientMulti t m (a :<|> b) f tag where
110 HasClientMulti t m (a :<|> b) f tag where
93 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>
111 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>
94 ClientMulti t m b f tag
112 ClientMulti t m b f tag
95− clientWithRouteMulti Proxy q f tag reqs baseurl =
113+ clientWithRouteMulti Proxy q f tag reqs baseurl opts =
96− clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl :<|>
114+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>
97− clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl
115+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts
98
116
99
117
100------------------------------------------------------------------------------
118------------------------------------------------------------------------------
@@ -107,8 +125,8 @@ instance (SupportsServantReflex t m,
107 type ClientMulti t m (Capture capture a :> sublayout) f tag =
125 type ClientMulti t m (Capture capture a :> sublayout) f tag =
108 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
126 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
109
127
110− clientWithRouteMulti _ q f tag reqs baseurl vals =
128+ clientWithRouteMulti _ q f tag reqs baseurl opts vals =
111− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
129+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
112 where
130 where
113 reqs' = (prependToPathParts <$> ps <*>) <$> reqs
131 reqs' = (prependToPathParts <$> ps <*>) <$> reqs
114 ps = (fmap . fmap . fmap) toUrlPiece vals
132 ps = (fmap . fmap . fmap) toUrlPiece vals
@@ -128,8 +146,8 @@ instance {-# OVERLAPPABLE #-}
128 type ClientMulti t m (Verb method status cts' a) f tag =
146 type ClientMulti t m (Verb method status cts' a) f tag =
129 Event t tag -> m (Event t (f (ReqResult tag a)))
147 Event t tag -> m (Event t (f (ReqResult tag a)))
130
148
131− clientWithRouteMulti _ _ _ _ reqs baseurl =
149+ clientWithRouteMulti _ _ _ _ reqs baseurl opts =
132− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
150+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts
133 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
151 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
134 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
152 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
135
153
@@ -143,8 +161,8 @@ instance {-# OVERLAPPING #-}
143 Event t tag -> m (Event t (f (ReqResult tag NoContent)))
161 Event t tag -> m (Event t (f (ReqResult tag NoContent)))
144 -- TODO: how to access input types here?
162 -- TODO: how to access input types here?
145 -- ExceptT ServantError IO NoContent
163 -- ExceptT ServantError IO NoContent
146− clientWithRouteMulti Proxy _ _ _ req baseurl =
164+ clientWithRouteMulti Proxy _ _ _ req baseurl opts =
147− performRequestsNoBody method req baseurl
165+ performRequestsNoBody method req baseurl opts
148 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
166 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
149
167
150
168
@@ -158,9 +176,9 @@ instance {-# OVERLAPPABLE #-}
158 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where
176 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where
159 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =
177 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =
160 Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))
178 Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))
161− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
179+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
162 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
180 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
163− resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl triggers :: m (Event t (f (ReqResult tag a)))
181+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))
164 return $ fmap toHeaders <$> resp
182 return $ fmap toHeaders <$> resp
165 where
183 where
166 reqs' = fmap (\r ->
184 reqs' = fmap (\r ->
@@ -181,9 +199,9 @@ instance {-# OVERLAPPABLE #-}
181 cts (Headers ls NoContent)) f tag where
199 cts (Headers ls NoContent)) f tag where
182 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag
200 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag
183 = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))
201 = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))
184− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
202+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
185 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
203 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
186− resp <- performRequestsNoBody method reqs' baseurl triggers
204+ resp <- performRequestsNoBody method reqs' baseurl opts triggers
187 return $ fmap toHeaders <$> resp
205 return $ fmap toHeaders <$> resp
188 where reqs' = fmap (\req ->
206 where reqs' = fmap (\req ->
189 req {respHeaders = OnlyHeaders (Set.fromList
207 req {respHeaders = OnlyHeaders (Set.fromList
@@ -203,11 +221,11 @@ instance (KnownSymbol sym,
203 type ClientMulti t m (Header sym a :> sublayout) f tag =
221 type ClientMulti t m (Header sym a :> sublayout) f tag =
204 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
222 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
205
223
206− clientWithRouteMulti Proxy f q tag reqs baseurl eVals =
224+ clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =
207 clientWithRouteMulti (Proxy :: Proxy sublayout) f
225 clientWithRouteMulti (Proxy :: Proxy sublayout) f
208 q tag
226 q tag
209 reqs'
227 reqs'
210− baseurl
228+ baseurl opts
211 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
229 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
212 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
230 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
213 <$> eVals <*>) <$> reqs
231 <$> eVals <*>) <$> reqs
@@ -224,6 +242,17 @@ instance HasClientMulti t m sublayout f tag
224 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
242 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
225
243
226
244
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+
227------------------------------------------------------------------------------
256------------------------------------------------------------------------------
228instance (KnownSymbol sym,
257instance (KnownSymbol sym,
229 ToHttpApiData a,
258 ToHttpApiData a,
@@ -237,9 +266,9 @@ instance (KnownSymbol sym,
237
266
238 -- if mparam = Nothing, we don't add it to the query string
267 -- if mparam = Nothing, we don't add it to the query string
239 -- TODO: Check the above comment
268 -- TODO: Check the above comment
240− clientWithRouteMulti Proxy q f tag reqs baseurl mparams =
269+ clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =
241 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
270 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
242− reqs' baseurl
271+ reqs' baseurl opts
243
272
244 where pname = symbolVal (Proxy :: Proxy sym)
273 where pname = symbolVal (Proxy :: Proxy sym)
245 p prm = QueryPartParam $ fmap qParamToQueryPart prm
274 p prm = QueryPartParam $ fmap qParamToQueryPart prm
@@ -260,8 +289,8 @@ instance (KnownSymbol sym,
260 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
289 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
261 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
290 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
262
291
263− clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =
292+ clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =
264− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
293+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
265
294
266 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }
295 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }
267 pname = symbolVal (Proxy :: Proxy sym)
296 pname = symbolVal (Proxy :: Proxy sym)
@@ -279,8 +308,8 @@ instance (KnownSymbol sym,
279 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
308 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
280 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
309 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
281
310
282− clientWithRouteMulti Proxy q f' tag reqs baseurl flags =
311+ clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =
283− clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl
312+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts
284
313
285 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
314 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
286 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
315 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
@@ -294,10 +323,10 @@ instance (SupportsServantReflex t m,
294 -> Event t tag
323 -> Event t tag
295 -> m (Event t (f (ReqResult tag ())))
324 -> m (Event t (f (ReqResult tag ())))
296
325
297− clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do
326+ clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do
298 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
327 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
299 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
328 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
300− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync rawReqs''
329+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''
301 return resps
330 return resps
302 where
331 where
303 aux (tag, Right r) = ResponseSuccess tag () r
332 aux (tag, Right r) = ResponseSuccess tag () r
@@ -313,8 +342,8 @@ instance (MimeRender ct a,
313 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
342 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
314 Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
343 Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
315
344
316− clientWithRouteMulti Proxy q f tag reqs baseurl bodies =
345+ clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
317− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
346+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
318 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
347 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
319 ctProxy = Proxy :: Proxy ct
348 ctProxy = Proxy :: Proxy ct
320 ctString = T.pack $ show $ contentType ctProxy
349 ctString = T.pack $ show $ contentType ctProxy
@@ -365,8 +394,8 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
365 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))
394 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))
366 -> ClientMulti t m api f tag
395 -> ClientMulti t m api f tag
367
396
368− clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =
397+ clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =
369− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl
398+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts
370 where
399 where
371 req' a r = r { authData = Just (constDyn a) }
400 req' a r = r { authData = Just (constDyn a) }
372 reqs' = liftA2 req' <$> authdatas <*> reqs
401 reqs' = liftA2 req' <$> authdatas <*> reqs
testdriver/test/Servant/ReflexSpec.hs+2−1
@@ -9,6 +9,7 @@ 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)
12
13
13
14
14clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()
15clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()
@@ -28,7 +29,7 @@ spec :: Spec
28spec = do
29spec = do
29 describe "servant-reflex tests" $ do
30 describe "servant-reflex tests" $ do
30
31
31− session "test page" $ using Chrome $ do
32+ session "test page" $ using [chromeCaps] $ do
32
33
33 it "opens the page" $ runWD $
34 it "opens the page" $ runWD $
34 openPage "http://localhost:8000"
35 openPage "http://localhost:8000"
testserver/API.hsmode 120000 → 100644+69−1
@@ -1 +0,0 @@
1−../exec/API.hs
@@ -0,0 +1,69 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE TypeOperators #-}
4+
5+module API where
6+
7+import Data.Aeson
8+import Data.Aeson.Types (typeMismatch)
9+import Data.Text (Text)
10+import Servant.API
11+
12+newtype Question = Question { unQuestion :: Text } deriving (Show)
13+
14+instance ToJSON Question where
15+ toJSON (Question txt) = object ["question" .= txt]
16+
17+instance FromJSON Question where
18+ parseJSON (Object v) = Question <$> v .: "question"
19+ parseJSON x = typeMismatch "Couldn't find key 'question'" x
20+
21+newtype Answer = Answer { unAnswer :: Text } deriving (Show)
22+
23+instance ToJSON Answer where
24+ toJSON (Answer txt) = object ["answer" .= txt]
25+
26+instance FromJSON Answer where
27+ parseJSON (Object v) = Answer <$> v .: "answer"
28+ parseJSON x = typeMismatch "Couldn't find key 'answer'" x
29+
30+
31+-- | API spec for server, client, and docs
32+type API = "getunit" :> Get '[JSON] ()
33+ :<|> "getint" :> Get '[JSON] Int
34+ :<|> "sayhi" :> QueryParam "username" Text
35+ :> QueryParams "greetings" Text
36+ :> QueryFlag "gusto"
37+ :> Get '[JSON] Text
38+ :<|> "double" :> ReqBody '[JSON] Double
39+ :> Post '[JSON] Double
40+ :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
41+ :<|> "qna" :> ReqBody '[JSON] Question
42+ :> Post '[JSON] Answer
43+ :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
44+ :<|> Raw
45+
46+type GET = Get '[JSON] ()
47+
48+-- Imported the comprehensive API example for testing.
49+-- https://github.com/haskell-servant/servant/blob/master/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs
50+type ComprehensiveAPI =
51+ GET :<|>
52+ Get '[JSON] Int :<|>
53+ Capture "foo" Int :> GET :<|>
54+ Header "foo" Int :> GET :<|>
55+ HttpVersion :> GET :<|>
56+ IsSecure :> GET :<|>
57+ QueryParam "foo" Int :> GET :<|>
58+ QueryParams "foo" Int :> GET :<|>
59+ QueryFlag "foo" :> GET :<|>
60+-- Raw :<|>
61+ RemoteHost :> GET :<|>
62+ ReqBody '[JSON] Int :> GET :<|>
63+ Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>
64+ "foo" :> GET :<|>
65+ Vault :> GET :<|>
66+ Verb 'POST 204 '[JSON] () :<|>
67+ Verb 'POST 204 '[JSON] Int
68+-- This one isn't in scope
69+-- :<|> WithNamedContext "foo" '[] GET
testserver/Main.hs+20−5
@@ -2,14 +2,17 @@
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE PolyKinds #-}
4{-# LANGUAGE PolyKinds #-}
5+{-# LANGUAGE TypeApplications #-}
5{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeOperators #-}
7{-# LANGUAGE TypeOperators #-}
7
8
8import Control.Monad.IO.Class (liftIO)
9import Control.Monad.IO.Class (liftIO)
10+import Control.Monad.Reader (reader)
9import Data.Aeson
11import Data.Aeson
10import Data.Bool
12import Data.Bool
11import Data.Char (toUpper)
13import Data.Char (toUpper)
12import qualified Data.List as L
14import qualified Data.List as L
15+import Data.Maybe (fromMaybe)
13import Data.Monoid
16import Data.Monoid
14import Data.Proxy
17import Data.Proxy
15import Data.Text hiding (head, length, map,
18import Data.Text hiding (head, length, map,
@@ -24,6 +27,7 @@ import Snap.Http.Server
24import Servant
27import Servant
25import Servant.Server
28import Servant.Server
26-- import Snap.Util.FileServe
29-- import Snap.Util.FileServe
30+import System.Environment (lookupEnv)
27import API
31import API
28import Snap
32import Snap
29
33
@@ -39,7 +43,7 @@ instance ToJSON Greet
39testApi :: Proxy API
43testApi :: Proxy API
40testApi = Proxy
44testApi = Proxy
41
45
42−data App = App
46+data App = App { appStaticDir :: String }
43
47
44-- Server-side handlers.
48-- Server-side handlers.
45--
49--
@@ -47,8 +51,10 @@ data App = App
47-- that represents the API, are glued together using :<|>.
51-- that represents the API, are glued together using :<|>.
48--
52--
49-- Each handler runs in the 'ExceptT ServantErr IO' monad.
53-- Each handler runs in the 'ExceptT ServantErr IO' monad.
50−server :: Server API (Handler App App)
54+server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
51−server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> serveDirectory "static"
55+server = return () :<|> return 100 :<|> sayhi :<|> dbl
56+ :<|> multi :<|> qna :<|> serveSecret
57+ :<|> statics
52 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
58 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
53 sayhi nm greetings withGusto = case nm of
59 sayhi nm greetings withGusto = case nm of
54 Nothing -> return ("Sorry, who are you?" :: Text)
60 Nothing -> return ("Sorry, who are you?" :: Text)
@@ -69,18 +75,27 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|>
69 putStrLn $ "qna got: " ++ show q
75 putStrLn $ "qna got: " ++ show q
70 T.putStrLn $ unQuestion q
76 T.putStrLn $ unQuestion q
71 return $ Answer $ unQuestion q
77 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
72
85
73-- Turn the server into a WAI app. 'serve' is provided by servant,
86-- Turn the server into a WAI app. 'serve' is provided by servant,
74-- more precisely by the Servant.Server module.
87-- more precisely by the Servant.Server module.
75test :: Handler App App ()
88test :: Handler App App ()
76−test = serveSnap testApi server
89+test = serveSnapWithContext testApi
90+ (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server
77
91
78initApp :: SnapletInit App App
92initApp :: SnapletInit App App
79initApp = makeSnaplet "myapp" "example" Nothing $ do
93initApp = makeSnaplet "myapp" "example" Nothing $ do
94+ staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")
80 addRoutes [("", test)
95 addRoutes [("", test)
81 ,("", serveDirectory "static")
96 ,("", serveDirectory "static")
82 ]
97 ]
83− return App
98+ return (App staticDir)
84
99
85-- Put this all to work!
100-- Put this all to work!
86main :: IO ()
101main :: IO ()
testserver/run-wd-tests.shdeleted−5
@@ -1,5 +0,0 @@
1−#!/usr/bin/env bash
2−
3−dist/build/back/back -p 8000 &
4−phantomjs --webdriver=127.0.0.1:4444 &
5−dist/build/spec/spec
testserver/testserver.cabal+8−7
@@ -19,13 +19,14 @@ executable back
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.1
22+ build-depends: aeson >= 0.9 && < 1.5
23− , base >=4.8 && <4.10
23+ , base >=4.8 && < 5
24+ , mtl
24− , snap >= 1.0 && < 1.1
25+ , snap >= 1.0 && < 1.2
25− , snap-server >= 1.0 && < 1.1
26+ , snap-server >= 1.0 && < 1.2
26 , snap-core >= 1.0 && < 1.1
27 , snap-core >= 1.0 && < 1.1
27− , servant >= 0.8 && < 0.11
28+ , servant >= 0.16 && < 0.18
28− , servant-snap >= 0.7.2 && < 0.8
29+ , servant-snap >= 0.8 && < 0.9
29− , text >= 1.2 && < 1.3
30+ , text >= 1.0 && < 1.3
30 -- hs-source-dirs:
31 -- hs-source-dirs:
31 default-language: Haskell2010
32 default-language: Haskell2010
testserver/tr.nixdeleted−32
@@ -1,32 +0,0 @@
1−{ reflex-platform, ... }:
2−let
3−
4− dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;
5− cabal2nixResult = reflex-platform.cabal2nixResult;
6− nixpkgs = (import <nixpkgs> {});
7−in
8−reflex-platform.ghc.override {
9− overrides = self: super: {
10− servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});
11− snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap) {});
12− io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});
13− io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});
14− heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});
15− xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});
16− snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});
17− snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});
18− snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});
19− snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});
20− hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});
21−
22− # servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});
23− # servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});
24− # servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});
25− # servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});
26− # servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});
27− # servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});
28− # servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});
29− # servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});
30−
31− };
32−}
travis.nixnew file+70
@@ -0,0 +1,70 @@
1+{
2+ nativeCompiler ? "ghc",
3+ # ^ Choose a GHC for compiling backend components (web server, selenium)
4+ # (ghc, ghc8_0, ghc8_2, ghc8_4 or ghcHEAD)
5+
6+ jsCompiler ? "ghcjs"
7+ # ^ Choose a GHCJS for compiling the frontend
8+ # (ghcjs, ghcjs8_0, ghcjs8_2 or ghcjs8_4)
9+
10+}:
11+
12+let
13+
14+ reflexPlatform = import ./nix/reflex-platform.nix;
15+
16+ lib = reflexPlatform.nixpkgs.haskell.lib;
17+ do = funs: pkg: builtins.foldl' (a: b: b a) pkg funs;
18+
19+ ghcjsPkgs = with lib; reflexPlatform.${jsCompiler}.override {
20+ overrides = self: super: {
21+ http-media = dontCheck super.http-media;
22+ servant = dontCheck super.servant;
23+ lens-aeson = dontCheck super.lens-aeson;
24+ servant-reflex = lib.appendConfigureFlag
25+ (self.callPackage ./default.nix {}) "-fExample";
26+ };
27+ };
28+
29+ ghcPkgs = with lib; reflexPlatform.${nativeCompiler}.override {
30+ overrides = self: super: {
31+ servant-snap = dontCheck ((import ./nix/servant-snap.nix {}) self super);
32+ testdriver = self.callCabal2nix "testdriver" ./testdriver {};
33+ testserver = import nix/testserver.nix ghcjsPkgs.servant-reflex self super;
34+ servant-reflex = self.callPackage ./default.nix {};
35+ };
36+ };
37+
38+ testresults = import ./nix/testresults.nix
39+ { inherit reflexPlatform;
40+ inherit (ghcPkgs) testserver testdriver;
41+ inherit (reflexPlatform.nixpkgs) curl;
42+ phantomjs = reflexPlatform.nixpkgs.phantomjs2;
43+ };
44+
45+in
46+ rec {
47+
48+ inherit reflexPlatform ghcPkgs ghcjsPkgs;
49+
50+ build = ghcjsPkgs.servant-reflex;
51+ buildGhc = ghcPkgs.servant-reflex;
52+ testserver = ghcPkgs.testserver;
53+ testdriver = ghcPkgs.testdriver;
54+ inherit testresults;
55+
56+ cabalBuild = reflexPlatform.${jsCompiler}.shellFor {
57+ name = "servant-reflex-cabal-builder";
58+
59+ packages = p: [
60+ build
61+ ];
62+
63+ shellHook = ''
64+ cabal configure --ghcjs -f Example
65+ cabal build
66+ exec/toSite.sh
67+ exit $?
68+ '';
69+ };
70+ }