git.iko.soy/servant-reflex
on master help sign in
swap
f76dbeb102 ahead, 0 behind
.gitignore+3−1
since splitsnapshots
unifiedsplit
@@ -6,4 +6,6 @@ log
6*.webapp
6*.webapp
7*.stats
7*.stats
8out
8out
9−reflex-platform
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 && 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.mdnew file+60
@@ -0,0 +1,60 @@
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+
29+0.3
30+---
31+
32+- **Addition of the 'Servant.Reflex.Multi' module** which allows the user
33+to choose some '(Applicative f, Traversable f) => f' for collecting
34+endpoint parameters. The traversable instance is used for passing
35+multiple 'XhrRequest's in response to a single event trigger. The
36+Applicative instance is used to combine parameters. For example,
37+'Capture "id" Name :> QueryParam "greeting" Text :> Get '[JSON] Text'
38+will generate a client function:
39+`Dynamic t (f Name) -> Dynamic t (f greeting) -> Event t tag ->
40+ m (Event t (f (ReqResult tag Text)))`
41+Calling that function with 'f' chosen to be list ('[]'), this call
42+`clientFun
43+(constDyn ["Greg", "Bernie"])
44+(constDyn ["Greetings", "Hey"])
45+trigger`
46+would produce four XhrRequests per 'trigger' event, one for each
47+combination of possible parameters, and one response event
48+would carry a list of the four responses.
49+A 'zip-wise' combination of the parameters can be chosen with
50+a different applicative wrapper: 'ZipList'
51+
52+- **Event tags**. A new type parameter lets users choose a payload
53+value to attach to outgoing requests at the point of triggering,
54+and which is embedded in the response, allowing individual
55+request-response pairs to be followed. The response's tag has been
56+added to each constructor `ReqResult tag a` type.
57+
58+- **Improved Unicode support** Thanks to Schell Scivally
59+(https://github.com/schell) for identifying and fixing a UTF-8
60+encoding bug!
README.md+114−28
@@ -2,16 +2,21 @@
2
2
3[![Build Status](https://travis-ci.org/imalsogreg/servant-reflex.svg?branch=master)](https://travis-ci.org/imalsogreg/servant-reflex)
3[![Build Status](https://travis-ci.org/imalsogreg/servant-reflex.svg?branch=master)](https://travis-ci.org/imalsogreg/servant-reflex)
4
4
5−## The problem `servant-reflex` solves
5+## `servant-reflex` lets you share your `servant` APIs with the frontend
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.
8−Syncronization between is checked at compile time, and rather than building XHR requests by hand, API endpoints are available behind `reflex`'s FRP semantics.
9
6
7+Keeping your frontend in sync with your API server can be difficult - when the
8+API changes its input parameters or return type, XHR requests from the
9+frontend will fail at runtime. If your API is defined by
10+[servant](https://haskell-servant.readthedocs.io) combinators, you can use
11+`servant-reflex` to share the API between the server and frontend.
12+Syncronization between is checked at compile time, and rather than building XHR
13+requests by hand, API endpoints are available behind `reflex`'s FRP semantics.
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
@@ -33,16 +39,26 @@ type API = "getint" :> Get '[JSON] Int
33 -- servant-reflex computes FRP functions for each API endpoint
39 -- servant-reflex computes FRP functions for each API endpoint
34 let (getint :<|> sayhi :<|> doubleit :<|> _) = client (Proxy :: Proxy API)
40 let (getint :<|> sayhi :<|> doubleit :<|> _) = client (Proxy :: Proxy API)
35 (Proxy :: Proxy m)
41 (Proxy :: Proxy m)
42+ (Proxy :: Proxy ())
36 (constDyn (BasePath "/"))
43 (constDyn (BasePath "/"))
37```
44```
38
45
39−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.
40
56
41```haskell
57```haskell
42 -- 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!
43 getint :: MonadWidget t m
59 getint :: MonadWidget t m
44 => Event t () -- ^ Trigger the XHR Request
60 => Event t () -- ^ Trigger the XHR Request
45− -> m (Event t (ReqResult Int)) -- ^ Consume the answer
61+ -> m (Event t (ReqResult () Int)) -- ^ Consume the answer
46
62
47 sayhi :: MonadWidget t m
63 sayhi :: MonadWidget t m
48 => Dynamic t (QParam Text)
64 => Dynamic t (QParam Text)
@@ -53,15 +69,21 @@ These client functions are computed from your API type. They manage serializatio
53 -- ^ Flag for capitalizing the response
69 -- ^ Flag for capitalizing the response
54 -> Event t ()
70 -> Event t ()
55 -- ^ Trigger the XHR Request
71 -- ^ Trigger the XHR Request
56− -> m (Event t (ReqResult Text))
72+ -> m (Event t (ReqResult () Text))
57
73
58 doubleit :: MonadWidget t m
74 doubleit :: MonadWidget t m
59 => Dynamic t (Either Text Double)
75 => Dynamic t (Either Text Double)
60 -> Event t ()
76 -> Event t ()
61− -> m (Event t (ReqResult Double))
77+ -> m (Event t (ReqResult () Double))
62```
78```
63
79
80+`ReqResult tag a` is defined in
64−`ReqResult 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:
65
87
66```haskell
88```haskell
67 -- ... continued ...
89 -- ... continued ...
@@ -79,7 +101,8 @@ These client functions are computed from your API type. They manage serializatio
79 dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])
101 dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])
80```
102```
81
103
82−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:
83
106
84```haskell
107```haskell
85 elClass "div" "int-demo" $ do
108 elClass "div" "int-demo" $ do
@@ -102,37 +125,100 @@ This example builds some input fields to enter API parameters, buttons to trigge
102 display =<< holdDyn Nothing outputDouble
125 display =<< holdDyn Nothing outputDouble
103```
126```
104
127
105−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.
106
133
107
134
108## Building the library and test server
135## Building the library and test server
109
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
110−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).
111−
142+To build these components, we will use the nix packages for the testserver. It
112−
143+manages the frontend build as a dependency.
113−First build the library:
114
144
115```
145```
116−git submodule update --init --recursive
146+nix build -f travis.nix testserver -o server
117−./build.sh
118```
147```
119
148
120−Then build the test server:
149+Point it at the static directory and run it:
121
150
122```
151```
123−deps/reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal build"
152+STATIC_DIR=server/static server/back -p 8000
124```
153```
125
154
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.
126
158
127−## Running the example site
159+**For a larger example of a project that shares types between backend and
160+frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
128
161
129−The server must be run from the directory where static assets live:
130
162
163+## Tagging requests
164+
165+The input and the return type of a client function like `getDouble` are both
166+event streams. The individual input events and responses occur at different
167+times and aren't automatically paired up, but you can recover the
168+relationship by tagging the requests.
169+
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:
175+
176+```haskell
177+ ...
178+ inp <- textInput def
179+
180+ -- Convert the raw text into an `Either Text Double`
181+ let inpNum = maybe (Left "No Parse") Right . readMaybe . T.unpack <$> value inp
182+ go <- button "Double It"
183+
184+ -- Call 'doubleIt' with triggers that coincide with good input parses
185+ rs <- doubleIt inpNum (fforMaybe (tagPromptlyDyn inpNum go) $ \case
186+ Left _ -> Nothing
187+ Right a -> Just a
188+ )
189+
190+ -- Accumulate good responses in a map
191+ doubleTable <- foldDyn (<>) mempty $ ffor rs $ \case
192+ ResponseSuccess tag v _ -> tag =: v
193+ _ -> mempty
194+
195+ el "table" $ do
196+ listWithKey doubleTable $ \k dv -> el "tr" $ do
197+ el "td" $ text (T.pack $ show k)
198+ el "td" $ dynText (T.pack . show <$> dv)
199+ ...
131```
200```
132−cd testserver
133−dist/build/back/back -p 8001
134−```
135
201
136−And simply browse to `localhost:8001`
202+## Simultaneous requests
203+
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:
208+
209+```haskell
210+sayHi
211+ :: Dynamic t (f (QParam Text))
212+ -> Dynamic t (f [Text])
213+ -> Dynamic t (f Bool)
214+ -> Event t tag
215+ -> m (Event t (f (ReqResult tag Text)))
216+```
137
217
138−**For a larger example of a project that shares types between backend and frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
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+48−21
@@ -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,11 +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
19+import GHC.TypeLits
17import Servant.API
20import Servant.API
18import API
21import API
19import Data.Proxy
22import Data.Proxy
20import Text.Read (readMaybe)
23import Text.Read (readMaybe)
21−import Reflex.Dom
24+import Reflex.Dom.Core hiding (run, mainWidget)
25+import Reflex.Dom (mainWidget)
22------------------------------------------------------------------------------
26------------------------------------------------------------------------------
23import Servant.Reflex
27import Servant.Reflex
24import Servant.Reflex.Multi
28import Servant.Reflex.Multi
@@ -42,17 +46,18 @@ runMulti :: forall t m. (SupportsServantReflex t m,
42runMulti = do
46runMulti = do
43 url <- baseUrlWidget
47 url <- baseUrlWidget
44 el "br" blank
48 el "br" blank
45− let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ ) =
49+ let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =
46 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
50 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
51+
47 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
48 num2 :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
53 num2 :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
49− -- dynText =<< holdDyn "waiting" (T.pack . show <$> num)
54+
50− -- numLabeled :: Event t (First Int, Double) <- zipListWithEvent (,) (First . Just <$> [0..]) num
51 b <- button "Run dbl multi"
55 b <- button "Run dbl multi"
52− reqCount <- count b
56+ reqCount :: Dynamic t Int <- count b
53 r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)
57 r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)
54− dynText =<< holdDyn "Waiting" (T.pack . show . fmapMaybe reqSuccess .snd <$> r)
58+ dynText =<< holdDyn "Waiting" (T.pack . show . fmap reqSuccess <$> r)
59+
55− lastInd <- holdDyn Nothing (Just . fst <$> r)
60+ lastInd <- holdDyn [] $ fmap reqTag <$> r
56 display lastInd
61 display lastInd
57
62
58 divClass "demo-group" $ do
63 divClass "demo-group" $ do
@@ -64,8 +69,13 @@ runMulti = do
64 textInput def
69 textInput def
65 gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
70 gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
66 b <- button "Go"
71 b <- button "Go"
67− 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+
68− dynText =<< holdDyn "Waiting" (T.pack . show . fmap (fmapMaybe reqSuccess) <$> r')
75+ dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .
76+ fmap reqSuccess <$> r')
77+
78+
69 return ()
79 return ()
70
80
71run :: forall t m. (SupportsServantReflex t m,
81run :: forall t m. (SupportsServantReflex t m,
@@ -87,21 +97,26 @@ run = mdo
87 el "br" (return ())
97 el "br" (return ())
88
98
89 -- Name the computed API client functions
99 -- Name the computed API client functions
100+ let tweakRequest = ClientOptions $ \r -> do
101+ return $ r & withCredentials .~ True
90− let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> doRaw) =
102+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl
103+ :<|> multi :<|> qna :<|> secret :<|> doRaw) =
91− client api (Proxy :: Proxy m) url
104+ clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest
105+
106+ c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
92
107
93 (unitBtn, intBtn) <- elClass "div" "demo-group" $ do
108 (unitBtn, intBtn) <- elClass "div" "demo-group" $ do
94 unitBtn <- divClass "unit-button" $ button "Get unit"
109 unitBtn <- divClass "unit-button" $ button "Get unit"
95 intBtn <- divClass "int-button" $ button "Get int"
110 intBtn <- divClass "int-button" $ button "Get int"
96
111
97 unitResponse <- getUnit $ tag (current reqCount) unitBtn
112 unitResponse <- getUnit $ tag (current reqCount) unitBtn
98− intResponse :: Event t (Int, ReqResult Int) <- getInt $ tag (current reqCount) intBtn
113+ intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn
99
114
100− score <- foldDyn (+) 0 (fmapMaybe reqSuccess (snd <$> intResponse))
115+ score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))
101
116
102 r <- holdDyn "Waiting" $ fmap showXhrResponse $
117 r <- holdDyn "Waiting" $ fmap showXhrResponse $
103− leftmost [fmapMaybe response (snd <$> unitResponse)
118+ leftmost [fmapMaybe response (unitResponse)
104− ,fmapMaybe response (snd <$> intResponse)
119+ ,fmapMaybe response (intResponse)
105 ]
120 ]
106 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
107 return (unitBtn, intBtn)
122 return (unitBtn, intBtn)
@@ -129,8 +144,8 @@ run = mdo
129
144
130 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)
145 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)
131 divClass "greeting-response" $ dynText =<<
146 divClass "greeting-response" $ dynText =<<
132− holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (snd <$> resp)
147+ holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)
133− , fmapMaybe reqFailure (snd <$> resp)])
148+ , fmapMaybe reqFailure (resp)])
134 return sayHiClicks
149 return sayHiClicks
135
150
136 dblBtn <- elClass "div" "demo-group" $ do
151 dblBtn <- elClass "div" "demo-group" $ do
@@ -141,11 +156,11 @@ run = mdo
141 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
156 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
142 dblinp) (tag (current reqCount) dblBtn)
157 dblinp) (tag (current reqCount) dblBtn)
143 divClass "double-errors" $ dynText =<<
158 divClass "double-errors" $ dynText =<<
144− holdDyn "(no errors)" (fmapMaybe reqFailure (snd <$> dblResp))
159+ holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))
145 el "br" (return ())
160 el "br" (return ())
146 divClass "double-result" $ el "p" $ dynText =<<
161 divClass "double-result" $ el "p" $ dynText =<<
147 holdDyn "No number yet" (fmap tShow $
162 holdDyn "No number yet" (fmap tShow $
148− fmapMaybe reqSuccess (snd <$> dblResp))
163+ fmapMaybe reqSuccess (dblResp))
149 return dblBtn
164 return dblBtn
150
165
151 mpGo <- elClass "div" "demo-group" $ do
166 mpGo <- elClass "div" "demo-group" $ do
@@ -155,7 +170,7 @@ run = mdo
155 multiResp <- multi b (tag (current reqCount) mpGo)
170 multiResp <- multi b (tag (current reqCount) mpGo)
156 dynText =<< holdDyn "No res yet" (fmap tShow $
171 dynText =<< holdDyn "No res yet" (fmap tShow $
157 fmapMaybe reqSuccess $
172 fmapMaybe reqSuccess $
158− (snd <$> multiResp))
173+ (multiResp))
159 return mpGo
174 return mpGo
160
175
161 return ()
176 return ()
@@ -165,12 +180,24 @@ run = mdo
165 elClass "div" "demo-group" $ do
180 elClass "div" "demo-group" $ do
166 text "JSON Unicode encoding test"
181 text "JSON Unicode encoding test"
167 txt <- value <$> textInput def
182 txt <- value <$> textInput def
168− ev <- button "Question"
183+ ev <- fmap (1 <$) $ button "Question"
169 let dQ = Right . Question <$> traceDyn "will send: " txt
184 let dQ = Right . Question <$> traceDyn "will send: " txt
170 rr <- qna dQ ev
185 rr <- qna dQ ev
171 el "p" $
186 el "p" $
172 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
187 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
173
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+
174showXhrResponse :: XhrResponse -> Text
201showXhrResponse :: XhrResponse -> Text
175showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
176 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−40
@@ -1,40 +0,0 @@
1−{ reflex-platform, ... }:
2−let
3− pkgs = import <nixpkgs> {};
4− c2n = reflex-platform.cabal2nixResult;
5−in reflex-platform.ghc.override {
6− overrides = self: super: {
7− servant-snap = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap) {});
8− snap = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap) {});
9− snap-server = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-server) {});
10− io-streams = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams) {});
11− io-streams-haproxy = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});
12− heist = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});
13− xmlhtml = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
14− snap-core = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-core) {});
15− servant = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant/servant) {});
16− Glob = pkgs.haskell.lib.dontCheck super.Glob;
17− natural-transformation = self.callPackage (
18− { mkDerivation, base, containers, fetchgit, quickcheck-instances
19− , stdenv, tasty, tasty-quickcheck
20− }:
21− mkDerivation {
22− pname = "natural-transformation";
23− version = "0.4";
24− src = fetchgit {
25− url = "https://github.com/ku-fpg/natural-transformation";
26− sha256 = "0xbnnxbf5ydszbhf7h5ra3mrqy4mcyqc3zb2k8bwm1zyqrz6v0fs";
27− rev = "b1200c09dcafd034e32846413913b74735c8ba56";
28− };
29− libraryHaskellDepends = [ base ];
30− testHaskellDepends = [
31− base containers quickcheck-instances tasty tasty-quickcheck
32− ];
33− homepage = "https://github.com/ku-fpg/natural-transformation";
34− description = "A natural transformation package";
35− license = stdenv.lib.licenses.bsd3;
36− }
37− ) {};
38− http-api-data = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/http-api-data) {});
39− };
40−}
overrides.nixdeleted−35
@@ -1,35 +0,0 @@
1−{ reflex-platform, ... }:
2−let
3−
4− nixpkgs = (import <nixpkgs> {});
5− dontCheck = nixpkgs.pkgs.haskell.lib.dontCheck;
6− cabal2nixResult = reflex-platform.cabal2nixResult;
7−
8−in
9−reflex-platform.ghcjs.override {
10− overrides = self: super: {
11− servant = dontCheck (self.callPackage (cabal2nixResult deps/servant/servant) {});
12− http-api-data = dontCheck (self.callPackage (cabal2nixResult deps/http-api-data) {});
13− natural-transformation = self.callPackage (
14− { mkDerivation, base, containers, fetchgit, quickcheck-instances
15− , stdenv, tasty, tasty-quickcheck
16− }:
17− mkDerivation {
18− pname = "natural-transformation";
19− version = "0.4";
20− src = fetchgit {
21− url = "https://github.com/ku-fpg/natural-transformation";
22− sha256 = "0xbnnxbf5ydszbhf7h5ra3mrqy4mcyqc3zb2k8bwm1zyqrz6v0fs";
23− rev = "b1200c09dcafd034e32846413913b74735c8ba56";
24− };
25− libraryHaskellDepends = [ base ];
26− testHaskellDepends = [
27− base containers quickcheck-instances tasty tasty-quickcheck
28− ];
29− homepage = "https://github.com/ku-fpg/natural-transformation";
30− description = "A natural transformation package";
31− license = stdenv.lib.licenses.bsd3;
32− }
33− ) {};
34− };
35−}
servant-reflex.cabal+36−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
@@ -11,42 +11,59 @@ Category: Web
11Build-type: Simple
11Build-type: Simple
12Cabal-version: >=1.10
12Cabal-version: >=1.10
13
13
14+Flag Example
15+ description: Enable example
16+ default: False
17+
14library
18library
15 exposed-modules:
19 exposed-modules:
16− Servant.Reflex
17− Servant.Reflex.Multi
18−
19− other-modules:
20 Servant.Common.BaseUrl
20 Servant.Common.BaseUrl
21 Servant.Common.Req
21 Servant.Common.Req
22+ Servant.Reflex
23+ Servant.Reflex.Multi
22
24
23 hs-source-dirs: src
25 hs-source-dirs: src
24 build-depends:
26 build-depends:
25− base >= 4.8 && < 4.10,
27+ base >= 4.8 && < 5,
26 bytestring >= 0.10 && < 0.11,
28 bytestring >= 0.10 && < 0.11,
27 case-insensitive >= 1.2.0.4 && < 1.3,
29 case-insensitive >= 1.2.0.4 && < 1.3,
28− containers >= 0.5.6 && < 0.6,
30+ containers >= 0.5.6 && < 0.7,
29 data-default >= 0.5 && < 0.8,
31 data-default >= 0.5 && < 0.8,
30− exceptions >= 0.8 && < 0.9,
32+ exceptions >= 0.8 && < 0.11,
31− ghcjs-dom >= 0.2 && < 0.3,
33+ ghcjs-dom >= 0.2 && < 0.10,
32− http-api-data >= 0.2 && < 0.4,
34+ http-api-data >= 0.3.6 && < 0.5,
33− http-media >= 0.6 && < 0.7,
35+ http-media >= 0.6 && < 0.9,
36+ jsaddle >= 0.8 && < 0.10,
34 mtl >= 2.2.1 && < 2.3,
37 mtl >= 2.2.1 && < 2.3,
35 network-uri >= 2.6 && < 2.7,
38 network-uri >= 2.6 && < 2.7,
36− reflex >= 0.5 && < 0.6,
39+ reflex >= 0.5 && < 0.9,
37− reflex-dom == 0.4 && < 0.5,
40+ reflex-dom-core >= 0.6 && < 0.7,
38 safe >= 0.3.9 && < 0.4,
41 safe >= 0.3.9 && < 0.4,
39− servant >= 0.8 && < 0.11,
42+ servant >= 0.16 && < 0.18,
43+ servant-auth >= 0.2.1 && < 0.4,
40 string-conversions >= 0.4 && < 0.5,
44 string-conversions >= 0.4 && < 0.5,
41 text >= 1.2 && < 1.3,
45 text >= 1.2 && < 1.3,
42 transformers >= 0.4 && < 0.6
46 transformers >= 0.4 && < 0.6
43
47
44− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
48+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
45
49
46 default-language: Haskell2010
50 default-language: Haskell2010
47
51
48executable example
52executable example
49− build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text
53+ if flag(Example)
54+ buildable: True
55+ else
56+ buildable: False
57+ build-depends:
58+ aeson,
59+ reflex,
60+ servant-reflex,
61+ base,
62+ scientific,
63+ servant,
64+ reflex-dom,
65+ reflex-dom-core,
66+ text
50 default-language: Haskell2010
67 default-language: Haskell2010
51 main-is: Example.hs
68 main-is: Example.hs
52 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+175−130
@@ -1,24 +1,25 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
6{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TupleSections #-}
9{-# LANGUAGE TupleSections #-}
10
10
11−{-# LANGUAGE EmptyCase #-}
12module Servant.Common.Req where
11module Servant.Common.Req where
13
12
14-------------------------------------------------------------------------------
13-------------------------------------------------------------------------------
15−import Control.Concurrent
16import Control.Applicative (liftA2, liftA3)
14import Control.Applicative (liftA2, liftA3)
17−import Control.Arrow (second)
15+import Control.Arrow ((&&&))
16+import Control.Concurrent
18import Control.Monad (join)
17import Control.Monad (join)
19import Control.Monad.IO.Class (MonadIO, liftIO)
18import Control.Monad.IO.Class (MonadIO, liftIO)
20import Data.Bifunctor (first)
19import Data.Bifunctor (first)
20+import qualified Data.ByteString.Builder as Builder
21import qualified Data.ByteString.Lazy.Char8 as BL
21import qualified Data.ByteString.Lazy.Char8 as BL
22+import Data.ByteString (ByteString)
22import qualified Data.Map as Map
23import qualified Data.Map as Map
23import Data.Maybe (catMaybes, fromMaybe)
24import Data.Maybe (catMaybes, fromMaybe)
24import Data.Functor.Compose
25import Data.Functor.Compose
@@ -27,40 +28,93 @@ import Data.Proxy (Proxy(..))
27import Data.Text (Text)
28import Data.Text (Text)
28import qualified Data.Text as T
29import qualified Data.Text as T
29import qualified Data.Text.Encoding as TE
30import qualified Data.Text.Encoding as TE
30−import Data.Traversable
31+import Data.Traversable (forM)
32+import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
33+import qualified Network.URI as N
31−import Reflex.Dom
34+import Reflex.Dom.Core hiding (tag)
32−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl, SupportsServantReflex)
35+import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
36+ SupportsServantReflex)
33import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
37import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
34import Web.HttpApiData (ToHttpApiData(..))
38import Web.HttpApiData (ToHttpApiData(..))
35-------------------------------------------------------------------------------
39-------------------------------------------------------------------------------
36import Servant.API.BasicAuth
40import Servant.API.BasicAuth
37
41
38
42
43+------------------------------------------------------------------------------
44+-- | The result of a request event
45+data ReqResult tag a
46+ = ResponseSuccess tag a XhrResponse
47+ -- ^ The succesfully decoded response from a request tagged with 'tag'
48+ | ResponseFailure tag Text XhrResponse
49+ -- ^ The failure response, which may have failed decoding or had
50+ -- a non-successful response code
51+ | RequestFailure tag Text
52+ -- ^ A failure to construct the request tagged with 'tag' at trigger time
53+ deriving (Functor)
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'
39
72
73+------------------------------------------------------------------------------
74+-- | Simple filter/accessor for successful responses, when you want to
75+-- ignore the error case. For example:
76+-- >> goodResponses <- fmapMaybe reqSuccess <$> clientFun triggers
77+reqSuccess :: ReqResult tag a -> Maybe a
40−data ReqResult a = ResponseSuccess a XhrResponse
78+reqSuccess (ResponseSuccess _ x _) = Just x
41− | ResponseFailure Text XhrResponse
79+reqSuccess _ = Nothing
42− | RequestFailure Text
43
80
44−instance Functor ReqResult where
45− fmap f (ResponseSuccess a xhr) = ResponseSuccess (f a) xhr
46− fmap _ (ResponseFailure r x) = ResponseFailure r x
47− fmap _ (RequestFailure r) = RequestFailure r
48
81
82+------------------------------------------------------------------------------
83+-- | Simple filter/accessor like 'reqSuccess', but keeping the request tag
49−reqSuccess :: ReqResult a -> Maybe a
84+reqSuccess' :: ReqResult tag a -> Maybe (tag,a)
50−reqSuccess (ResponseSuccess x _) = Just x
85+reqSuccess' (ResponseSuccess tag x _) = Just (tag,x)
51−reqSuccess _ = Nothing
86+reqSuccess' _ = Nothing
52
87
53−reqFailure :: ReqResult a -> Maybe Text
54−reqFailure (ResponseFailure s _) = Just s
55−reqFailure (RequestFailure s) = Just s
56−reqFailure _ = Nothing
57
88
89+------------------------------------------------------------------------------
90+-- | Simple filter/accessor for any failure case
58−response :: ReqResult a -> Maybe XhrResponse
91+reqFailure :: ReqResult tag a -> Maybe Text
59−response (ResponseSuccess _ x) = Just x
92+reqFailure (ResponseFailure _ s _) = Just s
93+reqFailure (RequestFailure _ s) = Just s
94+reqFailure _ = Nothing
95+
96+------------------------------------------------------------------------------
97+-- | Simple filter/accessor like 'reqFailure', but keeping the request tag
98+reqFailure' :: ReqResult tag a -> Maybe (tag,Text)
60−response (ResponseFailure _ x) = Just x
99+reqFailure' (ResponseFailure tag s _) = Just (tag,s)
100+reqFailure' (RequestFailure tag s) = Just (tag,s)
61−response _ = Nothing
101+reqFailure' _ = Nothing
62
102
63
103
104+------------------------------------------------------------------------------
105+-- | Simple filter/accessor for the raw XHR response
106+response :: ReqResult tag a -> Maybe XhrResponse
107+response (ResponseSuccess _ _ x) = Just x
108+response (ResponseFailure _ _ x) = Just x
109+response _ = Nothing
110+
111+------------------------------------------------------------------------------
112+-- | Retrieve response tag
113+reqTag :: ReqResult tag a -> tag
114+reqTag (ResponseSuccess tag _ _) = tag
115+reqTag (ResponseFailure tag _ _) = tag
116+reqTag (RequestFailure tag _ ) = tag
117+
64-------------------------------------------------------------------------------
118-------------------------------------------------------------------------------
65-- | You must wrap the parameter of a QueryParam endpoint with 'QParam' to
119-- | You must wrap the parameter of a QueryParam endpoint with 'QParam' to
66-- indicate whether the parameter is valid and present, validly absent, or
120-- indicate whether the parameter is valid and present, validly absent, or
@@ -72,11 +126,13 @@ data QParam a = QParamSome a
72 | QParamInvalid Text
126 | QParamInvalid Text
73 -- ^ Indication that your validation failed (the request isn't valid)
127 -- ^ Indication that your validation failed (the request isn't valid)
74
128
129+
75qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)
130qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)
76qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)
131qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)
77qParamToQueryPart QNone = Right Nothing
132qParamToQueryPart QNone = Right Nothing
78qParamToQueryPart (QParamInvalid e) = Left e
133qParamToQueryPart (QParamInvalid e) = Left e
79
134
135+
80data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
136data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
81 | QueryPartParams (Dynamic t [Text])
137 | QueryPartParams (Dynamic t [Text])
82 | QueryPartFlag (Dynamic t Bool)
138 | QueryPartFlag (Dynamic t Bool)
@@ -111,7 +167,7 @@ reqToReflexRequest
111 => Text
167 => Text
112 -> Dynamic t BaseUrl
168 -> Dynamic t BaseUrl
113 -> Req t
169 -> Req t
114− -> (Dynamic t (Either Text (XhrRequest XhrPayload)))
170+ -> Dynamic t (Either Text (XhrRequest XhrPayload))
115reqToReflexRequest reqMeth reqHost req =
171reqToReflexRequest reqMeth reqHost req =
116 let t :: Dynamic t [Either Text Text]
172 let t :: Dynamic t [Either Text Text]
117 t = sequence $ reverse $ reqPathParts req
173 t = sequence $ reverse $ reqPathParts req
@@ -123,18 +179,22 @@ reqToReflexRequest reqMeth reqHost req =
123 urlParts = fmap sequence t
179 urlParts = fmap sequence t
124
180
125 urlPath :: Dynamic t (Either Text Text)
181 urlPath :: Dynamic t (Either Text Text)
126− urlPath = (fmap.fmap) (T.intercalate "/") urlParts
182+ urlPath = (fmap.fmap)
183+ (T.intercalate "/" . fmap escape)
184+ urlParts
127
185
128 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
186 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
129 queryPartString (pName, qp) = case qp of
187 queryPartString (pName, qp) = case qp of
130 QueryPartParam p -> ffor p $ \case
188 QueryPartParam p -> ffor p $ \case
131 Left e -> Just (Left e)
189 Left e -> Just (Left e)
132− Right (Just a) -> Just (Right $ pName <> "=" <> a)
190+ Right (Just a) -> Just (Right $ pName <> "=" <> escape a)
133 Right Nothing -> Nothing
191 Right Nothing -> Nothing
134 QueryPartParams ps -> ffor ps $ \pStrings ->
192 QueryPartParams ps -> ffor ps $ \pStrings ->
135 if null pStrings
193 if null pStrings
136 then Nothing
194 then Nothing
195+ else Just . Right
196+ . T.intercalate "&"
137− else Just $ Right (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) pStrings))
197+ $ fmap (\p -> pName <> "=" <> escape p) pStrings
138 QueryPartFlag fl -> ffor fl $ \case
198 QueryPartFlag fl -> ffor fl $ \case
139 True -> Just $ Right pName
199 True -> Just $ Right pName
140 False -> Nothing
200 False -> Nothing
@@ -169,10 +229,10 @@ reqToReflexRequest reqMeth reqHost req =
169 Right $ XhrRequestConfig
229 Right $ XhrRequestConfig
170 { _xhrRequestConfig_sendData = bytesToPayload bBytes
230 { _xhrRequestConfig_sendData = bytesToPayload bBytes
171 , _xhrRequestConfig_headers =
231 , _xhrRequestConfig_headers =
172− Map.insert "Content-Type" bCT (Map.fromList hs)
232+ Map.insert "Content-Type" bCT (Map.fromList hs)
173 , _xhrRequestConfig_user = Nothing
233 , _xhrRequestConfig_user = Nothing
174 , _xhrRequestConfig_password = Nothing
234 , _xhrRequestConfig_password = Nothing
175− , _xhrRequestConfig_responseType = Nothing
235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
176 , _xhrRequestConfig_withCredentials = False
236 , _xhrRequestConfig_withCredentials = False
177 , _xhrRequestConfig_responseHeaders = def
237 , _xhrRequestConfig_responseHeaders = def
178 }
238 }
@@ -184,8 +244,8 @@ reqToReflexRequest reqMeth reqHost req =
184 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
244 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
185 , _xhrRequestConfig_user = Nothing
245 , _xhrRequestConfig_user = Nothing
186 , _xhrRequestConfig_password = Nothing
246 , _xhrRequestConfig_password = Nothing
187− , _xhrRequestConfig_responseType = Nothing
247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
188− , _xhrRequestConfig_sendData = ""
248+ , _xhrRequestConfig_sendData = mempty
189 , _xhrRequestConfig_withCredentials = False
249 , _xhrRequestConfig_withCredentials = False
190 }
250 }
191 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
@@ -212,41 +272,55 @@ reqToReflexRequest reqMeth reqHost req =
212displayHttpRequest :: Text -> Text
272displayHttpRequest :: Text -> Text
213displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
273displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
214
274
215−-- | This function actually performs the request.
275+-- | This function performs the request
216performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
276performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
217 => Text
277 => Text
218 -> Dynamic t (f (Req t))
278 -> Dynamic t (f (Req t))
219 -> Dynamic t BaseUrl
279 -> Dynamic t BaseUrl
280+ -> ClientOptions
220 -> Event t tag
281 -> Event t tag
221 -> m (Event t (tag, f (Either Text XhrResponse)))
282 -> m (Event t (tag, f (Either Text XhrResponse)))
222−performRequests reqMeth rs reqHost trigger = do
283+performRequests reqMeth rs reqHost opts trigger = do
223− -- 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 $
224− 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
225− let reqs = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
290+ (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
291+
226− resps <- performSomeRequestsAsync reqs
292+ resps <- performSomeRequestsAsync opts reqs
227 return $ getCompose <$> resps
293 return $ getCompose <$> resps
228
294
229−-- | 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.
230performSomeRequestsAsync
298performSomeRequestsAsync
231 :: (MonadIO (Performable m),
299 :: (MonadIO (Performable m),
300+ MonadJSM (Performable m),
232 HasWebView (Performable m),
301 HasWebView (Performable m),
233 PerformEvent t m,
302 PerformEvent t m,
234 TriggerEvent t m,
303 TriggerEvent t m,
235 Traversable f,
304 Traversable f,
236− IsXhrPayload a)
305+ IsXhrPayload a,
306+ Show a
307+ )
308+ => ClientOptions
237− => Event t (f (Either Text (XhrRequest a)))
309+ -> Event t (f (Either Text (XhrRequest a)))
238 -> m (Event t (f (Either Text XhrResponse)))
310 -> m (Event t (f (Either Text XhrResponse)))
311+performSomeRequestsAsync opts =
239−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return
312+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
240
313
241
314
242------------------------------------------------------------------------------
315------------------------------------------------------------------------------
243-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
316-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
244-- that accepts 'f (Either e (XhrRequestb))' events
317-- that accepts 'f (Either e (XhrRequestb))' events
245performSomeRequestsAsync'
318performSomeRequestsAsync'
246− :: (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
247− => (XhrRequest b -> (a -> IO ()) -> Performable m XMLHttpRequest)
321+ -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
248 -> 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)))
249−performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
323+performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
250 rs <- hrs
324 rs <- hrs
251 resps <- forM rs $ \r -> case r of
325 resps <- forM rs $ \r -> case r of
252 Left e -> do
326 Left e -> do
@@ -254,69 +328,17 @@ performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb ->
254 return resp
328 return resp
255 Right r' -> do
329 Right r' -> do
256 resp <- liftIO newEmptyMVar
330 resp <- liftIO newEmptyMVar
331+ r'' <- liftJSM $ (optsRequestFixup opts) r'
257− _ <- newXhr r' $ liftIO . putMVar resp . Right
332+ _ <- newXhr r'' $ liftIO . putMVar resp . Right
258 return resp
333 return resp
259 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
334 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
260 return ()
335 return ()
261
336
262
337
263
338
264−-- | This function actually performs the request.
265−performRequest :: forall t m tag .(SupportsServantReflex t m)
266− => Text
267− -> (Req t)
268− -> Dynamic t BaseUrl
269− -> Event t tag
270− -> m (Event t (tag, XhrResponse), Event t (tag, Text))
271−performRequest reqMeth req reqHost trigger = do
272−
273− let xhrReq = reqToReflexRequest reqMeth reqHost req
274− let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger
275− okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) e) reqs
276− badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) e) reqs
277−
278− resps <- performRequestsAsync okReqs
279−
280− return (resps, badReqs)
281−
282−
283−type XhrPayload = T.Text
339+type XhrPayload = ByteString
284bytesToPayload :: BL.ByteString -> XhrPayload
340bytesToPayload :: BL.ByteString -> XhrPayload
285−bytesToPayload = TE.decodeUtf8 . BL.toStrict
341+bytesToPayload = BL.toStrict
286−
287−
288−performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)
289− => Text
290− -> Req t
291− -> Dynamic t BaseUrl
292− -> Event t tag -> m (Event t (tag, ReqResult NoContent))
293−performRequestNoBody reqMeth req reqHost trigger = do
294− (resp, badReq) <- performRequest reqMeth req reqHost trigger
295− let decodeResp = const $ Right NoContent
296− return $ leftmost [ fmap (second (evalResponse decodeResp)) resp,
297− fmap (second RequestFailure) badReq]
298−
299−
300−
301−performRequestCT
302− :: (SupportsServantReflex t m,
303− MimeUnrender ct a)
304− => Proxy ct
305− -> Text
306− -> Req t
307− -> Dynamic t BaseUrl
308− -> Event t tag
309− -> m (Event t (tag, ReqResult a))
310−performRequestCT ct reqMeth req reqHost trigger = do
311− (resp, badReq) <- performRequest reqMeth req reqHost trigger
312− let decodeResp x = first T.pack .
313− mimeUnrender ct .
314− BL.fromStrict .
315− TE.encodeUtf8 =<< note "No body text"
316− (_xhrResponse_responseText x)
317−
318− return $ leftmost [fmap (second (evalResponse decodeResp)) resp,
319− fmap (second RequestFailure) badReq]
320
342
321
343
322performRequestsCT
344performRequestsCT
@@ -326,20 +348,22 @@ performRequestsCT
326 -> Text
348 -> Text
327 -> Dynamic t (f (Req t))
349 -> Dynamic t (f (Req t))
328 -> Dynamic t BaseUrl
350 -> Dynamic t BaseUrl
351+ -> ClientOptions
329 -> Event t tag
352 -> Event t tag
330− -> m (Event t (tag, f (ReqResult a)))
353+ -> m (Event t (f (ReqResult tag a)))
331−performRequestsCT ct reqMeth reqs reqHost trigger = do
354+performRequestsCT ct reqMeth reqs reqHost opts trigger = do
332− resps <- performRequests reqMeth reqs reqHost trigger
355+ resps <- performRequests reqMeth reqs reqHost opts trigger
356+ let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
333− let decodeResp x = first T.pack .
357+ first T.pack .
334− mimeUnrender ct .
358+ mimeUnrender ct $
335− BL.fromStrict .
359+ BL.fromStrict x
336− TE.encodeUtf8 =<< note "No body text"
360+ decodeResp _ = Left "No body"
337− (_xhrResponse_responseText x)
338− return $ ffor resps $ \(t, rs) ->
361+ return $ fmap
339− (t, ffor rs $ \r -> case r of
362+ (\(t,rs) -> ffor rs $ \r -> case r of
340− Left e -> RequestFailure e
363+ Left e -> RequestFailure t e
341− Right g -> evalResponse decodeResp g
364+ Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
342 )
365 )
366+ resps
343
367
344
368
345performRequestsNoBody
369performRequestsNoBody
@@ -348,34 +372,48 @@ performRequestsNoBody
348 => Text
372 => Text
349 -> Dynamic t (f (Req t))
373 -> Dynamic t (f (Req t))
350 -> Dynamic t BaseUrl
374 -> Dynamic t BaseUrl
375+ -> ClientOptions
351 -> Event t tag
376 -> Event t tag
352− -> m (Event t (tag, f (ReqResult NoContent)))
377+ -> m (Event t (f (ReqResult tag NoContent)))
353−performRequestsNoBody reqMeth reqs reqHost trigger = do
378+performRequestsNoBody reqMeth reqs reqHost opts trigger = do
354− resps <- performRequests reqMeth reqs reqHost trigger
379+ resps <- performRequests reqMeth reqs reqHost opts trigger
355 let decodeResp = const $ Right NoContent
380 let decodeResp = const $ Right NoContent
356− return $ ffor resps $ \(t, rs) ->
381+ return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
357− (t, ffor rs $ \r -> case r of
358− Left e -> RequestFailure e
382+ Left e -> RequestFailure tag e
359− Right g -> evalResponse decodeResp g
383+ Right g -> evalResponse decodeResp (tag,g)
360− )
361−
362
384
363
385
364------------------------------------------------------------------------------
386------------------------------------------------------------------------------
387+evalResponse
365−evalResponse :: (XhrResponse -> Either Text a) -> XhrResponse -> ReqResult a
388+ :: (XhrResponse -> Either Text a)
389+ -> (tag, XhrResponse)
390+ -> ReqResult tag a
366−evalResponse decode xhr =
391+evalResponse decode (tag, xhr) =
367− let okStatus = _xhrResponse_status xhr < 400
392+ let status = _xhrResponse_status xhr
393+ okStatus = status >= 200 && status < 400
368 errMsg = fromMaybe
394 errMsg = fromMaybe
369 ("Empty response with error code " <>
395 ("Empty response with error code " <>
370 T.pack (show $ _xhrResponse_status xhr))
396 T.pack (show $ _xhrResponse_status xhr))
371 (_xhrResponse_responseText xhr)
397 (_xhrResponse_responseText xhr)
372 respPayld = if okStatus
398 respPayld = if okStatus
399+ then either
373− then either (flip ResponseFailure xhr)
400+ (\e -> ResponseFailure tag e xhr)
374− (flip ResponseSuccess xhr) (decode xhr)
401+ (\v -> ResponseSuccess tag v xhr)
402+ (decode xhr)
375− else ResponseFailure errMsg xhr
403+ else ResponseFailure tag errMsg xhr
376 in respPayld
404 in respPayld
377
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
378
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'
379
417
380
418
381note :: e -> Maybe a -> Either e a
419note :: e -> Maybe a -> Either e a
@@ -384,3 +422,10 @@ note e = maybe (Left e) Right
384fmapL :: (e -> e') -> Either e a -> Either e' a
422fmapL :: (e -> e') -> Either e a -> Either e' a
385fmapL _ (Right a) = Right a
423fmapL _ (Right a) = Right a
386fmapL 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+215−112
@@ -1,24 +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 OverloadedStrings #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TupleSections #-}
11−{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
15−{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE OverloadedStrings #-}
16−{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE Rank2Types #-}
17−{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
18−{-# LANGUAGE TupleSections #-}
13+{-# LANGUAGE TupleSections #-}
19−{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeFamilies #-}
20−{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE TypeOperators #-}
21−{-# LANGUAGE UndecidableInstances #-}
16+{-# LANGUAGE UndecidableInstances #-}
17+
18+#if MIN_VERSION_base(4,9,0)
19+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
20+#endif
22
21
23-- #include "overlapping-compat.h"
22-- #include "overlapping-compat.h"
24-- | This module provides 'client' which can automatically generate
23-- | This module provides 'client' which can automatically generate
@@ -26,56 +25,70 @@
26-- API.
25-- API.
27module Servant.Reflex
26module Servant.Reflex
28 ( client
27 ( client
28+ , clientWithOpts
29+ , clientWithOptsAndResultHandler
30+ , clientWithRoute
31+ , clientWithRouteAndResultHandler
29 , BuildHeaderKeysTo(..)
32 , BuildHeaderKeysTo(..)
30 , toHeaders
33 , toHeaders
31− , HasClient(..)
34+ , HasClient
35+ , Client
32 , module Servant.Common.Req
36 , module Servant.Common.Req
33 , module Servant.Common.BaseUrl
37 , module Servant.Common.BaseUrl
34 ) where
38 ) where
35
39
36------------------------------------------------------------------------------
40------------------------------------------------------------------------------
37import Control.Applicative
41import Control.Applicative
42+import qualified Data.CaseInsensitive as CI
43+import Data.Functor.Identity
44+import qualified Data.Map as Map
38import Data.Monoid ((<>))
45import Data.Monoid ((<>))
39−import qualified Data.Set as Set
40−import qualified Data.Text.Encoding as E
41−import Data.CaseInsensitive (mk)
42import Data.Proxy (Proxy (..))
46import Data.Proxy (Proxy (..))
43−import qualified Data.Map as Map
47+import qualified Data.Set as Set
44import Data.Text (Text)
48import Data.Text (Text)
45import qualified Data.Text as T
49import qualified Data.Text as T
50+import qualified Data.Text.Encoding as E
51+import GHC.Exts (Constraint)
46import GHC.TypeLits (KnownSymbol, symbolVal)
52import GHC.TypeLits (KnownSymbol, symbolVal)
47−import Servant.API ((:<|>)(..),(:>), BasicAuth,
53+import Servant.API ((:<|>) (..), (:>), BasicAuth,
48− BasicAuthData, BuildHeadersTo(..),
54+ BasicAuthData, BuildHeadersTo (..),
49− Capture, contentType, Header,
55+ Capture, Header, Headers (..),
50− Headers(..), HttpVersion, IsSecure,
56+ HttpVersion, IsSecure,
51− MimeRender(..), MimeUnrender,
57+ MimeRender (..), MimeUnrender,
52 NoContent, QueryFlag, QueryParam,
58 NoContent, QueryFlag, QueryParam,
53− QueryParams, Raw, ReflectMethod(..),
59+ QueryParams, Raw, ReflectMethod (..),
54 RemoteHost, ReqBody,
60 RemoteHost, ReqBody,
55− ToHttpApiData(..), Vault, Verb)
61+ ToHttpApiData (..), Vault, Verb,
56−
62+ contentType)
63+import Servant.API.Description (Summary)
64+import qualified Servant.Auth as Auth
65+
57−import Reflex.Dom (Dynamic, Event, Reflex,
66+import Reflex.Dom.Core (Dynamic, Event, Reflex,
58− XhrRequest(..),
67+ XhrRequest (..), XhrResponse (..),
59− XhrResponseHeaders(..),
68+ XhrResponseHeaders (..),
60− XhrResponse(..), attachPromptlyDynWith, ffor, fmapMaybe,
69+ attachPromptlyDynWith, constDyn, ffor,
70+ fmapMaybe, leftmost,
61− leftmost, performRequestsAsync,
71+ performRequestsAsync)
62− )
63------------------------------------------------------------------------------
72------------------------------------------------------------------------------
64import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
73import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
65 showBaseUrl,
74 showBaseUrl,
66 SupportsServantReflex)
75 SupportsServantReflex)
76+import Servant.Common.Req (ClientOptions(..),
77+ defaultClientOptions,
67−import Servant.Common.Req (Req, ReqResult(..), QParam(..),
78+ Req, ReqResult(..), QParam(..),
68 QueryPart(..), addHeader, authData,
79 QueryPart(..), addHeader, authData,
69− defReq, prependToPathParts,
80+ defReq, evalResponse, prependToPathParts,
70− performRequestCT,
81+ -- performRequestCT,
71 performRequestsCT,
82 performRequestsCT,
72− performRequestNoBody,
83+ -- performRequestNoBody,
73 performRequestsNoBody,
84 performRequestsNoBody,
74 performSomeRequestsAsync,
85 performSomeRequestsAsync,
75 qParamToQueryPart, reqBody,
86 qParamToQueryPart, reqBody,
76 reqSuccess, reqFailure,
87 reqSuccess, reqFailure,
77− reqMethod, respHeaders, response,
88+ reqMethod, respHeaders,
89+ response,
90+ reqTag,
78− qParams)
91+ qParams, withCredentials)
79
92
80
93
81-- * Accessing APIs as a Client
94-- * Accessing APIs as a Client
@@ -90,28 +103,75 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),
90-- >
103-- >
91-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
104-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
92-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
105-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
93−-- -> m (Event t (l, ReqResult Book)))
106+-- > -> m (Event t (l, ReqResult Book)))
94-- > (getAllBooks :<|> postNewBook) = client myApi host
107-- > (getAllBooks :<|> postNewBook) = client myApi host
95-- > where host = constDyn $ BaseUrl Http "localhost" 8080
108-- > where host = constDyn $ BaseUrl Http "localhost" 8080
109+client
96−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
97− => Proxy layout -> Proxy m -> Proxy tag -> Dynamic t BaseUrl -> Client t m layout tag
125+ -> Client t m layout tag
98−client p q t baseurl = clientWithRoute p q t defReq baseurl
126+clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
127+
128+-- | Like 'clientWithOpts' but allows passing a function which will process the
129+-- result event in some way. This can be used to handle errors in a uniform way
130+-- across call sites.
131+clientWithOptsAndResultHandler
132+ :: (HasClient t m layout tag)
133+ => Proxy layout
134+ -> Proxy m
135+ -> Proxy tag
136+ -> Dynamic t BaseUrl
137+ -> ClientOptions
138+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
139+ -> Client t m layout tag
140+clientWithOptsAndResultHandler p q t = clientWithRouteAndResultHandler p q t defReq
99
141
100
142
101-- | This class lets us define how each API combinator
143-- | This class lets us define how each API combinator
102-- influences the creation of an HTTP request. It's mostly
144-- influences the creation of an HTTP request. It's mostly
103-- an internal class, you can just use 'client'.
145-- an internal class, you can just use 'client'.
104−class HasClient t m layout (tag :: *) where
146+class Monad m => HasClient t m layout (tag :: *) where
105 type Client t m layout tag :: *
147 type Client t m layout tag :: *
106− 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
107
167
108
168
109instance (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
110 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
111
171
112− clientWithRoute Proxy q pTag req baseurl =
172+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =
113− clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>
173+ clientWithRouteAndResultHandler (Proxy :: Proxy a) q pTag req baseurl opts wrap :<|>
114− clientWithRoute (Proxy :: Proxy b) q pTag req baseurl
174+ clientWithRouteAndResultHandler (Proxy :: Proxy b) q pTag req baseurl opts wrap
115
175
116
176
117-- Capture. Example:
177-- Capture. Example:
@@ -132,11 +192,9 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
132 type Client t m (Capture capture a :> sublayout) tag =
192 type Client t m (Capture capture a :> sublayout) tag =
133 Dynamic t (Either Text a) -> Client t m sublayout tag
193 Dynamic t (Either Text a) -> Client t m sublayout tag
134
194
135− clientWithRoute Proxy q t req baseurl val =
195+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
136− clientWithRoute (Proxy :: Proxy sublayout)
196+ clientWithRouteAndResultHandler
137− q t
138− (prependToPathParts p req)
197+ (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
139− baseurl
140 where p = (fmap . fmap) (toUrlPiece) val
198 where p = (fmap . fmap) (toUrlPiece) val
141
199
142
200
@@ -146,11 +204,11 @@ instance {-# OVERLAPPABLE #-}
146 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
204 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
147 ) => HasClient t m (Verb method status cts' a) tag where
205 ) => HasClient t m (Verb method status cts' a) tag where
148 type Client t m (Verb method status cts' a) tag =
206 type Client t m (Verb method status cts' a) tag =
149− Event t tag -> m (Event t (tag, ReqResult a))
207+ Event t tag -> m (Event t (ReqResult tag a))
150 -- TODO how to access input types here?
208 -- TODO how to access input types here?
151 -- ExceptT ServantError IO a
209 -- ExceptT ServantError IO a
152− clientWithRoute Proxy _ _ req baseurl trigs =
210+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
153− performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs
211+ wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
154 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
212 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
155 req' = req { reqMethod = method }
213 req' = req { reqMethod = method }
156
214
@@ -160,32 +218,36 @@ instance {-# OVERLAPPING #-}
160 (ReflectMethod method, SupportsServantReflex t m) =>
218 (ReflectMethod method, SupportsServantReflex t m) =>
161 HasClient t m (Verb method status cts NoContent) tag where
219 HasClient t m (Verb method status cts NoContent) tag where
162 type Client t m (Verb method status cts NoContent) tag =
220 type Client t m (Verb method status cts NoContent) tag =
163− Event t tag -> m (Event t (tag, ReqResult NoContent))
221+ Event t tag -> m (Event t (ReqResult tag NoContent))
164 -- TODO: how to access input types here?
222 -- TODO: how to access input types here?
165 -- ExceptT ServantError IO NoContent
223 -- ExceptT ServantError IO NoContent
166− clientWithRoute Proxy _ _ req baseurl =
224+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
167− performRequestNoBody method req baseurl
225+ wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
168 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
226 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
169
227
170
228
171−toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)
229+toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
172toHeaders r =
230toHeaders r =
173− let toBS = E.encodeUtf8
174− hdrs = maybe []
231+ let hdrs = maybe []
175− (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
232+ (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
176 (Map.toList $ _xhrResponse_headers xhr))
233 (Map.toList $ _xhrResponse_headers xhr))
177 (response r)
234 (response r)
178 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
235 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
179
236
237+
180class BuildHeaderKeysTo hs where
238class BuildHeaderKeysTo hs where
181− buildHeaderKeysTo :: Proxy hs -> [T.Text]
239+ buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
182
240
183instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
241instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
184 where buildHeaderKeysTo _ = []
242 where buildHeaderKeysTo _ = []
185
243
186instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
244instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
187− => 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))
188− buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
249+ in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)
250+
189
251
190-- HEADERS Verb (Content) --
252-- HEADERS Verb (Content) --
191-- Headers combinator not treated in fully general case,
253-- Headers combinator not treated in fully general case,
@@ -199,11 +261,11 @@ instance {-# OVERLAPPABLE #-}
199 SupportsServantReflex t m
261 SupportsServantReflex t m
200 ) => 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
201 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 =
202− Event t tag -> m (Event t (tag, ReqResult (Headers ls a)))
264+ Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
203− clientWithRoute Proxy _ _ req baseurl = do
265+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
204 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
266 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
205− resp <- performRequestCT (Proxy :: Proxy ct) method req' baseurl
267+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
206− return $ (fmap . fmap) toHeaders <$> resp
268+ wrap $ toHeaders <$> resp
207 where req' = req { respHeaders =
269 where req' = req { respHeaders =
208 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
270 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
209 }
271 }
@@ -215,11 +277,11 @@ instance {-# OVERLAPPABLE #-}
215 SupportsServantReflex t m
277 SupportsServantReflex t m
216 ) => 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
217 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
218− = Event t tag -> m (Event t (tag, ReqResult (Headers ls NoContent)))
280+ = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
219− clientWithRoute Proxy _ _ req baseurl = do
281+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
220 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
282 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
221− resp <- performRequestNoBody method req' baseurl
283+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
222− return $ (fmap . fmap) toHeaders <$> resp
284+ wrap $ toHeaders <$> resp
223 where req' = req {respHeaders =
285 where req' = req {respHeaders =
224 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
286 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
225 }
287 }
@@ -246,11 +308,11 @@ instance (KnownSymbol sym, ToHttpApiData a,
246 type Client t m (Header sym a :> sublayout) tag =
308 type Client t m (Header sym a :> sublayout) tag =
247 Dynamic t (Either Text a) -> Client t m sublayout tag
309 Dynamic t (Either Text a) -> Client t m sublayout tag
248
310
249− clientWithRoute Proxy q t req baseurl eVal =
311+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =
312+ clientWithRouteAndResultHandler
250− clientWithRoute (Proxy :: Proxy sublayout)
313+ (Proxy :: Proxy sublayout) q t
251− q t
252− (Servant.Common.Req.addHeader hname eVal req)
314+ (Servant.Common.Req.addHeader hname eVal req)
253− baseurl
315+ baseurl opts wrap
254 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
316 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
255
317
256
318
@@ -264,8 +326,21 @@ instance HasClient t m sublayout tag
264 type Client t m (HttpVersion :> sublayout) tag =
326 type Client t m (HttpVersion :> sublayout) tag =
265 Client t m sublayout tag
327 Client t m sublayout tag
266
328
267− clientWithRoute Proxy q t =
329+ clientWithRouteAndResultHandler Proxy =
330+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
331+
332+-- | Using a 'Summary' combinator in your API doesn't affect the client
333+-- functions.
334+instance (HasClient t m sublayout tag, KnownSymbol sym)
335+ => HasClient t m (Summary sym :> sublayout) tag where
336+
337+ type Client t m (Summary sym :> sublayout) tag =
338+ Client t m sublayout tag
339+
340+ clientWithRouteAndResultHandler Proxy =
268− clientWithRoute (Proxy :: Proxy sublayout) q t
341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
342+
343+
269
344
270
345
271-- | 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,
@@ -301,9 +376,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
301 Dynamic t (QParam a) -> Client t m sublayout tag
376 Dynamic t (QParam a) -> Client t m sublayout tag
302
377
303 -- 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
304− clientWithRoute Proxy q t req baseurl mparam =
379+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
305− clientWithRoute (Proxy :: Proxy sublayout) q t
380+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
306− (req {qParams = paramPair : qParams req}) baseurl
381+ (req {qParams = paramPair : qParams req}) baseurl opts wrap
307
382
308 where pname = symbolVal (Proxy :: Proxy sym)
383 where pname = symbolVal (Proxy :: Proxy sym)
309 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
384 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -347,8 +422,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
347 type Client t m (QueryParams sym a :> sublayout) tag =
422 type Client t m (QueryParams sym a :> sublayout) tag =
348 Dynamic t [a] -> Client t m sublayout tag
423 Dynamic t [a] -> Client t m sublayout tag
349
424
350− clientWithRoute Proxy q t req baseurl paramlist =
425+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
351− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
426+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
352
427
353 where req' = req { qParams = (T.pack pname, params') : qParams req }
428 where req' = req { qParams = (T.pack pname, params') : qParams req }
354 pname = symbolVal (Proxy :: Proxy sym)
429 pname = symbolVal (Proxy :: Proxy sym)
@@ -387,8 +462,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
387 type Client t m (QueryFlag sym :> sublayout) tag =
462 type Client t m (QueryFlag sym :> sublayout) tag =
388 Dynamic t Bool -> Client t m sublayout tag
463 Dynamic t Bool -> Client t m sublayout tag
389
464
390− clientWithRoute Proxy q t req baseurl flag =
465+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
391− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
466+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
392
467
393 where req' = req { qParams = thisPair : qParams req }
468 where req' = req { qParams = thisPair : qParams req }
394 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
469 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -400,9 +475,9 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
400instance SupportsServantReflex t m => HasClient t m Raw tag where
475instance SupportsServantReflex t m => HasClient t m Raw tag where
401 type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))
476 type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))
402 -> Event t tag
477 -> Event t tag
403− -> m (Event t (tag, ReqResult ()))
478+ -> m (Event t (ReqResult tag ()))
404
479
405− clientWithRoute _ _ _ _ baseurl xhrs triggers = do
480+ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
406
481
407 let xhrs' = liftA2 (\x path -> case x of
482 let xhrs' = liftA2 (\x path -> case x of
408 Left e -> Left e
483 Left e -> Left e
@@ -413,8 +488,9 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
413 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 ())
414
489
415 resps <- performRequestsAsync okReq
490 resps <- performRequestsAsync okReq
416− return $ leftmost [ fmap (ResponseSuccess ()) <$> resps
417− , fmap (RequestFailure) <$> badReq ]
491+ wrap $ leftmost [ uncurry RequestFailure <$> badReq
492+ , evalResponse (const $ Right ()) <$> resps
493+ ]
418
494
419
495
420-- | If you use a 'ReqBody' in one of your endpoints in your API,
496-- | If you use a 'ReqBody' in one of your endpoints in your API,
@@ -443,8 +519,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
443 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
519 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
444 Dynamic t (Either Text a) -> Client t m sublayout tag
520 Dynamic t (Either Text a) -> Client t m sublayout tag
445
521
446− clientWithRoute Proxy q t req baseurl body =
522+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
447− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
523+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
448 where req' = req { reqBody = bodyBytesCT }
524 where req' = req { reqBody = bodyBytesCT }
449 ctProxy = Proxy :: Proxy ct
525 ctProxy = Proxy :: Proxy ct
450 ctString = T.pack $ show $ contentType ctProxy
526 ctString = T.pack $ show $ contentType ctProxy
@@ -458,9 +534,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
458instance (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
459 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
460
536
461− clientWithRoute Proxy q t req baseurl =
537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =
462− clientWithRoute (Proxy :: Proxy sublayout) q t
538+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
463− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl
539+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap
464
540
465 where p = symbolVal (Proxy :: Proxy path)
541 where p = symbolVal (Proxy :: Proxy path)
466
542
@@ -468,23 +544,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient
468instance 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
469 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
470
546
471− clientWithRoute Proxy q t req baseurl =
547+ clientWithRouteAndResultHandler Proxy =
472− clientWithRoute (Proxy :: Proxy api) q t req baseurl
548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
473
549
474
550
475instance 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
476 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
477
553
478− clientWithRoute Proxy q t req baseurl =
554+ clientWithRouteAndResultHandler Proxy =
479− clientWithRoute (Proxy :: Proxy api) q t req baseurl
555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
480
556
481
557
482
558
483instance 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
484 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
485
561
486− clientWithRoute Proxy q t req baseurl =
562+ clientWithRouteAndResultHandler Proxy =
487− clientWithRoute (Proxy :: Proxy api) q t req baseurl
563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
488
564
489
565
490instance (HasClient t m api tag, Reflex t)
566instance (HasClient t m api tag, Reflex t)
@@ -493,8 +569,8 @@ instance (HasClient t m api tag, Reflex t)
493 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)
494 -> Client t m api tag
570 -> Client t m api tag
495
571
496− clientWithRoute Proxy q t req baseurl authdata =
572+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
497− clientWithRoute (Proxy :: Proxy api) q t req' baseurl
573+ clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
498 where
574 where
499 req' = req { authData = Just authdata }
575 req' = req { authData = Just authdata }
500
576
@@ -520,3 +596,30 @@ non-empty lists, but is otherwise more specific, no instance will be overall
520more specific. This in turn generally means adding yet another instance (one
596more specific. This in turn generally means adding yet another instance (one
521for empty and one for non-empty lists).
597for empty and one for non-empty lists).
522-}
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+126−96
@@ -1,69 +1,82 @@
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 InstanceSigs #-}
6+{-# LANGUAGE InstanceSigs #-}
7−{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TupleSections #-}
11−{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TupleSections #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE UndecidableInstances #-}
15+
16+module Servant.Reflex.Multi (
17+ -- * Compute servant client functions
18+ clientA
19+ , clientWithOptsA
20+ , BaseUrl(..)
21+ , Scheme(..)
22+
23+ -- * Build QueryParam arguments
24+ , QParam(..)
25+
26+ -- * Access response data
27+ , withCredentials
28+
29+ -- * Access response data
30+ , ReqResult(..)
31+ , reqSuccess
32+ , reqSuccess'
33+ , reqFailure
34+ , response
15
35
16−module Servant.Reflex.Multi
17− ( clientA
18 , HasClientMulti(..)
36 , HasClientMulti(..)
19 ) where
37 ) where
20
38
21------------------------------------------------------------------------------
39------------------------------------------------------------------------------
22−import Control.Applicative
40+import Control.Applicative (liftA2)
23−import Control.Arrow (second)
24−import Data.Functor.Compose
41+import Data.Functor.Compose (Compose (..), getCompose)
25−import Data.Monoid ((<>))
26−import qualified Data.Set as Set
27−import qualified Data.Text.Encoding as E
28−import Data.CaseInsensitive (mk)
29import Data.Proxy (Proxy (..))
42import Data.Proxy (Proxy (..))
30−import qualified Data.Map as Map
43+import qualified Data.Set as Set
31import Data.Text (Text)
44import Data.Text (Text)
32import qualified Data.Text as T
45import qualified Data.Text as T
46+import qualified Data.Text.Encoding as E
33import GHC.TypeLits (KnownSymbol, symbolVal)
47import GHC.TypeLits (KnownSymbol, symbolVal)
34−import Servant.API ((:<|>)(..),(:>), BasicAuth,
48+import Servant.API ((:<|>) (..), (:>), BasicAuth,
35− BasicAuthData, BuildHeadersTo(..),
49+ BasicAuthData, BuildHeadersTo (..),
36− Capture, contentType, Header,
50+ Capture, Header, Headers (..),
37− Headers(..), HttpVersion, IsSecure,
51+ HttpVersion, IsSecure,
38− MimeRender(..), MimeUnrender,
52+ MimeRender (..), MimeUnrender,
39 NoContent, QueryFlag, QueryParam,
53 NoContent, QueryFlag, QueryParam,
40− QueryParams, Raw, ReflectMethod(..),
54+ QueryParams, Raw, ReflectMethod (..),
41 RemoteHost, ReqBody,
55 RemoteHost, ReqBody,
42− ToHttpApiData(..), Vault, Verb)
56+ ToHttpApiData (..), Vault, Verb,
43−
57+ contentType)
58+import Servant.API.Description (Summary)
59+
44−import Reflex.Dom (Dynamic, Event, Reflex,
60+import Reflex.Dom.Core (Dynamic, Event, Reflex,
45− XhrRequest(..),
61+ XhrRequest (..),
46− XhrResponseHeaders(..),
62+ XhrResponseHeaders (..),
47− XhrResponse(..), constDyn, ffor, fmapMaybe,
48− leftmost, performRequestAsync, attachPromptlyDynWith,
63+ attachPromptlyDynWith, constDyn)
49− tagPromptlyDyn )
50------------------------------------------------------------------------------
64------------------------------------------------------------------------------
51−import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
65+import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
52− showBaseUrl,
53− SupportsServantReflex)
66+ SupportsServantReflex)
54−import Servant.Common.Req (Req, ReqResult(..), QParam(..),
67+import Servant.Common.Req (ClientOptions,
68+ QParam (..), QueryPart (..), Req,
55− QueryPart(..), addHeader, authData,
69+ ReqResult (..), addHeader, authData,
56− defReq, prependToPathParts,
70+ defReq,
57− performRequestCT,
71+ defaultClientOptions,
58− performRequestsCT,
72+ performRequestsCT,
59− performRequestNoBody,
60− performRequestsNoBody,
73+ performRequestsNoBody,
61− performSomeRequestsAsync,
74+ performSomeRequestsAsync,
62− qParamToQueryPart, reqBody,
75+ prependToPathParts, qParamToQueryPart,
63− reqSuccess, reqFailure,
76+ qParams, reqBody, reqFailure,
77+ reqMethod, reqSuccess, reqSuccess',
64− reqMethod, respHeaders, response,
78+ respHeaders, response, withCredentials)
65− qParams)
66−import Servant.Reflex (BuildHeaderKeysTo(..), toHeaders)
79+import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
67
80
68
81
69------------------------------------------------------------------------------
82------------------------------------------------------------------------------
@@ -72,14 +85,24 @@ clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
72 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
85 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
73clientA p q f tag baseurl =
86clientA p q f tag baseurl =
74 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
87 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
88+ defaultClientOptions
89+
75
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
76
99
77------------------------------------------------------------------------------
100------------------------------------------------------------------------------
78class HasClientMulti t m layout f (tag :: *) where
101class HasClientMulti t m layout f (tag :: *) where
79 type ClientMulti t m layout f tag :: *
102 type ClientMulti t m layout f tag :: *
80 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
103 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
81 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
104 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
82− -> ClientMulti t m layout f tag
105+ -> ClientOptions -> ClientMulti t m layout f tag
83
106
84
107
85------------------------------------------------------------------------------
108------------------------------------------------------------------------------
@@ -87,9 +110,9 @@ instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>
87 HasClientMulti t m (a :<|> b) f tag where
110 HasClientMulti t m (a :<|> b) f tag where
88 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 :<|>
89 ClientMulti t m b f tag
112 ClientMulti t m b f tag
90− clientWithRouteMulti Proxy q f tag reqs baseurl =
113+ clientWithRouteMulti Proxy q f tag reqs baseurl opts =
91− clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl :<|>
114+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>
92− clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl
115+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts
93
116
94
117
95------------------------------------------------------------------------------
118------------------------------------------------------------------------------
@@ -102,7 +125,8 @@ instance (SupportsServantReflex t m,
102 type ClientMulti t m (Capture capture a :> sublayout) f tag =
125 type ClientMulti t m (Capture capture a :> sublayout) f tag =
103 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
104
127
128+ clientWithRouteMulti _ q f tag reqs baseurl opts vals =
105− clientWithRouteMulti l q f tag reqs baseurl vals = clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
129+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
106 where
130 where
107 reqs' = (prependToPathParts <$> ps <*>) <$> reqs
131 reqs' = (prependToPathParts <$> ps <*>) <$> reqs
108 ps = (fmap . fmap . fmap) toUrlPiece vals
132 ps = (fmap . fmap . fmap) toUrlPiece vals
@@ -120,10 +144,10 @@ instance {-# OVERLAPPABLE #-}
120 ) => HasClientMulti t m (Verb method status cts' a) f tag where
144 ) => HasClientMulti t m (Verb method status cts' a) f tag where
121
145
122 type ClientMulti t m (Verb method status cts' a) f tag =
146 type ClientMulti t m (Verb method status cts' a) f tag =
123− Event t tag -> m (Event t (tag, f (ReqResult a)))
147+ Event t tag -> m (Event t (f (ReqResult tag a)))
124
148
125− clientWithRouteMulti _ _ f tag reqs baseurl =
149+ clientWithRouteMulti _ _ _ _ reqs baseurl opts =
126− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
150+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts
127 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
151 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
128 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
152 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
129
153
@@ -134,11 +158,11 @@ instance {-# OVERLAPPING #-}
134 (ReflectMethod method, SupportsServantReflex t m, Traversable f) =>
158 (ReflectMethod method, SupportsServantReflex t m, Traversable f) =>
135 HasClientMulti t m (Verb method status cts NoContent) f tag where
159 HasClientMulti t m (Verb method status cts NoContent) f tag where
136 type ClientMulti t m (Verb method status cts NoContent) f tag =
160 type ClientMulti t m (Verb method status cts NoContent) f tag =
137− Event t tag -> m (Event t (tag, f (ReqResult NoContent)))
161+ Event t tag -> m (Event t (f (ReqResult tag NoContent)))
138 -- TODO: how to access input types here?
162 -- TODO: how to access input types here?
139 -- ExceptT ServantError IO NoContent
163 -- ExceptT ServantError IO NoContent
140− clientWithRouteMulti Proxy _ _ tag req baseurl =
164+ clientWithRouteMulti Proxy _ _ _ req baseurl opts =
141− performRequestsNoBody method req baseurl
165+ performRequestsNoBody method req baseurl opts
142 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
166 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
143
167
144
168
@@ -151,11 +175,11 @@ instance {-# OVERLAPPABLE #-}
151 Traversable f
175 Traversable f
152 ) => 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
153 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 =
154− Event t tag -> m (Event t (tag, f (ReqResult (Headers ls a))))
178+ Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))
155− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
179+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
156 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
180 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
157− resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl triggers :: m (Event t (tag, f (ReqResult a)))
181+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))
158− return $ (fmap . fmap) toHeaders <$> resp
182+ return $ fmap toHeaders <$> resp
159 where
183 where
160 reqs' = fmap (\r ->
184 reqs' = fmap (\r ->
161 r { respHeaders =
185 r { respHeaders =
@@ -174,11 +198,11 @@ instance {-# OVERLAPPABLE #-}
174 ) => HasClientMulti t m (Verb method status
198 ) => HasClientMulti t m (Verb method status
175 cts (Headers ls NoContent)) f tag where
199 cts (Headers ls NoContent)) f tag where
176 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
177− = Event t tag -> m (Event t (tag, f (ReqResult (Headers ls NoContent))))
201+ = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))
178− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
202+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
179 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
203 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
180− resp <- performRequestsNoBody method reqs' baseurl triggers
204+ resp <- performRequestsNoBody method reqs' baseurl opts triggers
181− return $ (fmap . fmap) toHeaders <$> resp
205+ return $ fmap toHeaders <$> resp
182 where reqs' = fmap (\req ->
206 where reqs' = fmap (\req ->
183 req {respHeaders = OnlyHeaders (Set.fromList
207 req {respHeaders = OnlyHeaders (Set.fromList
184 (buildHeaderKeysTo (Proxy :: Proxy ls)))
208 (buildHeaderKeysTo (Proxy :: Proxy ls)))
@@ -197,11 +221,11 @@ instance (KnownSymbol sym,
197 type ClientMulti t m (Header sym a :> sublayout) f tag =
221 type ClientMulti t m (Header sym a :> sublayout) f tag =
198 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
199
223
200− clientWithRouteMulti Proxy f q tag reqs baseurl eVals =
224+ clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =
201 clientWithRouteMulti (Proxy :: Proxy sublayout) f
225 clientWithRouteMulti (Proxy :: Proxy sublayout) f
202 q tag
226 q tag
203 reqs'
227 reqs'
204− baseurl
228+ baseurl opts
205 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
229 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
206 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
230 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
207 <$> eVals <*>) <$> reqs
231 <$> eVals <*>) <$> reqs
@@ -218,12 +242,22 @@ instance HasClientMulti t m sublayout f tag
218 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
242 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
219
243
220
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+
221------------------------------------------------------------------------------
256------------------------------------------------------------------------------
222instance (KnownSymbol sym,
257instance (KnownSymbol sym,
223 ToHttpApiData a,
258 ToHttpApiData a,
224 HasClientMulti t m sublayout f tag,
259 HasClientMulti t m sublayout f tag,
225 Reflex t,
260 Reflex t,
226− Traversable f,
227 Applicative f)
261 Applicative f)
228 => HasClientMulti t m (QueryParam sym a :> sublayout) f tag where
262 => HasClientMulti t m (QueryParam sym a :> sublayout) f tag where
229
263
@@ -232,9 +266,9 @@ instance (KnownSymbol sym,
232
266
233 -- 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
234 -- TODO: Check the above comment
268 -- TODO: Check the above comment
235− clientWithRouteMulti Proxy q f tag reqs baseurl mparams =
269+ clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =
236 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
270 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
237− reqs' baseurl
271+ reqs' baseurl opts
238
272
239 where pname = symbolVal (Proxy :: Proxy sym)
273 where pname = symbolVal (Proxy :: Proxy sym)
240 p prm = QueryPartParam $ fmap qParamToQueryPart prm
274 p prm = QueryPartParam $ fmap qParamToQueryPart prm
@@ -249,36 +283,33 @@ instance (KnownSymbol sym,
249 ToHttpApiData a,
283 ToHttpApiData a,
250 HasClientMulti t m sublayout f tag,
284 HasClientMulti t m sublayout f tag,
251 Reflex t,
285 Reflex t,
252− Traversable f,
253 Applicative f)
286 Applicative f)
254 => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where
287 => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where
255
288
256 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
289 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
257 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
290 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
258
291
259− clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =
292+ clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =
260− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
293+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
261
294
262 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 }
263 pname = symbolVal (Proxy :: Proxy sym)
296 pname = symbolVal (Proxy :: Proxy sym)
264 params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)
297 params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)
265 l
298 l
266 reqs' = liftA2 req' <$> paramlists <*> reqs
299 reqs' = liftA2 req' <$> paramlists <*> reqs
267− -- reqs' = req' <$> paramlists <*> reqs
268
300
269
301
270instance (KnownSymbol sym,
302instance (KnownSymbol sym,
271 HasClientMulti t m sublayout f tag,
303 HasClientMulti t m sublayout f tag,
272 Reflex t,
304 Reflex t,
273− Traversable f,
274 Applicative f)
305 Applicative f)
275 => HasClientMulti t m (QueryFlag sym :> sublayout) f tag where
306 => HasClientMulti t m (QueryFlag sym :> sublayout) f tag where
276
307
277 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
308 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
278 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
309 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
279
310
280− clientWithRouteMulti Proxy q f tag reqs baseurl flags =
311+ clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =
281− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
312+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts
282
313
283 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
314 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
284 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
315 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
@@ -287,33 +318,32 @@ instance (KnownSymbol sym,
287
318
288
319
289instance (SupportsServantReflex t m,
320instance (SupportsServantReflex t m,
290− Traversable f) => HasClientMulti t m Raw f tag where
321+ Traversable f, Applicative f) => HasClientMulti t m Raw f tag where
291 type ClientMulti t m Raw f tag = f (Dynamic t (Either Text (XhrRequest ())))
322 type ClientMulti t m Raw f tag = f (Dynamic t (Either Text (XhrRequest ())))
292 -> Event t tag
323 -> Event t tag
293− -> m (Event t (tag, f (ReqResult ())))
324+ -> m (Event t (f (ReqResult tag ())))
294
325
295− clientWithRouteMulti _ _ _ _ oldReqs baseurl rawReqs triggers = do
326+ clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do
296 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
327 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
297 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
328 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
298− resps <- fmap (second (fmap aux) . getCompose) <$> performSomeRequestsAsync rawReqs''
329+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''
299 return resps
330 return resps
300 where
331 where
301− aux (Right r) = ResponseSuccess () r
332+ aux (tag, Right r) = ResponseSuccess tag () r
302− aux (Left e) = RequestFailure e
333+ aux (tag, Left e) = RequestFailure tag e
303
334
304
335
305instance (MimeRender ct a,
336instance (MimeRender ct a,
306 HasClientMulti t m sublayout f tag,
337 HasClientMulti t m sublayout f tag,
307 Reflex t,
338 Reflex t,
308− Traversable f,
309 Applicative f)
339 Applicative f)
310 => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where
340 => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where
311
341
312 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
342 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
313 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
314
344
315− clientWithRouteMulti Proxy q f tag reqs baseurl bodies =
345+ clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
316− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
346+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
317 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
347 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
318 ctProxy = Proxy :: Proxy ct
348 ctProxy = Proxy :: Proxy ct
319 ctString = T.pack $ show $ contentType ctProxy
349 ctString = T.pack $ show $ contentType ctProxy
@@ -358,14 +388,14 @@ instance HasClientMulti t m api f tag => HasClientMulti t m (IsSecure :> api) f
358 clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl
388 clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl
359
389
360
390
361−instance (HasClientMulti t m api f tag, Reflex t, Traversable f, Applicative f)
391+instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
362 => HasClientMulti t m (BasicAuth realm usr :> api) f tag where
392 => HasClientMulti t m (BasicAuth realm usr :> api) f tag where
363
393
364 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))
365 -> ClientMulti t m api f tag
395 -> ClientMulti t m api f tag
366
396
367− clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =
397+ clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =
368− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl
398+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts
369 where
399 where
370 req' a r = r { authData = Just (constDyn a) }
400 req' a r = r { authData = Just (constDyn a) }
371 reqs' = liftA2 req' <$> authdatas <*> reqs
401 reqs' = liftA2 req' <$> authdatas <*> reqs
stack.yamlnew file+56
@@ -0,0 +1,56 @@
1+flags: {}
2+extra-package-dbs: []
3+packages:
4+- '.'
5+
6+- location:
7+ git: https://github.com/reflex-frp/reflex
8+ commit: d78ba4318c425ca9b942dc387d7c5c7ab2d2e095
9+ extra-dep: true
10+
11+- location:
12+ git: https://github.com/mokus0/dependent-sum.git
13+ commit: bbc8ad3a81ea7f2b07ce7d036efd56f2e0f7c6ff
14+ extra-dep: true
15+
16+- location:
17+ git: https://github.com/gtk2hs/gtk2hs.git
18+ commit: 21d3a12a82756d04066e5e4198b35097012ee65b
19+ subdirs:
20+ - cairo
21+ - gio
22+ - glib
23+ - gtk
24+ - pango
25+ - tools
26+ extra-dep: true
27+
28+- location:
29+ git: https://github.com/byorgey/hashtables.git
30+ commit: 47d9ed261a5aba66a13d3c4da0e391d338b57fc5
31+ extra-dep: true
32+
33+- location:
34+ git: https://github.com/afcady/reflex-dom.git
35+ commit: 39b5ff23f3ae95d77c909ab3ed4bc4bd9e61f600
36+ extra-dep: true
37+
38+- location:
39+ git: https://github.com/afcady/dependent-sum-template.git
40+ commit: 68fc1a90580ea8f20775491cf651eefea422212a
41+ extra-dep: true
42+
43+extra-deps:
44+- cpphs-1.20.4
45+- directory-1.2.7.1
46+- ghcjs-dom-0.2.4.0
47+- haskell-src-exts-1.17.1
48+- haskell-src-meta-0.6.0.14
49+- hlint-1.9.35
50+- prim-uniq-0.1.0.1
51+- primitive-0.6.2.0
52+- ref-tf-0.4.0.1
53+- vector-0.12.0.0
54+- webkitgtk3-javascriptcore-0.13.2.0
55+- zenc-0.1.1
56+resolver: lts-8.3
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+ }