git.iko.soy/servant-reflex
on master help sign in
swap
f76dbeb112 ahead, 0 behind
.gitignore+3
since splitsnapshots
unifiedsplit
@@ -6,3 +6,6 @@ log
6*.webapp
6*.webapp
7*.stats
7*.stats
8out
8out
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−58
@@ -1,63 +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− - openssl aes-256-cbc -K $encrypted_3c89d919c82e_key -iv $encrypted_3c89d919c82e_iv -in deploy_key.enc -out deploy_key -d
6+ - sudo cp -rT $TRAVIS_BUILD_DIR/nix /etc/nix
24− - unset CC
25− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
26− - git submodule update --init --recursive
27
7
28−install:
8+before_script:
29− - cabal --version
9+ - sudo systemctl restart nix-daemon.service
30− - BENCH=${BENCH---enable-benchmarks}
10+ - git config --global user.email "travis-ci@example.com"
31− - TEST=${TEST---enable-tests}
11+ - git config --global user.name "Travis-CI"
32− - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
33− - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
34− then
35− zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
36− $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
37− fi
38− - travis_retry cabal update -v
39− - git clone https://github.com/reflex-frp/reflex-platform
40− - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
41− - reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal configure && cabal build"
42− - reflex-platform/work-on ghc ./testdriver --command "cd testdriver && cabal configure && cabal build"
43− - cd testserver && dist/build/back/back -p 8000 &
44− - sleep 3
45− - phantomjs --webdriver=127.0.0.1:4444 &
46− - sleep 3
47
12
48script:
13script:
49− - git config --global user.email "travis-ci@example.com"
14+ - nix-build travis.nix -A build
50− - git config --global user.name "Travis-CI"
15+ - nix-build travis.nix -A buildGhc
51− - ./build.sh
16+ - nix-build travis.nix -A testserver
52− - testdriver/dist/build/spec/spec
17+ - nix-build travis.nix -A testresults
53−
54−cache:
55− directories:
56− - /nix
57− - $HOME/.cabal/packages
58− - $HOME/.cabal/store
59−
60−env:
61− global:
62− - ENCRYPTION_LABEL: "3c89d919c82e"
63− - 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+29−4
@@ -1,10 +1,32 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE TypeOperators #-}
3+{-# LANGUAGE TypeOperators #-}
3
4
4module API where
5module API where
5
6
7+import Data.Aeson
8+import Data.Aeson.Types (typeMismatch)
6−import Data.Text (Text)
9+import Data.Text (Text)
7−import Servant.API
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+
8
30
9-- | API spec for server, client, and docs
31-- | API spec for server, client, and docs
10type API = "getunit" :> Get '[JSON] ()
32type API = "getunit" :> Get '[JSON] ()
@@ -16,6 +38,9 @@ type API = "getunit" :> Get '[JSON] ()
16 :<|> "double" :> ReqBody '[JSON] Double
38 :<|> "double" :> ReqBody '[JSON] Double
17 :> Post '[JSON] Double
39 :> Post '[JSON] Double
18 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
40 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
41+ :<|> "qna" :> ReqBody '[JSON] Question
42+ :> Post '[JSON] Answer
43+ :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
19 :<|> Raw
44 :<|> Raw
20
45
21type GET = Get '[JSON] ()
46type GET = Get '[JSON] ()
exec/Example.hs+58−20
@@ -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 :<|> doRaw) =
102+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl
103+ :<|> multi :<|> qna :<|> secret :<|> doRaw) =
91− client api (Proxy :: Proxy m) (Proxy :: Proxy Int) 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,11 +170,34 @@ 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 ()
162
177
178+ el "br" $ return ()
179+
180+ elClass "div" "demo-group" $ do
181+ text "JSON Unicode encoding test"
182+ txt <- value <$> textInput def
183+ ev <- fmap (1 <$) $ button "Question"
184+ let dQ = Right . Question <$> traceDyn "will send: " txt
185+ rr <- qna dQ ev
186+ el "p" $
187+ dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
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+
163showXhrResponse :: XhrResponse -> Text
201showXhrResponse :: XhrResponse -> Text
164showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
165 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−18
@@ -1,18 +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− http-api-data = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/http-api-data) {});
17− };
18−}
overrides.nixdeleted−14
@@ -1,14 +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− };
14−}
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.5 && < 0.9,
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: 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+199−128
@@ -1,65 +1,120 @@
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)
19+import Data.Bifunctor (first)
20+import qualified Data.ByteString.Builder as Builder
20import qualified Data.ByteString.Lazy.Char8 as BL
21import qualified Data.ByteString.Lazy.Char8 as BL
22+import Data.ByteString (ByteString)
21import qualified Data.Map as Map
23import qualified Data.Map as Map
22−import Data.Maybe (catMaybes)
24+import Data.Maybe (catMaybes, fromMaybe)
23import Data.Functor.Compose
25import Data.Functor.Compose
24import Data.Monoid ((<>))
26import Data.Monoid ((<>))
25import Data.Proxy (Proxy(..))
27import Data.Proxy (Proxy(..))
26import Data.Text (Text)
28import Data.Text (Text)
27import qualified Data.Text as T
29import qualified Data.Text as T
28import qualified Data.Text.Encoding as TE
30import qualified Data.Text.Encoding as TE
29−import Data.Traversable
31+import Data.Traversable (forM)
32+import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
33+import qualified Network.URI as N
30−import Reflex.Dom
34+import Reflex.Dom.Core hiding (tag)
31−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl, SupportsServantReflex)
35+import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
36+ SupportsServantReflex)
32import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
37import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
33import Web.HttpApiData (ToHttpApiData(..))
38import Web.HttpApiData (ToHttpApiData(..))
34-------------------------------------------------------------------------------
39-------------------------------------------------------------------------------
35import Servant.API.BasicAuth
40import Servant.API.BasicAuth
36
41
37
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'
38
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
39−data ReqResult a = ResponseSuccess a XhrResponse
78+reqSuccess (ResponseSuccess _ x _) = Just x
40− | ResponseFailure Text XhrResponse
79+reqSuccess _ = Nothing
41− | RequestFailure Text
42
80
43−instance Functor ReqResult where
44− fmap f (ResponseSuccess a xhr) = ResponseSuccess (f a) xhr
45− fmap _ (ResponseFailure r x) = ResponseFailure r x
46− fmap _ (RequestFailure r) = RequestFailure r
47
81
82+------------------------------------------------------------------------------
83+-- | Simple filter/accessor like 'reqSuccess', but keeping the request tag
48−reqSuccess :: ReqResult a -> Maybe a
84+reqSuccess' :: ReqResult tag a -> Maybe (tag,a)
49−reqSuccess (ResponseSuccess x _) = Just x
85+reqSuccess' (ResponseSuccess tag x _) = Just (tag,x)
50−reqSuccess _ = Nothing
86+reqSuccess' _ = Nothing
51
87
52−reqFailure :: ReqResult a -> Maybe Text
53−reqFailure (ResponseFailure s _) = Just s
54−reqFailure (RequestFailure s) = Just s
55−reqFailure _ = Nothing
56
88
89+------------------------------------------------------------------------------
90+-- | Simple filter/accessor for any failure case
57−response :: ReqResult a -> Maybe XhrResponse
91+reqFailure :: ReqResult tag a -> Maybe Text
58−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)
59−response (ResponseFailure _ x) = Just x
99+reqFailure' (ResponseFailure tag s _) = Just (tag,s)
100+reqFailure' (RequestFailure tag s) = Just (tag,s)
60−response _ = Nothing
101+reqFailure' _ = Nothing
61
102
62
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+
63-------------------------------------------------------------------------------
118-------------------------------------------------------------------------------
64-- | 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
65-- indicate whether the parameter is valid and present, validly absent, or
120-- indicate whether the parameter is valid and present, validly absent, or
@@ -71,11 +126,13 @@ data QParam a = QParamSome a
71 | QParamInvalid Text
126 | QParamInvalid Text
72 -- ^ Indication that your validation failed (the request isn't valid)
127 -- ^ Indication that your validation failed (the request isn't valid)
73
128
129+
74qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)
130qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)
75qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)
131qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)
76qParamToQueryPart QNone = Right Nothing
132qParamToQueryPart QNone = Right Nothing
77qParamToQueryPart (QParamInvalid e) = Left e
133qParamToQueryPart (QParamInvalid e) = Left e
78
134
135+
79data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
136data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
80 | QueryPartParams (Dynamic t [Text])
137 | QueryPartParams (Dynamic t [Text])
81 | QueryPartFlag (Dynamic t Bool)
138 | QueryPartFlag (Dynamic t Bool)
@@ -110,7 +167,7 @@ reqToReflexRequest
110 => Text
167 => Text
111 -> Dynamic t BaseUrl
168 -> Dynamic t BaseUrl
112 -> Req t
169 -> Req t
113− -> (Dynamic t (Either Text (XhrRequest XhrPayload)))
170+ -> Dynamic t (Either Text (XhrRequest XhrPayload))
114reqToReflexRequest reqMeth reqHost req =
171reqToReflexRequest reqMeth reqHost req =
115 let t :: Dynamic t [Either Text Text]
172 let t :: Dynamic t [Either Text Text]
116 t = sequence $ reverse $ reqPathParts req
173 t = sequence $ reverse $ reqPathParts req
@@ -122,18 +179,22 @@ reqToReflexRequest reqMeth reqHost req =
122 urlParts = fmap sequence t
179 urlParts = fmap sequence t
123
180
124 urlPath :: Dynamic t (Either Text Text)
181 urlPath :: Dynamic t (Either Text Text)
125− urlPath = (fmap.fmap) (T.intercalate "/") urlParts
182+ urlPath = (fmap.fmap)
183+ (T.intercalate "/" . fmap escape)
184+ urlParts
126
185
127 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
186 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
128 queryPartString (pName, qp) = case qp of
187 queryPartString (pName, qp) = case qp of
129 QueryPartParam p -> ffor p $ \case
188 QueryPartParam p -> ffor p $ \case
130 Left e -> Just (Left e)
189 Left e -> Just (Left e)
131− Right (Just a) -> Just (Right $ pName <> "=" <> a)
190+ Right (Just a) -> Just (Right $ pName <> "=" <> escape a)
132 Right Nothing -> Nothing
191 Right Nothing -> Nothing
133 QueryPartParams ps -> ffor ps $ \pStrings ->
192 QueryPartParams ps -> ffor ps $ \pStrings ->
134 if null pStrings
193 if null pStrings
135 then Nothing
194 then Nothing
195+ else Just . Right
196+ . T.intercalate "&"
136− else Just $ Right (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) pStrings))
197+ $ fmap (\p -> pName <> "=" <> escape p) pStrings
137 QueryPartFlag fl -> ffor fl $ \case
198 QueryPartFlag fl -> ffor fl $ \case
138 True -> Just $ Right pName
199 True -> Just $ Right pName
139 False -> Nothing
200 False -> Nothing
@@ -168,10 +229,10 @@ reqToReflexRequest reqMeth reqHost req =
168 Right $ XhrRequestConfig
229 Right $ XhrRequestConfig
169 { _xhrRequestConfig_sendData = bytesToPayload bBytes
230 { _xhrRequestConfig_sendData = bytesToPayload bBytes
170 , _xhrRequestConfig_headers =
231 , _xhrRequestConfig_headers =
171− Map.insert "Content-Type" bCT (Map.fromList hs)
232+ Map.insert "Content-Type" bCT (Map.fromList hs)
172 , _xhrRequestConfig_user = Nothing
233 , _xhrRequestConfig_user = Nothing
173 , _xhrRequestConfig_password = Nothing
234 , _xhrRequestConfig_password = Nothing
174− , _xhrRequestConfig_responseType = Nothing
235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
175 , _xhrRequestConfig_withCredentials = False
236 , _xhrRequestConfig_withCredentials = False
176 , _xhrRequestConfig_responseHeaders = def
237 , _xhrRequestConfig_responseHeaders = def
177 }
238 }
@@ -183,8 +244,8 @@ reqToReflexRequest reqMeth reqHost req =
183 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
244 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
184 , _xhrRequestConfig_user = Nothing
245 , _xhrRequestConfig_user = Nothing
185 , _xhrRequestConfig_password = Nothing
246 , _xhrRequestConfig_password = Nothing
186− , _xhrRequestConfig_responseType = Nothing
247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
187− , _xhrRequestConfig_sendData = ""
248+ , _xhrRequestConfig_sendData = mempty
188 , _xhrRequestConfig_withCredentials = False
249 , _xhrRequestConfig_withCredentials = False
189 }
250 }
190 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
@@ -211,41 +272,55 @@ reqToReflexRequest reqMeth reqHost req =
211displayHttpRequest :: Text -> Text
272displayHttpRequest :: Text -> Text
212displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
273displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
213
274
214−-- | This function actually performs the request.
275+-- | This function performs the request
215performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
276performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
216 => Text
277 => Text
217 -> Dynamic t (f (Req t))
278 -> Dynamic t (f (Req t))
218 -> Dynamic t BaseUrl
279 -> Dynamic t BaseUrl
280+ -> ClientOptions
219 -> Event t tag
281 -> Event t tag
220 -> m (Event t (tag, f (Either Text XhrResponse)))
282 -> m (Event t (tag, f (Either Text XhrResponse)))
221−performRequests reqMeth rs reqHost trigger = do
283+performRequests reqMeth rs reqHost opts trigger = do
222− -- 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 $
223− 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
224− let reqs = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
290+ (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
291+
225− resps <- performSomeRequestsAsync reqs
292+ resps <- performSomeRequestsAsync opts reqs
226 return $ getCompose <$> resps
293 return $ getCompose <$> resps
227
294
228−-- | 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.
229performSomeRequestsAsync
298performSomeRequestsAsync
230 :: (MonadIO (Performable m),
299 :: (MonadIO (Performable m),
300+ MonadJSM (Performable m),
231 HasWebView (Performable m),
301 HasWebView (Performable m),
232 PerformEvent t m,
302 PerformEvent t m,
233 TriggerEvent t m,
303 TriggerEvent t m,
234 Traversable f,
304 Traversable f,
235− IsXhrPayload a)
305+ IsXhrPayload a,
306+ Show a
307+ )
308+ => ClientOptions
236− => Event t (f (Either Text (XhrRequest a)))
309+ -> Event t (f (Either Text (XhrRequest a)))
237 -> m (Event t (f (Either Text XhrResponse)))
310 -> m (Event t (f (Either Text XhrResponse)))
311+performSomeRequestsAsync opts =
238−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return
312+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
239
313
240
314
241------------------------------------------------------------------------------
315------------------------------------------------------------------------------
242-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
316-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
243-- that accepts 'f (Either e (XhrRequestb))' events
317-- that accepts 'f (Either e (XhrRequestb))' events
244performSomeRequestsAsync'
318performSomeRequestsAsync'
245− :: (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
246− => (XhrRequest b -> (a -> IO ()) -> Performable m XMLHttpRequest)
321+ -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
247 -> 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)))
248−performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
323+performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
249 rs <- hrs
324 rs <- hrs
250 resps <- forM rs $ \r -> case r of
325 resps <- forM rs $ \r -> case r of
251 Left e -> do
326 Left e -> do
@@ -253,103 +328,92 @@ performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb ->
253 return resp
328 return resp
254 Right r' -> do
329 Right r' -> do
255 resp <- liftIO newEmptyMVar
330 resp <- liftIO newEmptyMVar
331+ r'' <- liftJSM $ (optsRequestFixup opts) r'
256− _ <- newXhr r' $ liftIO . putMVar resp . Right
332+ _ <- newXhr r'' $ liftIO . putMVar resp . Right
257 return resp
333 return resp
258 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
334 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
259 return ()
335 return ()
260
336
261
337
262
338
263−-- | This function actually performs the request.
339+type XhrPayload = ByteString
264−performRequest :: forall t m tag .(SupportsServantReflex t m)
340+bytesToPayload :: BL.ByteString -> XhrPayload
265− => Text
341+bytesToPayload = BL.toStrict
266− -> (Req t)
267− -> Dynamic t BaseUrl
268− -> Event t tag
269− -> m (Event t (tag, XhrResponse), Event t (tag, Text))
270−performRequest reqMeth req reqHost trigger = do
271−
272− let xhrReq = reqToReflexRequest reqMeth reqHost req
273− let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger
274− okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) e) reqs
275− badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) e) reqs
276−
277− resps <- performRequestsAsync okReqs
278−
279− return (resps, badReqs)
280
342
281
343
282−#ifdef ghcjs_HOST_OS
344+performRequestsCT
283−type XhrPayload = String
284−bytesToPayload :: BL.ByteString -> XhrPayload
285−bytesToPayload = BL.unpack
286−#else
287−type XhrPayload = T.Text
288−bytesToPayload :: BL.ByteString -> XhrPayload
289−bytesToPayload = T.pack . BL.unpack
290−#endif
291−
292−performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)
293− => Text
294− -> Req t
295− -> Dynamic t BaseUrl
296− -> Event t tag -> m (Event t (tag, ReqResult NoContent))
297−performRequestNoBody reqMeth req reqHost trigger = do
298− (resp, badReq) <- performRequest reqMeth req reqHost trigger
299− return $ leftmost [ fmap (ResponseSuccess NoContent) <$> resp, fmap RequestFailure <$> badReq]
300−
301−performRequestsNoBody :: forall t m f tag. (SupportsServantReflex t m, Traversable f)
302− => Text
303− -> Dynamic t (f (Req t))
304− -> Dynamic t BaseUrl
305− -> Event t tag -> m (Event t (tag, f (ReqResult NoContent)))
306−performRequestsNoBody reqMeth reqs reqHost trigger = do
307− resp <- performRequests reqMeth reqs reqHost trigger
308− return $ (fmap . fmap) aux <$> resp
309− where
310− aux (Right x) = ResponseSuccess NoContent x
311− aux (Left e) = RequestFailure e
312− -- return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]
313−
314−
315−performRequestCT
316 :: (SupportsServantReflex t m,
345 :: (SupportsServantReflex t m,
317− MimeUnrender ct a)
346+ MimeUnrender ct a, Traversable f)
318 => Proxy ct
347 => Proxy ct
319 -> Text
348 -> Text
320− -> Req t
349+ -> Dynamic t (f (Req t))
321 -> Dynamic t BaseUrl
350 -> Dynamic t BaseUrl
351+ -> ClientOptions
322 -> Event t tag
352 -> Event t tag
323− -> m (Event t (tag, ReqResult a))
353+ -> m (Event t (f (ReqResult tag a)))
324−performRequestCT ct reqMeth req reqHost trigger = do
354+performRequestsCT ct reqMeth reqs reqHost opts trigger = do
325− (resp, badReq) <- performRequest reqMeth req reqHost trigger
355+ resps <- performRequests reqMeth reqs reqHost opts trigger
326− let decodes = ffor resp $ fmap (\xhr ->
356+ let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
357+ first T.pack .
327− ((mimeUnrender ct . BL.fromStrict . TE.encodeUtf8)
358+ mimeUnrender ct $
328− =<< note "No body text" (_xhrResponse_responseText xhr), xhr))
359+ BL.fromStrict x
360+ decodeResp _ = Left "No body"
361+ return $ fmap
329− reqs = ffor decodes $ fmap (\case
362+ (\(t,rs) -> ffor rs $ \r -> case r of
330− (Right a, r) -> ResponseSuccess a r
363+ Left e -> RequestFailure t e
331− (Left e, r) -> ResponseFailure (T.pack e) r)
364+ Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
332− return $ leftmost [reqs, fmap RequestFailure <$> badReq]
365+ )
333−
366+ resps
334−performRequestsCT
367+
368+
369+performRequestsNoBody
335 :: (SupportsServantReflex t m,
370 :: (SupportsServantReflex t m,
336− MimeUnrender ct a, Traversable f)
371+ Traversable f)
337− => Proxy ct
338− -> Text
372+ => Text
339 -> Dynamic t (f (Req t))
373 -> Dynamic t (f (Req t))
340 -> Dynamic t BaseUrl
374 -> Dynamic t BaseUrl
375+ -> ClientOptions
341 -> Event t tag
376 -> Event t tag
342− -> m (Event t (tag, f (ReqResult a)))
377+ -> m (Event t (f (ReqResult tag NoContent)))
343−performRequestsCT ct reqMeth reqs reqHost trigger = do
378+performRequestsNoBody reqMeth reqs reqHost opts trigger = do
344− resps <- performRequests reqMeth reqs reqHost trigger
379+ resps <- performRequests reqMeth reqs reqHost opts trigger
345− return $ fmap (second (fmap reqToResult)) resps
380+ let decodeResp = const $ Right NoContent
346− where
381+ return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
347− reqToResult (Left e) = RequestFailure e
382+ Left e -> RequestFailure tag e
348− reqToResult (Right x) = case _xhrResponse_responseText x of
383+ Right g -> evalResponse decodeResp (tag,g)
349− Nothing -> ResponseFailure "No request body" x
384+
350− Just bod -> case mimeUnrender ct . BL.fromStrict . TE.encodeUtf8 $ bod of
385+
351− Left e -> ResponseFailure (T.pack e) x
386+------------------------------------------------------------------------------
387+evalResponse
388+ :: (XhrResponse -> Either Text a)
389+ -> (tag, XhrResponse)
390+ -> ReqResult tag a
391+evalResponse decode (tag, xhr) =
392+ let status = _xhrResponse_status xhr
393+ okStatus = status >= 200 && status < 400
394+ errMsg = fromMaybe
395+ ("Empty response with error code " <>
396+ T.pack (show $ _xhrResponse_status xhr))
397+ (_xhrResponse_responseText xhr)
398+ respPayld = if okStatus
399+ then either
400+ (\e -> ResponseFailure tag e xhr)
352− Right v -> ResponseSuccess v x
401+ (\v -> ResponseSuccess tag v xhr)
402+ (decode xhr)
403+ else ResponseFailure tag errMsg xhr
404+ in respPayld
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
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'
353
417
354
418
355note :: e -> Maybe a -> Either e a
419note :: e -> Maybe a -> Either e a
@@ -358,3 +422,10 @@ note e = maybe (Left e) Right
358fmapL :: (e -> e') -> Either e a -> Either e' a
422fmapL :: (e -> e') -> Either e a -> Either e' a
359fmapL _ (Right a) = Right a
423fmapL _ (Right a) = Right a
360fmapL 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+216−107
@@ -1,17 +1,23 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
2+{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE InstanceSigs #-}
7+{-# LANGUAGE InstanceSigs #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE OverloadedStrings #-}
8−{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE Rank2Types #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TupleSections #-}
13+{-# LANGUAGE TupleSections #-}
11−{-# LANGUAGE TypeFamilies #-}
14+{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE TypeOperators #-}
15+{-# LANGUAGE TypeOperators #-}
13−{-# LANGUAGE UndecidableInstances #-}
16+{-# LANGUAGE UndecidableInstances #-}
14−{-# LANGUAGE MultiParamTypeClasses #-}
17+
18+#if MIN_VERSION_base(4,9,0)
19+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
20+#endif
15
21
16-- #include "overlapping-compat.h"
22-- #include "overlapping-compat.h"
17-- | This module provides 'client' which can automatically generate
23-- | This module provides 'client' which can automatically generate
@@ -19,56 +25,71 @@
19-- API.
25-- API.
20module Servant.Reflex
26module Servant.Reflex
21 ( client
27 ( client
28+ , clientWithOpts
29+ , clientWithOptsAndResultHandler
30+ , clientWithRoute
31+ , clientWithRouteAndResultHandler
22 , BuildHeaderKeysTo(..)
32 , BuildHeaderKeysTo(..)
23 , toHeaders
33 , toHeaders
24− , HasClient(..)
34+ , HasClient
35+ , Client
25 , module Servant.Common.Req
36 , module Servant.Common.Req
26 , module Servant.Common.BaseUrl
37 , module Servant.Common.BaseUrl
27 ) where
38 ) where
28
39
29------------------------------------------------------------------------------
40------------------------------------------------------------------------------
30import Control.Applicative
41import Control.Applicative
42+import qualified Data.CaseInsensitive as CI
43+import Data.Functor.Identity
44+import qualified Data.Map as Map
31import Data.Monoid ((<>))
45import Data.Monoid ((<>))
32−import qualified Data.Set as Set
33−import qualified Data.Text.Encoding as E
34−import Data.CaseInsensitive (mk)
35import Data.Proxy (Proxy (..))
46import Data.Proxy (Proxy (..))
36−import qualified Data.Map as Map
47+import qualified Data.Set as Set
37import Data.Text (Text)
48import Data.Text (Text)
38import qualified Data.Text as T
49import qualified Data.Text as T
50+import qualified Data.Text.Encoding as E
51+import GHC.Exts (Constraint)
39import GHC.TypeLits (KnownSymbol, symbolVal)
52import GHC.TypeLits (KnownSymbol, symbolVal)
40−import Servant.API ((:<|>)(..),(:>), BasicAuth,
53+import Servant.API ((:<|>) (..), (:>), BasicAuth,
41− BasicAuthData, BuildHeadersTo(..),
54+ BasicAuthData, BuildHeadersTo (..),
42− Capture, contentType, Header,
55+ Capture, Header, Headers (..),
43− Headers(..), HttpVersion, IsSecure,
56+ HttpVersion, IsSecure,
44− MimeRender(..), MimeUnrender,
57+ MimeRender (..), MimeUnrender,
45 NoContent, QueryFlag, QueryParam,
58 NoContent, QueryFlag, QueryParam,
46− QueryParams, Raw, ReflectMethod(..),
59+ QueryParams, Raw, ReflectMethod (..),
47 RemoteHost, ReqBody,
60 RemoteHost, ReqBody,
48− ToHttpApiData(..), Vault, Verb)
61+ ToHttpApiData (..), Vault, Verb,
49−
62+ contentType)
63+import Servant.API.Description (Summary)
64+import qualified Servant.Auth as Auth
65+
50−import Reflex.Dom (Dynamic, Event, Reflex,
66+import Reflex.Dom.Core (Dynamic, Event, Reflex,
51− XhrRequest(..),
67+ XhrRequest (..), XhrResponse (..),
52− XhrResponseHeaders(..),
68+ XhrResponseHeaders (..),
53− XhrResponse(..), attachPromptlyDynWith, ffor, fmapMaybe,
69+ attachPromptlyDynWith, constDyn, ffor,
70+ fmapMaybe, leftmost,
54− leftmost, performRequestsAsync,
71+ performRequestsAsync)
55− )
56------------------------------------------------------------------------------
72------------------------------------------------------------------------------
57import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
73import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
58 showBaseUrl,
74 showBaseUrl,
59 SupportsServantReflex)
75 SupportsServantReflex)
76+import Servant.Common.Req (ClientOptions(..),
77+ defaultClientOptions,
60−import Servant.Common.Req (Req, ReqResult(..), QParam(..),
78+ Req, ReqResult(..), QParam(..),
61 QueryPart(..), addHeader, authData,
79 QueryPart(..), addHeader, authData,
62− defReq, prependToPathParts,
80+ defReq, evalResponse, prependToPathParts,
63− performRequestCT,
81+ -- performRequestCT,
64 performRequestsCT,
82 performRequestsCT,
65− performRequestNoBody,
83+ -- performRequestNoBody,
66 performRequestsNoBody,
84 performRequestsNoBody,
67 performSomeRequestsAsync,
85 performSomeRequestsAsync,
68 qParamToQueryPart, reqBody,
86 qParamToQueryPart, reqBody,
69 reqSuccess, reqFailure,
87 reqSuccess, reqFailure,
70− reqMethod, respHeaders, response,
88+ reqMethod, respHeaders,
89+ response,
90+ reqTag,
71− qParams)
91+ qParams, withCredentials)
92+
72
93
73-- * Accessing APIs as a Client
94-- * Accessing APIs as a Client
74
95
@@ -82,28 +103,75 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),
82-- >
103-- >
83-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
104-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
84-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
105-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
85−-- -> m (Event t (l, ReqResult Book)))
106+-- > -> m (Event t (l, ReqResult Book)))
86-- > (getAllBooks :<|> postNewBook) = client myApi host
107-- > (getAllBooks :<|> postNewBook) = client myApi host
87-- > where host = constDyn $ BaseUrl Http "localhost" 8080
108-- > where host = constDyn $ BaseUrl Http "localhost" 8080
109+client
88−client :: (HasClient t m layout tag)
110+ :: (HasClient t m layout tag)
111+ => Proxy layout
112+ -> Proxy m
113+ -> Proxy tag
114+ -> Dynamic t BaseUrl
115+ -> Client t m layout tag
116+client p q t baseurl = clientWithRoute p q t defReq baseurl defaultClientOptions
117+
118+clientWithOpts
119+ :: (HasClient t m layout tag)
120+ => Proxy layout
121+ -> Proxy m
122+ -> Proxy tag
123+ -> Dynamic t BaseUrl
124+ -> ClientOptions
89− => Proxy layout -> Proxy m -> Proxy tag -> Dynamic t BaseUrl -> Client t m layout tag
125+ -> Client t m layout tag
90−client p q t 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
91
141
92
142
93-- | This class lets us define how each API combinator
143-- | This class lets us define how each API combinator
94-- influences the creation of an HTTP request. It's mostly
144-- influences the creation of an HTTP request. It's mostly
95-- an internal class, you can just use 'client'.
145-- an internal class, you can just use 'client'.
96−class HasClient t m layout (tag :: *) where
146+class Monad m => HasClient t m layout (tag :: *) where
97 type Client t m layout tag :: *
147 type Client t m layout tag :: *
98− clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> Client t m layout tag
148+ clientWithRoute
149+ :: Proxy layout
150+ -> Proxy m
151+ -> Proxy tag
152+ -> Req t
153+ -> Dynamic t BaseUrl
154+ -> ClientOptions
155+ -> Client t m layout tag
156+ clientWithRoute l m t r b o = clientWithRouteAndResultHandler l m t r b o return
157+
158+ clientWithRouteAndResultHandler
159+ :: Proxy layout
160+ -> Proxy m
161+ -> Proxy tag
162+ -> Req t
163+ -> Dynamic t BaseUrl
164+ -> ClientOptions
165+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
166+ -> Client t m layout tag
99
167
100
168
101instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
169instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
102 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
170 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
103
171
104− clientWithRoute Proxy q pTag req baseurl =
172+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =
105− clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>
173+ clientWithRouteAndResultHandler (Proxy :: Proxy a) q pTag req baseurl opts wrap :<|>
106− clientWithRoute (Proxy :: Proxy b) q pTag req baseurl
174+ clientWithRouteAndResultHandler (Proxy :: Proxy b) q pTag req baseurl opts wrap
107
175
108
176
109-- Capture. Example:
177-- Capture. Example:
@@ -124,11 +192,9 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
124 type Client t m (Capture capture a :> sublayout) tag =
192 type Client t m (Capture capture a :> sublayout) tag =
125 Dynamic t (Either Text a) -> Client t m sublayout tag
193 Dynamic t (Either Text a) -> Client t m sublayout tag
126
194
127− clientWithRoute Proxy q t req baseurl val =
195+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
128− clientWithRoute (Proxy :: Proxy sublayout)
196+ clientWithRouteAndResultHandler
129− q t
130− (prependToPathParts p req)
197+ (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
131− baseurl
132 where p = (fmap . fmap) (toUrlPiece) val
198 where p = (fmap . fmap) (toUrlPiece) val
133
199
134
200
@@ -138,11 +204,11 @@ instance {-# OVERLAPPABLE #-}
138 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
204 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
139 ) => HasClient t m (Verb method status cts' a) tag where
205 ) => HasClient t m (Verb method status cts' a) tag where
140 type Client t m (Verb method status cts' a) tag =
206 type Client t m (Verb method status cts' a) tag =
141− Event t tag -> m (Event t (tag, ReqResult a))
207+ Event t tag -> m (Event t (ReqResult tag a))
142 -- TODO how to access input types here?
208 -- TODO how to access input types here?
143 -- ExceptT ServantError IO a
209 -- ExceptT ServantError IO a
144− clientWithRoute Proxy _ _ req baseurl trigs =
210+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
145− performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs
211+ wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
146 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
212 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
147 req' = req { reqMethod = method }
213 req' = req { reqMethod = method }
148
214
@@ -152,32 +218,36 @@ instance {-# OVERLAPPING #-}
152 (ReflectMethod method, SupportsServantReflex t m) =>
218 (ReflectMethod method, SupportsServantReflex t m) =>
153 HasClient t m (Verb method status cts NoContent) tag where
219 HasClient t m (Verb method status cts NoContent) tag where
154 type Client t m (Verb method status cts NoContent) tag =
220 type Client t m (Verb method status cts NoContent) tag =
155− Event t tag -> m (Event t (tag, ReqResult NoContent))
221+ Event t tag -> m (Event t (ReqResult tag NoContent))
156 -- TODO: how to access input types here?
222 -- TODO: how to access input types here?
157 -- ExceptT ServantError IO NoContent
223 -- ExceptT ServantError IO NoContent
158− clientWithRoute Proxy _ _ req baseurl =
224+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
159− performRequestNoBody method req baseurl
225+ wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
160 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
226 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
161
227
162
228
163−toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)
229+toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
164toHeaders r =
230toHeaders r =
165− let toBS = E.encodeUtf8
166− hdrs = maybe []
231+ let hdrs = maybe []
167− (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
232+ (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
168 (Map.toList $ _xhrResponse_headers xhr))
233 (Map.toList $ _xhrResponse_headers xhr))
169 (response r)
234 (response r)
170 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
235 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
171
236
237+
172class BuildHeaderKeysTo hs where
238class BuildHeaderKeysTo hs where
173− buildHeaderKeysTo :: Proxy hs -> [T.Text]
239+ buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
174
240
175instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
241instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
176 where buildHeaderKeysTo _ = []
242 where buildHeaderKeysTo _ = []
177
243
178instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
244instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
179− => 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))
180− buildHeaderKeysTo _ = (T.pack $ symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
249+ in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)
250+
181
251
182-- HEADERS Verb (Content) --
252-- HEADERS Verb (Content) --
183-- Headers combinator not treated in fully general case,
253-- Headers combinator not treated in fully general case,
@@ -191,11 +261,11 @@ instance {-# OVERLAPPABLE #-}
191 SupportsServantReflex t m
261 SupportsServantReflex t m
192 ) => 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
193 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 =
194− Event t tag -> m (Event t (tag, ReqResult (Headers ls a)))
264+ Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
195− clientWithRoute Proxy _ _ req baseurl = do
265+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
196 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
266 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
197− resp <- performRequestCT (Proxy :: Proxy ct) method req' baseurl
267+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
198− return $ (fmap . fmap) toHeaders <$> resp
268+ wrap $ toHeaders <$> resp
199 where req' = req { respHeaders =
269 where req' = req { respHeaders =
200 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
270 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
201 }
271 }
@@ -207,11 +277,11 @@ instance {-# OVERLAPPABLE #-}
207 SupportsServantReflex t m
277 SupportsServantReflex t m
208 ) => 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
209 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
210− = Event t tag -> m (Event t (tag, ReqResult (Headers ls NoContent)))
280+ = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
211− clientWithRoute Proxy _ _ req baseurl = do
281+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
212 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
282 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
213− resp <- performRequestNoBody method req' baseurl
283+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
214− return $ (fmap . fmap) toHeaders <$> resp
284+ wrap $ toHeaders <$> resp
215 where req' = req {respHeaders =
285 where req' = req {respHeaders =
216 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
286 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
217 }
287 }
@@ -238,11 +308,11 @@ instance (KnownSymbol sym, ToHttpApiData a,
238 type Client t m (Header sym a :> sublayout) tag =
308 type Client t m (Header sym a :> sublayout) tag =
239 Dynamic t (Either Text a) -> Client t m sublayout tag
309 Dynamic t (Either Text a) -> Client t m sublayout tag
240
310
241− clientWithRoute Proxy q t req baseurl eVal =
311+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =
312+ clientWithRouteAndResultHandler
242− clientWithRoute (Proxy :: Proxy sublayout)
313+ (Proxy :: Proxy sublayout) q t
243− q t
244− (Servant.Common.Req.addHeader hname eVal req)
314+ (Servant.Common.Req.addHeader hname eVal req)
245− baseurl
315+ baseurl opts wrap
246 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
316 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
247
317
248
318
@@ -256,8 +326,20 @@ instance HasClient t m sublayout tag
256 type Client t m (HttpVersion :> sublayout) tag =
326 type Client t m (HttpVersion :> sublayout) tag =
257 Client t m sublayout tag
327 Client t m sublayout tag
258
328
259− clientWithRoute Proxy q t =
329+ clientWithRouteAndResultHandler Proxy =
260− clientWithRoute (Proxy :: Proxy sublayout) q t
330+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
331+
332+-- | Using a 'Summary' combinator in your API doesn't affect the client
333+-- functions.
334+instance (HasClient t m sublayout tag, KnownSymbol sym)
335+ => HasClient t m (Summary sym :> sublayout) tag where
336+
337+ type Client t m (Summary sym :> sublayout) tag =
338+ Client t m sublayout tag
339+
340+ clientWithRouteAndResultHandler Proxy =
341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
342+
261
343
262
344
263
345
@@ -294,9 +376,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
294 Dynamic t (QParam a) -> Client t m sublayout tag
376 Dynamic t (QParam a) -> Client t m sublayout tag
295
377
296 -- if mparam = Nothing, we don't add it to the query string
378 -- if mparam = Nothing, we don't add it to the query string
297− clientWithRoute Proxy q t req baseurl mparam =
379+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
298− clientWithRoute (Proxy :: Proxy sublayout) q t
380+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
299− (req {qParams = paramPair : qParams req}) baseurl
381+ (req {qParams = paramPair : qParams req}) baseurl opts wrap
300
382
301 where pname = symbolVal (Proxy :: Proxy sym)
383 where pname = symbolVal (Proxy :: Proxy sym)
302 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
384 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -340,12 +422,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
340 type Client t m (QueryParams sym a :> sublayout) tag =
422 type Client t m (QueryParams sym a :> sublayout) tag =
341 Dynamic t [a] -> Client t m sublayout tag
423 Dynamic t [a] -> Client t m sublayout tag
342
424
343− clientWithRoute Proxy q t req baseurl paramlist =
425+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
344− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
426+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
345
427
346 where req' = req { qParams = (T.pack pname, params') : qParams req }
428 where req' = req { qParams = (T.pack pname, params') : qParams req }
347 pname = symbolVal (Proxy :: Proxy sym)
429 pname = symbolVal (Proxy :: Proxy sym)
348− params' = QueryPartParams $ (fmap . fmap) (toQueryParam)
430+ params' = QueryPartParams $ (fmap . fmap) toQueryParam
349 paramlist
431 paramlist
350
432
351
433
@@ -380,8 +462,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
380 type Client t m (QueryFlag sym :> sublayout) tag =
462 type Client t m (QueryFlag sym :> sublayout) tag =
381 Dynamic t Bool -> Client t m sublayout tag
463 Dynamic t Bool -> Client t m sublayout tag
382
464
383− clientWithRoute Proxy q t req baseurl flag =
465+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
384− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
466+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
385
467
386 where req' = req { qParams = thisPair : qParams req }
468 where req' = req { qParams = thisPair : qParams req }
387 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
469 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -393,9 +475,9 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
393instance SupportsServantReflex t m => HasClient t m Raw tag where
475instance SupportsServantReflex t m => HasClient t m Raw tag where
394 type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))
476 type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))
395 -> Event t tag
477 -> Event t tag
396− -> m (Event t (tag, ReqResult ()))
478+ -> m (Event t (ReqResult tag ()))
397
479
398− clientWithRoute _ _ _ _ baseurl xhrs triggers = do
480+ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
399
481
400 let xhrs' = liftA2 (\x path -> case x of
482 let xhrs' = liftA2 (\x path -> case x of
401 Left e -> Left e
483 Left e -> Left e
@@ -406,8 +488,9 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
406 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
488 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
407
489
408 resps <- performRequestsAsync okReq
490 resps <- performRequestsAsync okReq
409− return $ leftmost [ fmap (ResponseSuccess ()) <$> resps
410− , fmap (RequestFailure) <$> badReq ]
491+ wrap $ leftmost [ uncurry RequestFailure <$> badReq
492+ , evalResponse (const $ Right ()) <$> resps
493+ ]
411
494
412
495
413-- | 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,
@@ -436,8 +519,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
436 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
519 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
437 Dynamic t (Either Text a) -> Client t m sublayout tag
520 Dynamic t (Either Text a) -> Client t m sublayout tag
438
521
439− clientWithRoute Proxy q t req baseurl body =
522+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
440− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
523+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
441 where req' = req { reqBody = bodyBytesCT }
524 where req' = req { reqBody = bodyBytesCT }
442 ctProxy = Proxy :: Proxy ct
525 ctProxy = Proxy :: Proxy ct
443 ctString = T.pack $ show $ contentType ctProxy
526 ctString = T.pack $ show $ contentType ctProxy
@@ -451,10 +534,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
451instance (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
452 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
453
536
454− clientWithRoute Proxy q t req baseurl =
537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =
455− clientWithRoute (Proxy :: Proxy sublayout) q t
538+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
456− (prependToPathParts (pure (Right $ T.pack p)) req)
539+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap
457− baseurl
458
540
459 where p = symbolVal (Proxy :: Proxy path)
541 where p = symbolVal (Proxy :: Proxy path)
460
542
@@ -462,23 +544,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient
462instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
544instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
463 type Client t m (Vault :> api) tag = Client t m api tag
545 type Client t m (Vault :> api) tag = Client t m api tag
464
546
465− clientWithRoute Proxy q t req baseurl =
547+ clientWithRouteAndResultHandler Proxy =
466− clientWithRoute (Proxy :: Proxy api) q t req baseurl
548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
467
549
468
550
469instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
551instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
470 type Client t m (RemoteHost :> api) tag = Client t m api tag
552 type Client t m (RemoteHost :> api) tag = Client t m api tag
471
553
472− clientWithRoute Proxy q t req baseurl =
554+ clientWithRouteAndResultHandler Proxy =
473− clientWithRoute (Proxy :: Proxy api) q t req baseurl
555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
474
556
475
557
476
558
477instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
559instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
478 type Client t m (IsSecure :> api) tag = Client t m api tag
560 type Client t m (IsSecure :> api) tag = Client t m api tag
479
561
480− clientWithRoute Proxy q t req baseurl =
562+ clientWithRouteAndResultHandler Proxy =
481− clientWithRoute (Proxy :: Proxy api) q t req baseurl
563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)
482
564
483
565
484instance (HasClient t m api tag, Reflex t)
566instance (HasClient t m api tag, Reflex t)
@@ -487,8 +569,8 @@ instance (HasClient t m api tag, Reflex t)
487 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
569 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
488 -> Client t m api tag
570 -> Client t m api tag
489
571
490− clientWithRoute Proxy q t req baseurl authdata =
572+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
491− clientWithRoute (Proxy :: Proxy api) q t req' baseurl
573+ clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
492 where
574 where
493 req' = req { authData = Just authdata }
575 req' = req { authData = Just authdata }
494
576
@@ -514,3 +596,30 @@ non-empty lists, but is otherwise more specific, no instance will be overall
514more specific. This in turn generally means adding yet another instance (one
596more specific. This in turn generally means adding yet another instance (one
515for empty and one for non-empty lists).
597for empty and one for non-empty lists).
516-}
598-}
599+
600+
601+-- SUPPORT FOR servant-auth --
602+
603+-- For JavaScript clients we should be sending/storing JSON web tokens in a
604+-- way that is inaccessible to JavaScript.
605+--
606+-- For @servant-auth@ this is done with HTTP-only cookies. In a Reflex-DOM
607+-- app this means the @servant-auth@ client should only verify that the API
608+-- supports Cookie-based authentication but do nothing with the token
609+-- directly.
610+
611+-- @HasCookieAuth auths@ is nominally a redundant constraint, but ensures
612+-- we're not trying to rely on cookies when the API does not use them.
613+instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where
614+
615+ type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag
616+ clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)
617+
618+
619+type family HasCookieAuth xs :: Constraint where
620+ HasCookieAuth (Auth.Cookie ': xs) = ()
621+ HasCookieAuth (x ': xs) = HasCookieAuth xs
622+ HasCookieAuth '[] = CookieAuthNotEnabled
623+
624+class CookieAuthNotEnabled
625+
src/Servant/Reflex/Multi.hs+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+39−14
@@ -2,27 +2,34 @@
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
9+import Control.Monad.IO.Class (liftIO)
10+import Control.Monad.Reader (reader)
8import Data.Aeson
11import Data.Aeson
9import Data.Bool
12import Data.Bool
10−import Data.Char (toUpper)
13+import Data.Char (toUpper)
11−import qualified Data.List as L
14+import qualified Data.List as L
15+import Data.Maybe (fromMaybe)
12import Data.Monoid
16import Data.Monoid
13import Data.Proxy
17import Data.Proxy
14−import Data.Text hiding (length, null, map, head, toUpper)
18+import Data.Text hiding (head, length, map,
19+ null, toUpper)
15−import qualified Data.Text as T
20+import qualified Data.Text as T
21+import qualified Data.Text.IO as T
16import GHC.Generics
22import GHC.Generics
17−import Snap.Http.Server
18−import Snap.Core
19import Servant.Server.Internal.SnapShims
23import Servant.Server.Internal.SnapShims
24+import Snap.Core
25+import Snap.Http.Server
20
26
21−import Servant -- hiding (serveDirectory)
27+import Servant
22import Servant.Server
28import Servant.Server
23-- import Snap.Util.FileServe
29-- import Snap.Util.FileServe
30+import System.Environment (lookupEnv)
24import API
31import API
25−import Snap
32+import Snap
26
33
27-- * Example
34-- * Example
28
35
@@ -36,7 +43,7 @@ instance ToJSON Greet
36testApi :: Proxy API
43testApi :: Proxy API
37testApi = Proxy
44testApi = Proxy
38
45
39−data App = App
46+data App = App { appStaticDir :: String }
40
47
41-- Server-side handlers.
48-- Server-side handlers.
42--
49--
@@ -44,8 +51,10 @@ data App = App
44-- that represents the API, are glued together using :<|>.
51-- that represents the API, are glued together using :<|>.
45--
52--
46-- Each handler runs in the 'ExceptT ServantErr IO' monad.
53-- Each handler runs in the 'ExceptT ServantErr IO' monad.
47−server :: Server API (Handler App App)
54+server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
48−server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> serveDirectory "static"
55+server = return () :<|> return 100 :<|> sayhi :<|> dbl
56+ :<|> multi :<|> qna :<|> serveSecret
57+ :<|> statics
49 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
58 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
50 sayhi nm greetings withGusto = case nm of
59 sayhi nm greetings withGusto = case nm of
51 Nothing -> return ("Sorry, who are you?" :: Text)
60 Nothing -> return ("Sorry, who are you?" :: Text)
@@ -57,20 +66,36 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> serveDire
57 | otherwise = T.intercalate ", " (L.init greetings)
66 | otherwise = T.intercalate ", " (L.init greetings)
58 <> ", and " <> L.last greetings <> ", "
67 <> ", and " <> L.last greetings <> ", "
59 return . modifier $ greetPart <> n
68 return . modifier $ greetPart <> n
69+ dbl x = if x `elem` [4,13]
70+ then throwError $ err500 { errBody = "No unlucky numbers please" }
60− dbl x = return $ x * 2
71+ else return $ x * 2
61 multi = return . bool "Box unchecked" "Box Checked"
72 multi = return . bool "Box unchecked" "Box Checked"
73+ qna q = do
74+ liftIO $ do
75+ putStrLn $ "qna got: " ++ show q
76+ T.putStrLn $ 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
62
85
63-- 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,
64-- more precisely by the Servant.Server module.
87-- more precisely by the Servant.Server module.
65test :: Handler App App ()
88test :: Handler App App ()
66−test = serveSnap testApi server
89+test = serveSnapWithContext testApi
90+ (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server
67
91
68initApp :: SnapletInit App App
92initApp :: SnapletInit App App
69initApp = makeSnaplet "myapp" "example" Nothing $ do
93initApp = makeSnaplet "myapp" "example" Nothing $ do
94+ staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")
70 addRoutes [("", test)
95 addRoutes [("", test)
71 ,("", serveDirectory "static")
96 ,("", serveDirectory "static")
72 ]
97 ]
73− return App
98+ return (App staticDir)
74
99
75-- Put this all to work!
100-- Put this all to work!
76main :: 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+17−16
@@ -1,31 +1,32 @@
1−-- Initial back.cabal generated by cabal init. For further documentation,
1+-- Initial back.cabal generated by cabal init. For further documentation,
2-- see http://haskell.org/cabal/users-guide/
2-- see http://haskell.org/cabal/users-guide/
3
3
4name: testserver
4name: testserver
5version: 0.1.0.0
5version: 0.1.0.0
6−-- synopsis:
6+-- synopsis:
7−-- description:
7+-- description:
8license: BSD3
8license: BSD3
9license-file: LICENSE
9license-file: LICENSE
10author: Greg Hale
10author: Greg Hale
11maintainer: imalsogreg@gmail.com
11maintainer: imalsogreg@gmail.com
12−-- copyright:
12+-- copyright:
13−-- category:
13+-- category:
14build-type: Simple
14build-type: Simple
15−-- extra-source-files:
15+-- extra-source-files:
16cabal-version: >=1.10
16cabal-version: >=1.10
17
17
18executable back
18executable 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.7.1 && < 0.9
28+ , servant >= 0.16 && < 0.18
28− , servant-snap >= 0.7 && < 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+ }