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

Submodule changed.

deps/reflex-platformnew file+1

Submodule changed.

deps/servantnew file+1

Submodule changed.

deps/servant-snapnew file+1

Submodule changed.

exec/API.hs−1
@@ -40,7 +40,6 @@ type API = "getunit" :> Get '[JSON] ()
4040 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
4141 :<|> "qna" :> ReqBody '[JSON] Question
4242 :> Post '[JSON] Answer
43− :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
4443 :<|> Raw
4544
4645type GET = Get '[JSON] ()
exec/Example.hs+27−45
@@ -1,4 +1,3 @@
1−{-# LANGUAGE DataKinds #-}
21{-# LANGUAGE FlexibleContexts #-}
32{-# LANGUAGE GADTs #-}
43{-# LANGUAGE OverloadedStrings #-}
@@ -15,17 +14,16 @@ import Control.Monad.Fix (MonadFix)
1514import Data.Monoid (First(..), (<>))
1615import Data.Text (Text)
1716import qualified Data.Text as T
18−import qualified Data.Text.Encoding as T
1917import GHC.TypeLits
2018import Servant.API
2119import API
2220import Data.Proxy
2321import Text.Read (readMaybe)
24−import Reflex.Dom.Core hiding (run, mainWidget)
25−import Reflex.Dom (mainWidget)
22+import Reflex.Dom hiding (run)
2623------------------------------------------------------------------------------
2724import Servant.Reflex
2825import Servant.Reflex.Multi
26+import qualified TupleExample
2927
3028
3129api :: Proxy API
@@ -33,8 +31,10 @@ api = Proxy
3331
3432main :: IO ()
3533main = mainWidget $ do
34+ el "h1" $ text "Wowzers!"
3635 divClass "example-base" run
3736 divClass "example-multi" runMulti
37+ divClass "example-tuple" TupleExample.run
3838
3939
4040runMulti :: forall t m. (SupportsServantReflex t m,
@@ -46,7 +46,7 @@ runMulti :: forall t m. (SupportsServantReflex t m,
4646runMulti = do
4747 url <- baseUrlWidget
4848 el "br" blank
49− let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =
49+ let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ ) =
5050 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
5151
5252 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
@@ -67,14 +67,11 @@ runMulti = do
6767 grts <- fmap (fmap T.words . value) $ divClass "" $ do
6868 text "Greetings"
6969 textInput def
70− gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
70+ gust <- fmap value $ divClass "gusto-input" $ checkbox False def
7171 b <- button "Go"
72− r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)
73− (constDyn [True, False]) (1 <$ b)
74−
75− dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .
76− fmap reqSuccess <$> r')
72+ r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) grts) (constDyn [True, False]) (1 <$ b)
7773
74+ dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes . fmap reqSuccess <$> r')
7875
7976 return ()
8077
@@ -97,11 +94,8 @@ run = mdo
9794 el "br" (return ())
9895
9996 -- Name the computed API client functions
100− let tweakRequest = ClientOptions $ \r -> do
101− return $ r & withCredentials .~ True
102− let (getUnit :<|> getInt :<|> sayhi :<|> dbl
103− :<|> multi :<|> qna :<|> secret :<|> doRaw) =
104− clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest
97+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> doRaw) =
98+ client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url
10599
106100 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
107101
@@ -112,11 +106,11 @@ run = mdo
112106 unitResponse <- getUnit $ tag (current reqCount) unitBtn
113107 intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn
114108
115− score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))
109+ score <- foldDyn (+) 0 (fmapMaybe reqSuccess intResponse)
116110
117− r <- holdDyn "Waiting" $ fmap showXhrResponse $
118− leftmost [fmapMaybe response (unitResponse)
119− ,fmapMaybe response (intResponse)
111+ r <- holdDyn "Waiting" $ showXhrResponse <$>
112+ leftmost [fmapMaybe response unitResponse
113+ ,fmapMaybe response intResponse
120114 ]
121115 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score
122116 return (unitBtn, intBtn)
@@ -125,14 +119,14 @@ run = mdo
125119
126120 text "Name"
127121 el "br" $ return ()
128− inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ (textInput def)
122+ inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ textInput def
129123 let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp
130124 el "br" $ return ()
131125
132126 text "Greetings (space-separated)"
133127 el "br" $ return ()
134128 greetings <- fmap (fmap T.words . value) $
135− divClass "greetings-input" $ (textInput def)
129+ divClass "greetings-input" $ textInput def
136130
137131 el "br" $ return ()
138132
@@ -144,23 +138,23 @@ run = mdo
144138
145139 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)
146140 divClass "greeting-response" $ dynText =<<
147− holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)
148− , fmapMaybe reqFailure (resp)])
141+ holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess resp
142+ , fmapMaybe reqFailure resp])
149143 return sayHiClicks
150144
151145 dblBtn <- elClass "div" "demo-group" $ do
152146 text "A Double to double"
153147 el "br" $ return ()
154148 dblinp <- fmap value $ divClass "double-input" $ textInput def
155− (dblBtn) <- divClass "double-button" $ button "Double it"
156− dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
149+ dblBtn <- divClass "double-button" $ button "Double it"
150+ dblResp <- dbl ((note "read failure" . readMaybe . T.unpack) <$>
157151 dblinp) (tag (current reqCount) dblBtn)
158152 divClass "double-errors" $ dynText =<<
159− holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))
153+ holdDyn "(no errors)" (fmapMaybe reqFailure dblResp)
160154 el "br" (return ())
161155 divClass "double-result" $ el "p" $ dynText =<<
162− holdDyn "No number yet" (fmap tShow $
163− fmapMaybe reqSuccess (dblResp))
156+ holdDyn "No number yet" (tShow <$>
157+ fmapMaybe reqSuccess dblResp)
164158 return dblBtn
165159
166160 mpGo <- elClass "div" "demo-group" $ do
@@ -168,9 +162,9 @@ run = mdo
168162 b <- value <$> checkbox False def
169163 mpGo <- button "Test"
170164 multiResp <- multi b (tag (current reqCount) mpGo)
171− dynText =<< holdDyn "No res yet" (fmap tShow $
172− fmapMaybe reqSuccess $
173− (multiResp))
165+ dynText =<< holdDyn "No res yet" (tShow <$>
166+ fmapMaybe reqSuccess
167+ multiResp)
174168 return mpGo
175169
176170 return ()
@@ -180,24 +174,12 @@ run = mdo
180174 elClass "div" "demo-group" $ do
181175 text "JSON Unicode encoding test"
182176 txt <- value <$> textInput def
183− ev <- fmap (1 <$) $ button "Question"
177+ ev <- (1 <$) <$> button "Question"
184178 let dQ = Right . Question <$> traceDyn "will send: " txt
185179 rr <- qna dQ ev
186180 el "p" $
187181 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
188182
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−
201183showXhrResponse :: XhrResponse -> Text
202184showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
203185 T.unlines ["stat: " <> tShow stat
exec/TupleExample.hsnew file+35
@@ -0,0 +1,35 @@
1+{-# LANGUAGE RankNTypes #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeApplications #-}
8+
9+module TupleExample where
10+
11+import Data.Aeson
12+import Data.Proxy
13+import Data.Text
14+import GHC.TypeLits
15+import Reflex.Dom
16+import Servant.API
17+import Servant.Reflex.Tuple
18+
19+type TestAPI = Get '[JSON] Int
20+ -- :<|> Post '[JSON] Int
21+ :<|> Capture "name" Text :> Post '[JSON] Text
22+
23+
24+run :: forall t m. (SupportsServantReflex t m, MonadWidget t m) => m ()
25+run = do
26+ let (getInt :<|> greet) = client (Proxy @TestAPI) (Proxy @m) (BasePath "/")
27+ -- let getInt = client (Proxy @TestAPI) (Proxy @m) (BasePath "/")
28+ b <- button "Go for it"
29+ g <- ("greg" <$) <$> button "Hello"
30+ -- g <- button "Hello"
31+ b' <- getInt b
32+ display =<< holdDyn (Left "Waiting") b'
33+ g' <- greet g
34+ display =<< holdDyn (Left "Waiting") g'
35+
nix/nix.confdeleted−3
@@ -1,3 +0,0 @@
1−substituters = https://cache.nixos.org/ https://nixcache.reflex-frp.org/
2−trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=
3−trusted-users = travis
nix/reflex-platform.nixdeleted−7
@@ -1,7 +0,0 @@
1−let
2− rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;
3−in import (builtins.fetchTarball
4− {
5− url = "https://github.com/reflex-frp/reflex-platform/archive/${rev}.tar.gz";
6− sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;
7− }) {}
nix/servant-snap.nixdeleted−7
@@ -1,7 +0,0 @@
1−# Servant-snap is marked broken in nixpkgs
2−{ nixpkgs ? import <nixpkgs> {}}: self: super:
3−self.callCabal2nix "servant-snap" (nixpkgs.fetchgit {
4− url = "https://github.com/haskell-servant/servant-snap.git";
5− rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";
6− sha256 = "sha256-fzzQGwG8Ko72OO/kwLMG52eNZSt3F2dxhNgM9gaO4yQ=";
7−}) {}
nix/testresults.nixdeleted−17
@@ -1,17 +0,0 @@
1−{ curl, reflexPlatform, testdriver, testserver, phantomjs }:
2−
3−reflexPlatform.nixpkgs.pkgs.runCommand "runWebdriveTest.sh" {} ''
4− echo About to phantom
5− ${phantomjs}/bin/phantomjs --webdriver=127.0.0.1:4444 &
6− sleep 3
7− echo About to Server
8− STATIC_DIR=${testserver}/static ${testserver}/back -q --no-access-log --no-error-log -p 8000 &
9− sleep 3
10− ${curl}/bin/curl localhost:8000
11− ${curl}/bin/curl localhost:8000/runmain.js
12− echo About to testdrive
13− ${testdriver}/bin/spec > $out 2>&1
14− echo Done
15− trap "exit" INT TERM
16− trap "kill 0" EXIT
17− ''
nix/testserver.nixdeleted−9
@@ -1,9 +0,0 @@
1−servant-reflex: self: super:
2−
3−(self.callCabal2nix "testserver" ../testserver {}).overrideDerivation (drv: {
4− postInstall = ''
5− cp dist/build/back/back $out/back
6− mkdir $out/static
7− cp ${servant-reflex}/bin/example.jsexe/* $out/static/
8− '';
9−})
overrides-ghc.nixnew file+11
@@ -0,0 +1,11 @@
1+{ reflex-platform, ... }:
2+let
3+ c2n = reflex-platform.cabal2nixResult;
4+ dc = reflex-platform.lib.dontCheck;
5+in reflex-platform.ghc.override {
6+ overrides = self: super: {
7+ servant-snap = dc (self.callPackage (c2n deps/servant-snap) {});
8+ heist = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});
9+ xmlhtml = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
10+ };
11+}
overrides.nixnew file+9
@@ -0,0 +1,9 @@
1+{ reflex-platform, ... }:
2+let
3+ dc = reflex-platform.lib.dontCheck;
4+ c2n = reflex-platform.cabal2nixResult;
5+in
6+reflex-platform.ghcjs.override {
7+ overrides = self: super: {
8+ };
9+}
servant-reflex.cabal+20−26
@@ -1,8 +1,8 @@
11Name: servant-reflex
2−Version: 0.3.6
3−Synopsis: servant API generator for reflex apps
4−Description: Generate reflex-compatible client functions from servant API descriptions
5−License: BSD3
2+Version: 0.3.1
3+Synopsis: Servant reflex API generator
4+Description: Servant reflex API generator
5+License: AllRightsReserved
66License-file: LICENSE.md
77Author: Greg Hale, Doug Beardsley
88Maintainer: imalsogreg@gmail.com
@@ -17,35 +17,37 @@ Flag Example
1717
1818library
1919 exposed-modules:
20− Servant.Common.BaseUrl
21− Servant.Common.Req
2220 Servant.Reflex
2321 Servant.Reflex.Multi
22+ Servant.Reflex.Tuple
23+
24+ other-modules:
25+ Servant.Common.BaseUrl
26+ Servant.Common.Req
2427
2528 hs-source-dirs: src
2629 build-depends:
27− base >= 4.8 && < 5,
30+ base >= 4.8 && < 4.10,
2831 bytestring >= 0.10 && < 0.11,
2932 case-insensitive >= 1.2.0.4 && < 1.3,
30− containers >= 0.5.6 && < 0.7,
33+ containers >= 0.5.6 && < 0.6,
3134 data-default >= 0.5 && < 0.8,
32− exceptions >= 0.8 && < 0.11,
35+ exceptions >= 0.8 && < 0.9,
3336 ghcjs-dom >= 0.2 && < 0.10,
34− http-api-data >= 0.3.6 && < 0.5,
35− http-media >= 0.6 && < 0.9,
37+ http-api-data >= 0.2 && < 0.4,
38+ http-media >= 0.6 && < 0.7,
3639 jsaddle >= 0.8 && < 0.10,
3740 mtl >= 2.2.1 && < 2.3,
3841 network-uri >= 2.6 && < 2.7,
39− reflex >= 0.5 && < 0.9,
40− reflex-dom-core >= 0.6 && < 0.8,
42+ reflex >= 0.5 && < 0.6,
43+ reflex-dom == 0.4 && < 0.5,
4144 safe >= 0.3.9 && < 0.4,
42− servant >= 0.16 && < 0.19,
43− servant-auth >= 0.2.1 && < 0.4,
45+ servant >= 0.8 && < 0.11,
4446 string-conversions >= 0.4 && < 0.5,
4547 text >= 1.2 && < 1.3,
4648 transformers >= 0.4 && < 0.6
4749
48− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
50+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
4951
5052 default-language: Haskell2010
5153
@@ -54,17 +56,9 @@ executable example
5456 buildable: True
5557 else
5658 buildable: False
57− build-depends:
58− aeson,
59− reflex,
60− servant-reflex,
61− base,
62− scientific,
63− servant,
64− reflex-dom,
65− reflex-dom-core,
66− text
59+ build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text
6760 default-language: Haskell2010
6861 main-is: Example.hs
6962 other-modules: API
63+ TupleExample
7064 hs-source-dirs: exec
shell.nixdeleted−1
@@ -1 +0,0 @@
1−(import ./travis.nix {nativeCompiler = "ghc";}).ghcPkgs.servant-reflex.env
src/Servant/Common/BaseUrl.hs+7−10
@@ -1,5 +1,4 @@
11{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE CPP #-}
32{-# LANGUAGE DeriveDataTypeable #-}
43{-# LANGUAGE DeriveGeneric #-}
54{-# LANGUAGE FlexibleContexts #-}
@@ -29,14 +28,11 @@ import qualified Data.Text as T
2928import GHC.Generics
3029import Language.Javascript.JSaddle.Monad (MonadJSM)
3130import Reflex
32−import Reflex.Dom.Core
31+import Reflex.Dom
3332import Text.Read
3433
35−#if !MIN_VERSION_reflex_dom_core(0,7,0)
34+
3635type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadJSM (Performable m))
37−#else
38−type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, MonadJSM (Performable m))
39−#endif
4036
4137-- | URI scheme to use
4238data Scheme =
@@ -89,14 +85,15 @@ baseUrlWidget = elClass "div" "base-url" $ do
8985 where pathWidget :: m (Dynamic t BaseUrl)
9086 pathWidget = do
9187 text "Url base path"
92− t <- inputElement def
88+ t <- textInput (def {_textInputConfig_attributes =
89+ constDyn ("placeholder" =: "/a/b")})
9390 return $ BasePath <$> value t
9491 fullUrlWidget :: m (Dynamic t BaseUrl)
9592 fullUrlWidget = do
9693 schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def
97− srv <- inputElement def
94+ srv <- textInput def {_textInputConfig_attributes = constDyn $ "placeholder" =: "example.com"}
9895 text ":"
99− prt <- inputElement def
96+ prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}
10097 port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))
101− path <- inputElement def
98+ path <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "a/b" }
10299 return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path
src/Servant/Common/Req.hs+305−114
@@ -4,22 +4,18 @@
44{-# LANGUAGE GADTs #-}
55{-# LANGUAGE OverloadedStrings #-}
66{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE RankNTypes #-}
87{-# LANGUAGE ScopedTypeVariables #-}
98{-# LANGUAGE TupleSections #-}
109
1110module Servant.Common.Req where
1211
1312-------------------------------------------------------------------------------
14−import Control.Applicative (liftA2, liftA3)
15−import Control.Arrow ((&&&))
1613import Control.Concurrent
14+import Control.Applicative (liftA2, liftA3)
1715import Control.Monad (join)
1816import Control.Monad.IO.Class (MonadIO, liftIO)
1917import Data.Bifunctor (first)
20−import qualified Data.ByteString.Builder as Builder
2118import qualified Data.ByteString.Lazy.Char8 as BL
22−import Data.ByteString (ByteString)
2319import qualified Data.Map as Map
2420import Data.Maybe (catMaybes, fromMaybe)
2521import Data.Functor.Compose
@@ -30,8 +26,8 @@ import qualified Data.Text as T
3026import qualified Data.Text.Encoding as TE
3127import Data.Traversable (forM)
3228import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
33−import qualified Network.URI as N
34−import Reflex.Dom.Core hiding (tag)
29+import Reflex.Dom hiding (tag)
30+import Reflex.Dom.Xhr (newXMLHttpRequest)
3531import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
3632 SupportsServantReflex)
3733import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
@@ -52,23 +48,6 @@ data ReqResult tag a
5248 -- ^ A failure to construct the request tagged with 'tag' at trigger time
5349 deriving (Functor)
5450
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'
7251
7352------------------------------------------------------------------------------
7453-- | Simple filter/accessor for successful responses, when you want to
@@ -93,13 +72,6 @@ reqFailure (ResponseFailure _ s _) = Just s
9372reqFailure (RequestFailure _ s) = Just s
9473reqFailure _ = Nothing
9574
96−------------------------------------------------------------------------------
97−-- | Simple filter/accessor like 'reqFailure', but keeping the request tag
98−reqFailure' :: ReqResult tag a -> Maybe (tag,Text)
99−reqFailure' (ResponseFailure tag s _) = Just (tag,s)
100−reqFailure' (RequestFailure tag s) = Just (tag,s)
101−reqFailure' _ = Nothing
102−
10375
10476------------------------------------------------------------------------------
10577-- | Simple filter/accessor for the raw XHR response
@@ -137,6 +109,10 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
137109 | QueryPartParams (Dynamic t [Text])
138110 | QueryPartFlag (Dynamic t Bool)
139111
112+data QueryPartIO = QueryPartParamIO (Maybe Text)
113+ | QueryPartParamsIO [Text]
114+ | QueryPartFlagIO Bool
115+
140116
141117-------------------------------------------------------------------------------
142118-- The data structure used to build up request information while traversing
@@ -151,16 +127,38 @@ data Req t = Req
151127 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))
152128 }
153129
130+data ReqIO = ReqIO
131+ { reqMethodIO :: Text
132+ , reqPathPartsIO :: [Text]
133+ , qParamsIO :: [(Text, QueryPartIO)]
134+ , reqBodyIO :: Maybe (BL.ByteString, Text)
135+ , headersIO :: [(Text, Text)]
136+ , respHeadersIO :: XhrResponseHeaders
137+ , authDataIO :: Maybe BasicAuthData
138+ }
139+
154140defReq :: Req t
155141defReq = Req "GET" [] [] Nothing [] def Nothing
156142
143+defReqIO :: ReqIO
144+defReqIO = ReqIO "GET" [] [] Nothing [] def Nothing
145+
157146prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t
158147prependToPathParts p req =
159148 req { reqPathParts = p : reqPathParts req }
160149
150+
161151addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
162152addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
163153
154+prependToPathPartsIO :: Text -> ReqIO -> ReqIO
155+prependToPathPartsIO p req =
156+ req { reqPathPartsIO = p : reqPathPartsIO req }
157+
158+addHeaderIO :: (ToHttpApiData a) => Text -> a -> ReqIO -> ReqIO
159+addHeaderIO name val req = req { headersIO = (name, (TE.decodeUtf8 . toHeader) val) : headersIO req }
160+
161+
164162
165163reqToReflexRequest
166164 :: forall t. Reflex t
@@ -179,22 +177,18 @@ reqToReflexRequest reqMeth reqHost req =
179177 urlParts = fmap sequence t
180178
181179 urlPath :: Dynamic t (Either Text Text)
182− urlPath = (fmap.fmap)
183− (T.intercalate "/" . fmap escape)
184− urlParts
180+ urlPath = (fmap.fmap) (T.intercalate "/") urlParts
185181
186182 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
187183 queryPartString (pName, qp) = case qp of
188184 QueryPartParam p -> ffor p $ \case
189185 Left e -> Just (Left e)
190− Right (Just a) -> Just (Right $ pName <> "=" <> escape a)
186+ Right (Just a) -> Just (Right $ pName <> "=" <> a)
191187 Right Nothing -> Nothing
192188 QueryPartParams ps -> ffor ps $ \pStrings ->
193189 if null pStrings
194190 then Nothing
195− else Just . Right
196− . T.intercalate "&"
197− $ fmap (\p -> pName <> "=" <> escape p) pStrings
191+ else Just $ Right (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) pStrings))
198192 QueryPartFlag fl -> ffor fl $ \case
199193 True -> Just $ Right pName
200194 False -> Nothing
@@ -202,7 +196,9 @@ reqToReflexRequest reqMeth reqHost req =
202196
203197 queryPartStrings :: [Dynamic t (Maybe (Either Text Text))]
204198 queryPartStrings = map queryPartString (qParams req)
205− queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Dynamic t (Either Text [Text])
199+
200+ queryPartStrings' :: Dynamic t (Either Text [Text])
201+ queryPartStrings' = sequence . catMaybes <$> sequence queryPartStrings :: Dynamic t (Either Text [Text])
206202 queryString :: Dynamic t (Either Text Text) =
207203 ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs
208204 xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q)
@@ -216,23 +212,23 @@ reqToReflexRequest reqMeth reqHost req =
216212 xhrHeaders :: Dynamic t (Either Text [(Text, Text)])
217213 xhrHeaders = (fmap sequence . sequence . fmap f . headers) req
218214 where
219− f = \(headerName, dynam) ->
215+ f (headerName, dynam) =
220216 fmap (fmap (\rightVal -> (headerName, rightVal))) dynam
221217
222218 mkConfigBody :: Either Text [(Text,Text)]
223− -> (Either Text (BL.ByteString, Text))
219+ -> Either Text (BL.ByteString, Text)
224220 -> Either Text (XhrRequestConfig XhrPayload)
225221 mkConfigBody ehs rb = case (ehs, rb) of
226222 (_, Left e) -> Left e
227223 (Left e, _) -> Left e
228224 (Right hs, Right (bBytes, bCT)) ->
229− Right $ XhrRequestConfig
225+ Right XhrRequestConfig
230226 { _xhrRequestConfig_sendData = bytesToPayload bBytes
231227 , _xhrRequestConfig_headers =
232− Map.insert "Content-Type" bCT (Map.fromList hs)
228+ Map.insert "Content-Type" bCT (Map.fromList hs)
233229 , _xhrRequestConfig_user = Nothing
234230 , _xhrRequestConfig_password = Nothing
235− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
231+ , _xhrRequestConfig_responseType = Nothing
236232 , _xhrRequestConfig_withCredentials = False
237233 , _xhrRequestConfig_responseHeaders = def
238234 }
@@ -244,8 +240,8 @@ reqToReflexRequest reqMeth reqHost req =
244240 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
245241 , _xhrRequestConfig_user = Nothing
246242 , _xhrRequestConfig_password = Nothing
247− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
248− , _xhrRequestConfig_sendData = mempty
243+ , _xhrRequestConfig_responseType = Nothing
244+ , _xhrRequestConfig_sendData = ""
249245 , _xhrRequestConfig_withCredentials = False
250246 }
251247 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
@@ -263,84 +259,255 @@ reqToReflexRequest reqMeth reqHost req =
263259 Nothing -> xhr
264260 Just auth -> liftA2 mkAuth auth xhr
265261
266− xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
262+ xhrReq = (liftA2 . liftA2) (XhrRequest reqMeth) xhrUrl (addAuth xhrOpts)
267263
268264 in xhrReq
269265
266+reqToReflexRequestIO
267+ :: Text
268+ -> BaseUrl
269+ -> ReqIO
270+ -> XhrRequest XhrPayload
271+reqToReflexRequestIO reqMeth reqHost req =
272+ let t :: [Text]
273+ t = reverse $ reqPathPartsIO req
274+
275+ baseUrl :: Text
276+ baseUrl = showBaseUrl reqHost
277+
278+ urlParts :: [Text]
279+ urlParts = t
280+
281+ urlPath :: Text
282+ urlPath = T.intercalate "/" urlParts
283+
284+ queryPartString :: (Text, QueryPartIO) -> Maybe Text
285+ queryPartString (pName, qp) = case qp of
286+ QueryPartParamIO p -> case p of
287+ Just a -> Just (pName <> "=" <> a)
288+ _ -> Nothing
289+ QueryPartParamsIO ps ->
290+ if null ps
291+ then Nothing
292+ else Just (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) ps))
293+ QueryPartFlagIO fl -> if fl
294+ then Just pName
295+ else Nothing
296+
297+
298+ queryPartStrings :: [Maybe Text]
299+ queryPartStrings = map queryPartString (qParamsIO req)
300+
301+ queryPartStrings' :: [Text]
302+ queryPartStrings' = catMaybes queryPartStrings
303+
304+ queryString :: Text = T.intercalate "&" queryPartStrings'
305+
306+ xhrUrl = (\a p q -> a </> if T.null q then p else p <> "?" <> q)
307+ baseUrl urlPath queryString
308+ where
309+ (</>) :: Text -> Text -> Text
310+ x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y
311+ | otherwise = x <> "/" <> y
312+
313+
314+ xhrHeaders :: [(Text, Text)]
315+ xhrHeaders = headersIO req
316+
317+ mkConfigBody :: [(Text,Text)]
318+ -> (BL.ByteString, Text)
319+ -> XhrRequestConfig XhrPayload
320+ mkConfigBody hs (bBytes, bCT) =
321+ XhrRequestConfig
322+ { _xhrRequestConfig_sendData = bytesToPayload bBytes
323+ , _xhrRequestConfig_headers =
324+ Map.insert "Content-Type" bCT (Map.fromList hs)
325+ , _xhrRequestConfig_user = Nothing
326+ , _xhrRequestConfig_password = Nothing
327+ , _xhrRequestConfig_responseType = Nothing
328+ , _xhrRequestConfig_withCredentials = False
329+ , _xhrRequestConfig_responseHeaders = def
330+ }
331+
332+ xhrOpts :: XhrRequestConfig XhrPayload
333+ xhrOpts = case reqBodyIO req of
334+ Nothing -> def { _xhrRequestConfig_headers = Map.fromList xhrHeaders
335+ , _xhrRequestConfig_user = Nothing
336+ , _xhrRequestConfig_password = Nothing
337+ , _xhrRequestConfig_responseType = Nothing
338+ , _xhrRequestConfig_sendData = ""
339+ , _xhrRequestConfig_withCredentials = False
340+ }
341+ Just rBody -> mkConfigBody xhrHeaders rBody
342+
343+ mkAuth :: BasicAuthData -> XhrRequestConfig x -> XhrRequestConfig x
344+ mkAuth (BasicAuthData u p) config = config
345+ { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
346+ , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
347+
348+ addAuth :: XhrRequestConfig x
349+ -> XhrRequestConfig x
350+ addAuth xhr = case authDataIO req of
351+ Nothing -> xhr
352+ Just auth -> mkAuth auth xhr
353+
354+ xhrReq = (XhrRequest reqMeth) xhrUrl (addAuth xhrOpts)
355+
356+ in xhrReq
357+
358+
270359-- * performing requests
271360
272361displayHttpRequest :: Text -> Text
273362displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
274363
275−-- | This function performs the request
364+-- | This function actually performs the request.
276365performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
277366 => Text
278367 -> Dynamic t (f (Req t))
279368 -> Dynamic t BaseUrl
280− -> ClientOptions
281369 -> Event t tag
282370 -> m (Event t (tag, f (Either Text XhrResponse)))
283−performRequests reqMeth rs reqHost opts trigger = do
284− let xhrReqs =
285− join $ (\(fxhr :: f (Req t)) -> sequence $
286− reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
287−
288− -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
289− reqs = attachPromptlyDynWith
290− (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
291−
292− resps <- performSomeRequestsAsync opts reqs
371+performRequests reqMeth rs reqHost trigger = do
372+ -- let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))
373+ let xhrReqs = join $ (\(fxhr :: f (Req t)) -> sequence $ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
374+ let reqs = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
375+ resps <- performSomeRequestsAsync reqs
293376 return $ getCompose <$> resps
294377
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.
378+
379+performRequestsIO :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
380+ => Text
381+ -> Event t (f ReqIO)
382+ -> BaseUrl
383+ -> m (Event t (f XhrResponse))
384+performRequestsIO reqMeth rs reqHost = do
385+ -- let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))
386+ -- let xhrReqs = join $ (\(fxhr :: f (Req t)) -> sequence $ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
387+ let xhrReqs :: (Event t (f (XhrRequest XhrPayload))) = fmap (reqToReflexRequestIO reqMeth reqHost) <$> rs
388+ -- let reqs = attachPromptlyDynWith (\fxhr t -> fxhr) xhrReqs trigger
389+ resps <- performRequestsAsync xhrReqs
390+ return $ resps
391+
392+
393+-- | 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.
298394performSomeRequestsAsync
299− :: (MonadIO (Performable m),
395+ :: (MonadJSM (Performable m),
300396 MonadJSM (Performable m),
301−#if !MIN_VERSION_reflex_dom_core(0,7,0)
302397 HasWebView (Performable m),
303−#endif
304398 PerformEvent t m,
305399 TriggerEvent t m,
306400 Traversable f,
307− IsXhrPayload a,
308− Show a
309− )
310− => ClientOptions
311− -> Event t (f (Either Text (XhrRequest a)))
401+ IsXhrPayload a)
402+ => Event t (f (Either Text (XhrRequest a)))
312403 -> m (Event t (f (Either Text XhrResponse)))
313−performSomeRequestsAsync opts =
314− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
404+performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return
315405
316406
317407------------------------------------------------------------------------------
318408-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
319−-- that accepts 'f (Either e (XhrRequestb))' events
409+-- that accepts 'f (Either e (XhrRequest))' events
320410performSomeRequestsAsync'
321− :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
322− => ClientOptions
323− -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
411+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
412+ => (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
324413 -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
325−performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
414+performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
326415 rs <- hrs
327416 resps <- forM rs $ \r -> case r of
328− Left e -> do
329− resp <- liftIO $ newMVar (Left e)
330− return resp
417+ Left e -> liftIO $ newMVar (Left e)
418+
331419 Right r' -> do
332420 resp <- liftIO newEmptyMVar
333− r'' <- liftJSM $ (optsRequestFixup opts) r'
334− _ <- newXhr r'' $ liftIO . putMVar resp . Right
421+ _ <- newXhr r' $ liftIO . putMVar resp . Right
335422 return resp
336423 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
337424 return ()
338425
339426
340427
341−type XhrPayload = ByteString
428+-- | This function actually performs the request.
429+performRequest :: forall t m tag .(SupportsServantReflex t m)
430+ => Text
431+ -> Req t
432+ -> Dynamic t BaseUrl
433+ -> Event t tag
434+ -> m (Event t (tag, XhrResponse), Event t (tag, Text))
435+performRequest reqMeth req reqHost trigger = do
436+
437+ let xhrReq = reqToReflexRequest reqMeth reqHost req
438+ let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger
439+ okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) e) reqs
440+ badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) e) reqs
441+
442+ resps <- performRequestsAsync okReqs
443+
444+ return (resps, badReqs)
445+
446+
447+-- -- | This function actually performs the request.
448+-- performRequestIO :: forall t m tag. (SupportsServantReflex t m)
449+-- => Text
450+-- -> ReqIO
451+-- -> BaseUrl
452+-- -> tag
453+-- -> m (Either (tag, XhrResponse) (tag, Text))
454+-- performRequestIO reqMeth req reqHost trigger = do
455+
456+-- let xhrReq = reqToReflexRequestIO reqMeth reqHost req
457+-- let reqs = (trigger ,xhrReq )
458+
459+-- -- resps <- performRequestsAsync okReqs
460+
461+-- -- let x :: _ = newXMLHttpRequestWithError
462+
463+-- -- return (resps, badReqs)
464+-- undefined
465+
466+-- doThing :: (IsXhrPayload a, MonadJSM m, HasJSContext m) => XhrRequest a -> m XhrResponse
467+-- doThing req = do
468+-- v <- liftIO newEmptyMVar
469+-- r <- newXMLHttpRequest req (liftIO . putMVar v)
470+-- liftIO $ takeMVar v
471+
472+
473+type XhrPayload = T.Text
342474bytesToPayload :: BL.ByteString -> XhrPayload
343−bytesToPayload = BL.toStrict
475+bytesToPayload = TE.decodeUtf8 . BL.toStrict
476+
477+
478+-- performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)
479+-- => Text
480+-- -> Req t
481+-- -> Dynamic t BaseUrl
482+-- -> Event t tag -> m (Event t (ReqResult tag NoContent))
483+-- performRequestNoBody reqMeth req reqHost trigger = do
484+-- (resp, badReq) <- performRequest reqMeth req reqHost trigger
485+-- let decodeResp = const $ Right NoContent
486+-- return $ leftmost [ fmap (evalResponse decodeResp) resp
487+-- , fmap (uncurry RequestFailure) badReq
488+-- ]
489+
490+
491+-- performRequestCT
492+-- :: (SupportsServantReflex t m,
493+-- MimeUnrender ct a)
494+-- => Proxy ct
495+-- -> Text
496+-- -> Req t
497+-- -> Dynamic t BaseUrl
498+-- -> Event t tag
499+-- -> m (Event t (ReqResult tag a))
500+-- performRequestCT ct reqMeth req reqHost trigger = do
501+-- (resp, badReq) <- performRequest reqMeth req reqHost trigger
502+-- let decodeResp x = first T.pack .
503+-- mimeUnrender ct .
504+-- BL.fromStrict .
505+-- TE.encodeUtf8 =<< note "No body text"
506+-- (_xhrResponse_responseText x)
507+
508+-- return $ leftmost [fmap (evalResponse decodeResp) resp
509+-- , fmap (uncurry RequestFailure) badReq
510+-- ]
344511
345512
346513performRequestsCT
@@ -350,35 +517,57 @@ performRequestsCT
350517 -> Text
351518 -> Dynamic t (f (Req t))
352519 -> Dynamic t BaseUrl
353− -> ClientOptions
354520 -> Event t tag
355521 -> m (Event t (f (ReqResult tag a)))
356−performRequestsCT ct reqMeth reqs reqHost opts trigger = do
357− resps <- performRequests reqMeth reqs reqHost opts trigger
358− let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
359− first T.pack .
360− mimeUnrender ct $
361− BL.fromStrict x
362− decodeResp _ = Left "No body"
522+performRequestsCT ct reqMeth reqs reqHost trigger = do
523+ resps <- performRequests reqMeth reqs reqHost trigger
524+ let decodeResp x = first T.pack .
525+ mimeUnrender ct .
526+ BL.fromStrict .
527+ TE.encodeUtf8 =<< note "No body text"
528+ (_xhrResponse_responseText x)
363529 return $ fmap
364530 (\(t,rs) -> ffor rs $ \r -> case r of
365531 Left e -> RequestFailure t e
366− Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
532+ Right g -> evalResponse decodeResp (t,g)
367533 )
368534 resps
369535
370536
537+performRequestsCTIO
538+ :: (SupportsServantReflex t m,
539+ MimeUnrender ct a, Traversable f)
540+ => Proxy ct
541+ -> Text
542+ -> Event t (f ReqIO)
543+ -> BaseUrl
544+ -> m (Event t (f (Either Text a)))
545+performRequestsCTIO ct reqMeth reqs reqHost = do
546+ resps <- performRequestsIO reqMeth reqs reqHost
547+ let decodeResp x = first T.pack .
548+ mimeUnrender ct .
549+ BL.fromStrict .
550+ TE.encodeUtf8 =<< note "No body text"
551+ (_xhrResponse_responseText x)
552+ return $ fmap (fmap decodeResp) resps
553+ -- return $ fmap
554+ -- (\(t,rs) -> ffor rs $ \r -> case r of
555+ -- Left e -> RequestFailure t e
556+ -- Right g -> evalResponse decodeResp (t,g)
557+ -- )
558+ -- resps
559+
560+
371561performRequestsNoBody
372562 :: (SupportsServantReflex t m,
373563 Traversable f)
374564 => Text
375565 -> Dynamic t (f (Req t))
376566 -> Dynamic t BaseUrl
377− -> ClientOptions
378567 -> Event t tag
379568 -> m (Event t (f (ReqResult tag NoContent)))
380−performRequestsNoBody reqMeth reqs reqHost opts trigger = do
381− resps <- performRequests reqMeth reqs reqHost opts trigger
569+performRequestsNoBody reqMeth reqs reqHost trigger = do
570+ resps <- performRequests reqMeth reqs reqHost trigger
382571 let decodeResp = const $ Right NoContent
383572 return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
384573 Left e -> RequestFailure tag e
@@ -391,8 +580,7 @@ evalResponse
391580 -> (tag, XhrResponse)
392581 -> ReqResult tag a
393582evalResponse decode (tag, xhr) =
394− let status = _xhrResponse_status xhr
395− okStatus = status >= 200 && status < 400
583+ let okStatus = _xhrResponse_status xhr < 400
396584 errMsg = fromMaybe
397585 ("Empty response with error code " <>
398586 T.pack (show $ _xhrResponse_status xhr))
@@ -405,17 +593,26 @@ evalResponse decode (tag, xhr) =
405593 else ResponseFailure tag errMsg xhr
406594 in respPayld
407595
408−------------------------------------------------------------------------------
409−-- | Utility for simultaneously accessing/filtering Success and Failure
410−-- response 'Event's,
411−fanReqResult :: Reflex t => Event t (ReqResult tag a) -> (Event t Text, Event t a)
412−fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess
596+-- ------------------------------------------------------------------------------
597+-- evalResponseIO
598+-- :: (XhrResponse -> Either Text a)
599+-- -> (XhrResponse)
600+-- -> ReqResult tag a
601+-- evalResponseIO decode (tag, xhr) =
602+-- let okStatus = _xhrResponse_status xhr < 400
603+-- errMsg = fromMaybe
604+-- ("Empty response with error code " <>
605+-- T.pack (show $ _xhrResponse_status xhr))
606+-- (_xhrResponse_responseText xhr)
607+-- respPayld = if okStatus
608+-- then either
609+-- (\e -> ResponseFailure tag e xhr)
610+-- (\v -> ResponseSuccess tag v xhr)
611+-- (decode xhr)
612+-- else ResponseFailure tag errMsg xhr
613+-- in respPayld
614+
413615
414−------------------------------------------------------------------------------
415−-- | Utility for simultaneously accessing/filtering Success and Failure
416−-- response 'Event's, but keeping the request tag
417−fanReqResult' :: Reflex t => Event t (ReqResult tag a) -> (Event t (tag, Text), Event t (tag, a))
418−fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'
419616
420617
421618note :: e -> Maybe a -> Either e a
@@ -424,9 +621,3 @@ note e = maybe (Left e) Right
424621fmapL :: (e -> e') -> Either e a -> Either e' a
425622fmapL _ (Right a) = Right a
426623fmapL f (Left e) = Left (f e)
427−
428−builderToText :: Builder.Builder -> T.Text
429−builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
430−
431−escape :: T.Text -> T.Text
432−escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
src/Servant/Reflex.hs+182−213
@@ -1,23 +1,19 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE InstanceSigs #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE Rank2Types #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TupleSections #-}
14−{-# LANGUAGE TypeFamilies #-}
15−{-# LANGUAGE TypeOperators #-}
16−{-# LANGUAGE UndecidableInstances #-}
17−
18−#if MIN_VERSION_base(4,9,0)
19−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
20−#endif
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE InstanceSigs #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE OverloadedStrings #-}
11+{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TupleSections #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE TypeOperators #-}
16+{-# LANGUAGE UndecidableInstances #-}
2117
2218-- #include "overlapping-compat.h"
2319-- | This module provides 'client' which can automatically generate
@@ -25,70 +21,56 @@
2521-- API.
2622module Servant.Reflex
2723 ( client
28− , clientWithOpts
29− , clientWithOptsAndResultHandler
30− , clientWithRoute
31− , clientWithRouteAndResultHandler
3224 , BuildHeaderKeysTo(..)
3325 , toHeaders
34− , HasClient
35− , Client
26+ , HasClient(..)
3627 , module Servant.Common.Req
3728 , module Servant.Common.BaseUrl
3829 ) where
3930
4031------------------------------------------------------------------------------
4132import Control.Applicative
42−import qualified Data.CaseInsensitive as CI
33+import Data.CaseInsensitive (mk)
4334import Data.Functor.Identity
44−import qualified Data.Map as Map
45−import Data.Monoid ((<>))
46−import Data.Proxy (Proxy (..))
47−import qualified Data.Set as Set
48−import Data.Text (Text)
49−import qualified Data.Text as T
50−import qualified Data.Text.Encoding as E
51−import GHC.Exts (Constraint)
52−import GHC.TypeLits (KnownSymbol, symbolVal)
53−import Servant.API ((:<|>) (..), (:>), BasicAuth,
54− BasicAuthData, BuildHeadersTo (..),
55− Capture, Header, Headers (..),
56− HttpVersion, IsSecure,
57− MimeRender (..), MimeUnrender,
58− NoContent, QueryFlag, QueryParam',
59− QueryParams, Raw, ReflectMethod (..),
60− RemoteHost, ReqBody,
61− ToHttpApiData (..), Vault, Verb,
62− contentType)
63−import Servant.API.Description (Summary)
64−import qualified Servant.Auth as Auth
65−
66−import Reflex.Dom.Core (Dynamic, Event, Reflex,
67− XhrRequest (..), XhrResponse (..),
68− XhrResponseHeaders (..),
69− attachPromptlyDynWith, constDyn, ffor,
70− fmapMaybe, leftmost,
71− performRequestsAsync)
35+import qualified Data.Map as Map
36+import Data.Monoid ((<>))
37+import Data.Proxy (Proxy (..))
38+import qualified Data.Set as Set
39+import Data.Text (Text)
40+import qualified Data.Text as T
41+import qualified Data.Text.Encoding as E
42+import GHC.TypeLits
43+import Servant.API ((:<|>) (..), (:>), BasicAuth,
44+ BasicAuthData, BuildHeadersTo (..),
45+ Capture, Header, Headers (..),
46+ HttpVersion, IsSecure, MimeRender (..),
47+ MimeUnrender, NoContent, QueryFlag,
48+ QueryParam, QueryParams, Raw,
49+ ReflectMethod (..), RemoteHost,
50+ ReqBody, ToHttpApiData (..), Vault,
51+ Verb, contentType)
52+
53+import Reflex.Dom (Dynamic, Event, Reflex,
54+ XhrRequest (..), XhrResponse (..),
55+ XhrResponseHeaders (..),
56+ attachPromptlyDynWith, constDyn, ffor,
57+ fmapMaybe, leftmost,
58+ performRequestsAsync)
7259------------------------------------------------------------------------------
73−import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
74− showBaseUrl,
75− SupportsServantReflex)
76−import Servant.Common.Req (ClientOptions(..),
77− defaultClientOptions,
78− Req, ReqResult(..), QParam(..),
79− QueryPart(..), addHeader, authData,
80− defReq, evalResponse, prependToPathParts,
81− -- performRequestCT,
82− performRequestsCT,
83− -- performRequestNoBody,
84− performRequestsNoBody,
85− performSomeRequestsAsync,
86− qParamToQueryPart, reqBody,
87− reqSuccess, reqFailure,
88− reqMethod, respHeaders,
89− response,
90− reqTag,
91− qParams, withCredentials)
60+import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
61+ SupportsServantReflex, baseUrlWidget,
62+ showBaseUrl)
63+import Servant.Common.Req (QParam (..), QueryPart (..), Req,
64+ ReqIO(..), ReqResult (..), addHeader, addHeaderIO,
65+ authData, defReq, evalResponse,
66+ performRequestsCT,
67+ performRequestsCTIO,
68+ performRequestsNoBody,
69+ performSomeRequestsAsync,
70+ prependToPathParts, prependToPathPartsIO, qParamToQueryPart,
71+ qParams, reqBody, reqFailure,
72+ reqMethod, reqSuccess, reqTag,
73+ respHeaders, response)
9274
9375
9476-- * Accessing APIs as a Client
@@ -103,75 +85,71 @@ import Servant.Common.Req (ClientOptions(..),
10385-- >
10486-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
10587-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
106−-- > -> m (Event t (l, ReqResult Book)))
88+-- -> m (Event t (l, ReqResult Book)))
10789-- > (getAllBooks :<|> postNewBook) = client myApi host
10890-- > where host = constDyn $ BaseUrl Http "localhost" 8080
109−client
110− :: (HasClient t m layout tag)
111− => Proxy layout
112− -> Proxy m
113− -> Proxy tag
114− -> Dynamic t BaseUrl
115− -> Client t m layout tag
116−client p q t baseurl = clientWithRoute p q t defReq baseurl defaultClientOptions
117−
118−clientWithOpts
119− :: (HasClient t m layout tag)
120− => Proxy layout
121− -> Proxy m
122− -> Proxy tag
123− -> Dynamic t BaseUrl
124− -> ClientOptions
125− -> Client t m layout tag
126−clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
127−
128−-- | Like 'clientWithOpts' but allows passing a function which will process the
129−-- result event in some way. This can be used to handle errors in a uniform way
130−-- across call sites.
131−clientWithOptsAndResultHandler
132− :: (HasClient t m layout tag)
133− => Proxy layout
134− -> Proxy m
135− -> Proxy tag
136− -> Dynamic t BaseUrl
137− -> ClientOptions
138− -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
139− -> Client t m layout tag
140−clientWithOptsAndResultHandler p q t = clientWithRouteAndResultHandler p q t defReq
91+client :: (HasClient t m layout tag)
92+ => Proxy layout -> Proxy m -> Proxy tag -> Dynamic t BaseUrl -> Client t m layout tag
93+client p q t = clientWithRoute p q t defReq
14194
14295
14396-- | This class lets us define how each API combinator
14497-- influences the creation of an HTTP request. It's mostly
14598-- an internal class, you can just use 'client'.
146−class Monad m => HasClient t m layout (tag :: *) where
99+class HasClient t m layout (tag :: *) | m -> t where
147100 type Client t m layout tag :: *
101+ type ClientIO m layout tag :: *
102+ type Inp m layout tag :: k
148103 clientWithRoute
149104 :: Proxy layout
150105 -> Proxy m
151106 -> Proxy tag
152107 -> Req t
153108 -> Dynamic t BaseUrl
154− -> ClientOptions
155109 -> Client t m layout tag
156− clientWithRoute l m t r b o = clientWithRouteAndResultHandler l m t r b o return
157−
158− clientWithRouteAndResultHandler
110+ clientWithRouteIO
159111 :: Proxy layout
160112 -> Proxy m
161113 -> 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
114+ -> ReqIO
115+ -> BaseUrl
116+ -> ClientIO m layout tag
117+
118+data HList :: [*] -> * where
119+ HNil :: HList '[]
120+ HCons :: a -> HList xs -> HList (a ': xs)
121+
122+
123+type family ToTuple xs :: *
124+
125+type instance ToTuple (HList '[]) = ()
126+type instance ToTuple (HList (a ': '[])) = a
127+type instance ToTuple (HList (a ': b ': '[])) = (a,b)
128+type instance ToTuple (HList (a ': b ': c ': '[])) = (a,b,c)
129+type instance ToTuple (HList (a ': b ': c ': d ': '[])) = (a,b,c,d)
130+type instance ToTuple (HList (a ': b ': c ': d ': e ': '[])) = (a,b,c,d,e)
131+type instance ToTuple (HList (a ': b ': c ': d ': e ': f ': '[])) = (a,b,c,d,e,f)
132+
133+type instance ToTuple (a :> ()) = a
134+type instance ToTuple (a :> b :> ()) = (a,b)
135+type instance ToTuple (a :> b :> c :> ()) = (a,b,c)
136+type instance ToTuple (a :> b :> c :> d :> ()) = (a,b,c,d)
137+type instance ToTuple (a :> b :> c :> d :> e :> ()) = (a,b,c,d,e)
138+type instance ToTuple (a :> b :> c :> d :> e :> f :> ()) = (a,b,c,d,e,f)
167139
168140
169141instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
170142 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
143+ type Inp m (a :<|> b) tag = Inp m a tag :<|> Inp m b tag
144+ type ClientIO m (a :<|> b) tag = ClientIO m a tag :<|> ClientIO m b tag
171145
172− clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =
173− clientWithRouteAndResultHandler (Proxy :: Proxy a) q pTag req baseurl opts wrap :<|>
174− clientWithRouteAndResultHandler (Proxy :: Proxy b) q pTag req baseurl opts wrap
146+ clientWithRoute Proxy q pTag req baseurl =
147+ clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>
148+ clientWithRoute (Proxy :: Proxy b) q pTag req baseurl
149+
150+ clientWithRouteIO Proxy q pTag req baseurl =
151+ clientWithRouteIO (Proxy :: Proxy a) q pTag req baseurl :<|>
152+ clientWithRouteIO (Proxy :: Proxy b) q pTag req baseurl
175153
176154
177155-- Capture. Example:
@@ -192,10 +170,26 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
192170 type Client t m (Capture capture a :> sublayout) tag =
193171 Dynamic t (Either Text a) -> Client t m sublayout tag
194172
195− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
196− clientWithRouteAndResultHandler
197− (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
198− where p = (fmap . fmap) (toUrlPiece) val
173+ -- type ClientIO m (Capture capture a :> sublayout) tag =
174+ -- ToTuple (Inp m (Capture capture a :> sublayout) -> ClientIO m sublayout tag
175+
176+ -- type Inp m (Capture capture a :> sublayout) tag =
177+ -- a :> Inp m sublayout tag
178+
179+ clientWithRoute Proxy q t req baseurl val =
180+ clientWithRoute (Proxy :: Proxy sublayout)
181+ q t
182+ (prependToPathParts p req)
183+ baseurl
184+ where p = (fmap . fmap) toUrlPiece val
185+
186+ -- clientWithRouteIO Proxy q t req baseurl val =
187+ -- clientWithRouteIO (Proxy :: Proxy sublayout)
188+ -- q t
189+ -- req
190+ -- -- (prependToPathPartsIO p req)
191+ -- baseurl
192+ -- where p = toUrlPiece val
199193
200194
201195-- VERB (Returning content) --
@@ -203,15 +197,26 @@ instance {-# OVERLAPPABLE #-}
203197 -- Note [Non-Empty Content Types]
204198 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
205199 ) => HasClient t m (Verb method status cts' a) tag where
200+
206201 type Client t m (Verb method status cts' a) tag =
207202 Event t tag -> m (Event t (ReqResult tag a))
203+
204+ type ClientIO m (Verb method status cts' a) tag =
205+ tag -> m (ReqResult tag a)
206+
208207 -- TODO how to access input types here?
209208 -- ExceptT ServantError IO a
210− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
211− wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
209+ clientWithRoute Proxy _ _ req baseurl trigs =
210+ -- performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs
211+ fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl trigs
212212 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
213213 req' = req { reqMethod = method }
214214
215+ -- clientWithRouteIO Proxy _ _ req baseurl tag =
216+ -- performRequestsCTIO (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl tag
217+ -- where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
218+ -- req' = req { reqMethodIO = method }
219+
215220
216221-- -- VERB (No content) --
217222instance {-# OVERLAPPING #-}
@@ -221,33 +226,29 @@ instance {-# OVERLAPPING #-}
221226 Event t tag -> m (Event t (ReqResult tag NoContent))
222227 -- TODO: how to access input types here?
223228 -- ExceptT ServantError IO NoContent
224− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
225− wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
229+ clientWithRoute Proxy _ _ req baseurl =
230+ (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl
226231 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
227232
228233
229234toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
230235toHeaders r =
231− let hdrs = maybe []
232− (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
236+ let toBS = E.encodeUtf8
237+ hdrs = maybe []
238+ (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
233239 (Map.toList $ _xhrResponse_headers xhr))
234240 (response r)
235241 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
236242
237−
238243class BuildHeaderKeysTo hs where
239− buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
244+ buildHeaderKeysTo :: Proxy hs -> [T.Text]
240245
241246instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
242247 where buildHeaderKeysTo _ = []
243248
244249instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
245250 => BuildHeaderKeysTo ((Header h v) ': xs) where
246− buildHeaderKeysTo _ =
247− let
248− thisKey = CI.mk $ T.pack (symbolVal (Proxy :: Proxy h))
249− in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)
250−
251+ buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
251252
252253-- HEADERS Verb (Content) --
253254-- Headers combinator not treated in fully general case,
@@ -262,10 +263,10 @@ instance {-# OVERLAPPABLE #-}
262263 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
263264 type Client t m (Verb method status cts' (Headers ls a)) tag =
264265 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
265− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
266+ clientWithRoute Proxy _ _ req baseurl trigs = do
266267 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
267− resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
268− wrap $ toHeaders <$> resp
268+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl trigs
269+ return $ toHeaders <$> resp
269270 where req' = req { respHeaders =
270271 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
271272 }
@@ -278,10 +279,10 @@ instance {-# OVERLAPPABLE #-}
278279 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
279280 type Client t m (Verb method status cts (Headers ls NoContent)) tag
280281 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
281− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
282+ clientWithRoute Proxy _ _ req baseurl trigs = do
282283 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
283− resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
284− wrap $ toHeaders <$> resp
284+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl trigs
285+ return $ toHeaders <$> resp
285286 where req' = req {respHeaders =
286287 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
287288 }
@@ -308,13 +309,20 @@ instance (KnownSymbol sym, ToHttpApiData a,
308309 type Client t m (Header sym a :> sublayout) tag =
309310 Dynamic t (Either Text a) -> Client t m sublayout tag
310311
311− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =
312− clientWithRouteAndResultHandler
313− (Proxy :: Proxy sublayout) q t
314− (Servant.Common.Req.addHeader hname eVal req)
315− baseurl opts wrap
312+ clientWithRoute Proxy q t req baseurl eVal =
313+ clientWithRoute (Proxy :: Proxy sublayout)
314+ q t
315+ (Servant.Common.Req.addHeader hname eVal req)
316+ baseurl
316317 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
317318
319+ -- clientWithRouteIO Proxy q t req baseurl eVal =
320+ -- clientWithRouteIO (Proxy :: Proxy sublayout)
321+ -- q t
322+ -- (Servant.Common.Req.addHeaderIO hname eVal req)
323+ -- baseurl
324+ -- where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
325+
318326
319327
320328
@@ -326,21 +334,8 @@ instance HasClient t m sublayout tag
326334 type Client t m (HttpVersion :> sublayout) tag =
327335 Client t m sublayout tag
328336
329− clientWithRouteAndResultHandler Proxy =
330− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
331−
332−-- | Using a 'Summary' combinator in your API doesn't affect the client
333−-- functions.
334−instance (HasClient t m sublayout tag, KnownSymbol sym)
335− => HasClient t m (Summary sym :> sublayout) tag where
336−
337− type Client t m (Summary sym :> sublayout) tag =
338− Client t m sublayout tag
339−
340− clientWithRouteAndResultHandler Proxy =
341− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
342−
343−
337+ clientWithRoute Proxy =
338+ clientWithRoute (Proxy :: Proxy sublayout)
344339
345340
346341-- | If you use a 'QueryParam' in one of your endpoints in your API,
@@ -370,15 +365,15 @@ instance (HasClient t m sublayout tag, KnownSymbol sym)
370365-- > -- 'getBooksBy Nothing' for all books
371366-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
372367instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)
373− => HasClient t m (QueryParam' mods sym a :> sublayout) tag where
368+ => HasClient t m (QueryParam sym a :> sublayout) tag where
374369
375− type Client t m (QueryParam' mods sym a :> sublayout) tag =
370+ type Client t m (QueryParam sym a :> sublayout) tag =
376371 Dynamic t (QParam a) -> Client t m sublayout tag
377372
378373 -- if mparam = Nothing, we don't add it to the query string
379− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
380− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
381− (req {qParams = paramPair : qParams req}) baseurl opts wrap
374+ clientWithRoute Proxy q t req baseurl mparam =
375+ clientWithRoute (Proxy :: Proxy sublayout) q t
376+ (req {qParams = paramPair : qParams req}) baseurl
382377
383378 where pname = symbolVal (Proxy :: Proxy sym)
384379 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -422,8 +417,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
422417 type Client t m (QueryParams sym a :> sublayout) tag =
423418 Dynamic t [a] -> Client t m sublayout tag
424419
425− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
426− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
420+ clientWithRoute Proxy q t req baseurl paramlist =
421+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
427422
428423 where req' = req { qParams = (T.pack pname, params') : qParams req }
429424 pname = symbolVal (Proxy :: Proxy sym)
@@ -462,8 +457,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
462457 type Client t m (QueryFlag sym :> sublayout) tag =
463458 Dynamic t Bool -> Client t m sublayout tag
464459
465− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
466− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
460+ clientWithRoute Proxy q t req baseurl flag =
461+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
467462
468463 where req' = req { qParams = thisPair : qParams req }
469464 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -477,7 +472,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
477472 -> Event t tag
478473 -> m (Event t (ReqResult tag ()))
479474
480− clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
475+ clientWithRoute _ _ _ _ baseurl xhrs triggers = do
481476
482477 let xhrs' = liftA2 (\x path -> case x of
483478 Left e -> Left e
@@ -488,7 +483,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
488483 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
489484
490485 resps <- performRequestsAsync okReq
491− wrap $ leftmost [ uncurry RequestFailure <$> badReq
486+ return $ leftmost [ uncurry RequestFailure <$> badReq
492487 , evalResponse (const $ Right ()) <$> resps
493488 ]
494489
@@ -519,8 +514,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
519514 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
520515 Dynamic t (Either Text a) -> Client t m sublayout tag
521516
522− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
523− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
517+ clientWithRoute Proxy q t req baseurl body =
518+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
524519 where req' = req { reqBody = bodyBytesCT }
525520 ctProxy = Proxy :: Proxy ct
526521 ctString = T.pack $ show $ contentType ctProxy
@@ -534,9 +529,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
534529instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
535530 type Client t m (path :> sublayout) tag = Client t m sublayout tag
536531
537− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =
538− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
539− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap
532+ clientWithRoute Proxy q t req =
533+ clientWithRoute (Proxy :: Proxy sublayout) q t
534+ (prependToPathParts (pure (Right $ T.pack p)) req)
540535
541536 where p = symbolVal (Proxy :: Proxy path)
542537
@@ -544,23 +539,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient
544539instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
545540 type Client t m (Vault :> api) tag = Client t m api tag
546541
547− clientWithRouteAndResultHandler Proxy =
548− clientWithRouteAndResultHandler (Proxy :: Proxy api)
542+ clientWithRoute Proxy =
543+ clientWithRoute (Proxy :: Proxy api)
549544
550545
551546instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
552547 type Client t m (RemoteHost :> api) tag = Client t m api tag
553548
554− clientWithRouteAndResultHandler Proxy =
555− clientWithRouteAndResultHandler (Proxy :: Proxy api)
549+ clientWithRoute Proxy =
550+ clientWithRoute (Proxy :: Proxy api)
556551
557552
558553
559554instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
560555 type Client t m (IsSecure :> api) tag = Client t m api tag
561556
562− clientWithRouteAndResultHandler Proxy =
563− clientWithRouteAndResultHandler (Proxy :: Proxy api)
557+ clientWithRoute Proxy =
558+ clientWithRoute (Proxy :: Proxy api)
564559
565560
566561instance (HasClient t m api tag, Reflex t)
@@ -569,8 +564,8 @@ instance (HasClient t m api tag, Reflex t)
569564 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
570565 -> Client t m api tag
571566
572− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
573− clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
567+ clientWithRoute Proxy q t req baseurl authdata =
568+ clientWithRoute (Proxy :: Proxy api) q t req' baseurl
574569 where
575570 req' = req { authData = Just authdata }
576571
@@ -596,29 +591,3 @@ non-empty lists, but is otherwise more specific, no instance will be overall
596591more specific. This in turn generally means adding yet another instance (one
597592for empty and one for non-empty lists).
598593-}
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
src/Servant/Reflex/Multi.hs+53−82
@@ -16,15 +16,12 @@
1616module Servant.Reflex.Multi (
1717 -- * Compute servant client functions
1818 clientA
19− , clientWithOptsA
2019 , BaseUrl(..)
2120 , Scheme(..)
2221
2322 -- * Build QueryParam arguments
2423 , QParam(..)
2524
26− -- * Access response data
27− , withCredentials
2825
2926 -- * Access response data
3027 , ReqResult(..)
@@ -37,45 +34,40 @@ module Servant.Reflex.Multi (
3734 ) where
3835
3936------------------------------------------------------------------------------
40−import Control.Applicative (liftA2)
41−import Data.Functor.Compose (Compose (..), getCompose)
42−import Data.Proxy (Proxy (..))
43−import qualified Data.Set as Set
44−import Data.Text (Text)
45−import qualified Data.Text as T
46−import qualified Data.Text.Encoding as E
47−import GHC.TypeLits (KnownSymbol, symbolVal)
48−import Servant.API ((:<|>) (..), (:>), BasicAuth,
49− BasicAuthData, BuildHeadersTo (..),
50− Capture, Header, Headers (..),
51− HttpVersion, IsSecure,
52− MimeRender (..), MimeUnrender,
53− NoContent, QueryFlag, QueryParam,
54− QueryParams, Raw, ReflectMethod (..),
55− RemoteHost, ReqBody,
56− ToHttpApiData (..), Vault, Verb,
57− contentType)
58−import Servant.API.Description (Summary)
59−
60−import Reflex.Dom.Core (Dynamic, Event, Reflex,
61− XhrRequest (..),
62− XhrResponseHeaders (..),
63− attachPromptlyDynWith, constDyn)
37+import Control.Applicative (liftA2)
38+import Data.Functor.Compose (Compose (..), getCompose)
39+import Data.Proxy (Proxy (..))
40+import qualified Data.Set as Set
41+import Data.Text (Text)
42+import qualified Data.Text as T
43+import qualified Data.Text.Encoding as E
44+import GHC.TypeLits (KnownSymbol, symbolVal)
45+import Servant.API ((:<|>) (..), (:>), BasicAuth,
46+ BasicAuthData, BuildHeadersTo (..),
47+ Capture, Header, Headers (..),
48+ HttpVersion, IsSecure, MimeRender (..),
49+ MimeUnrender, NoContent, QueryFlag,
50+ QueryParam, QueryParams, Raw,
51+ ReflectMethod (..), RemoteHost,
52+ ReqBody, ToHttpApiData (..), Vault,
53+ Verb, contentType)
54+
55+import Reflex.Dom (Dynamic, Event, Reflex,
56+ XhrRequest (..),
57+ XhrResponseHeaders (..),
58+ attachPromptlyDynWith, constDyn)
6459------------------------------------------------------------------------------
6560import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
6661 SupportsServantReflex)
67−import Servant.Common.Req (ClientOptions,
68− QParam (..), QueryPart (..), Req,
62+import Servant.Common.Req (QParam (..), QueryPart (..), Req,
6963 ReqResult (..), addHeader, authData,
70− defReq,
71− defaultClientOptions,
72− performRequestsCT,
64+ defReq, performRequestsCT,
7365 performRequestsNoBody,
7466 performSomeRequestsAsync,
7567 prependToPathParts, qParamToQueryPart,
7668 qParams, reqBody, reqFailure,
7769 reqMethod, reqSuccess, reqSuccess',
78− respHeaders, response, withCredentials)
70+ respHeaders, response)
7971import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
8072
8173
@@ -85,24 +77,14 @@ clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
8577 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
8678clientA p q f tag baseurl =
8779 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
88− defaultClientOptions
89−
9080
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
9981
10082------------------------------------------------------------------------------
10183class HasClientMulti t m layout f (tag :: *) where
10284 type ClientMulti t m layout f tag :: *
10385 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
10486 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
105− -> ClientOptions -> ClientMulti t m layout f tag
87+ -> ClientMulti t m layout f tag
10688
10789
10890------------------------------------------------------------------------------
@@ -110,9 +92,9 @@ instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>
11092 HasClientMulti t m (a :<|> b) f tag where
11193 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>
11294 ClientMulti t m b f tag
113− clientWithRouteMulti Proxy q f tag reqs baseurl opts =
114− clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>
115− clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts
95+ clientWithRouteMulti Proxy q f tag reqs baseurl =
96+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl :<|>
97+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl
11698
11799
118100------------------------------------------------------------------------------
@@ -125,8 +107,8 @@ instance (SupportsServantReflex t m,
125107 type ClientMulti t m (Capture capture a :> sublayout) f tag =
126108 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
127109
128− clientWithRouteMulti _ q f tag reqs baseurl opts vals =
129− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
110+ clientWithRouteMulti _ q f tag reqs baseurl vals =
111+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
130112 where
131113 reqs' = (prependToPathParts <$> ps <*>) <$> reqs
132114 ps = (fmap . fmap . fmap) toUrlPiece vals
@@ -146,8 +128,8 @@ instance {-# OVERLAPPABLE #-}
146128 type ClientMulti t m (Verb method status cts' a) f tag =
147129 Event t tag -> m (Event t (f (ReqResult tag a)))
148130
149− clientWithRouteMulti _ _ _ _ reqs baseurl opts =
150− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts
131+ clientWithRouteMulti _ _ _ _ reqs baseurl =
132+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
151133 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
152134 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
153135
@@ -161,8 +143,8 @@ instance {-# OVERLAPPING #-}
161143 Event t tag -> m (Event t (f (ReqResult tag NoContent)))
162144 -- TODO: how to access input types here?
163145 -- ExceptT ServantError IO NoContent
164− clientWithRouteMulti Proxy _ _ _ req baseurl opts =
165− performRequestsNoBody method req baseurl opts
146+ clientWithRouteMulti Proxy _ _ _ req baseurl =
147+ performRequestsNoBody method req baseurl
166148 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
167149
168150
@@ -176,9 +158,9 @@ instance {-# OVERLAPPABLE #-}
176158 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where
177159 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =
178160 Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))
179− clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
161+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
180162 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
181− resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))
163+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl triggers :: m (Event t (f (ReqResult tag a)))
182164 return $ fmap toHeaders <$> resp
183165 where
184166 reqs' = fmap (\r ->
@@ -199,9 +181,9 @@ instance {-# OVERLAPPABLE #-}
199181 cts (Headers ls NoContent)) f tag where
200182 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag
201183 = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))
202− clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
184+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
203185 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
204− resp <- performRequestsNoBody method reqs' baseurl opts triggers
186+ resp <- performRequestsNoBody method reqs' baseurl triggers
205187 return $ fmap toHeaders <$> resp
206188 where reqs' = fmap (\req ->
207189 req {respHeaders = OnlyHeaders (Set.fromList
@@ -221,11 +203,11 @@ instance (KnownSymbol sym,
221203 type ClientMulti t m (Header sym a :> sublayout) f tag =
222204 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
223205
224− clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =
206+ clientWithRouteMulti Proxy f q tag reqs baseurl eVals =
225207 clientWithRouteMulti (Proxy :: Proxy sublayout) f
226208 q tag
227209 reqs'
228− baseurl opts
210+ baseurl
229211 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
230212 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
231213 <$> eVals <*>) <$> reqs
@@ -242,17 +224,6 @@ instance HasClientMulti t m sublayout f tag
242224 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
243225
244226
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−
256227------------------------------------------------------------------------------
257228instance (KnownSymbol sym,
258229 ToHttpApiData a,
@@ -266,9 +237,9 @@ instance (KnownSymbol sym,
266237
267238 -- if mparam = Nothing, we don't add it to the query string
268239 -- TODO: Check the above comment
269− clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =
240+ clientWithRouteMulti Proxy q f tag reqs baseurl mparams =
270241 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
271− reqs' baseurl opts
242+ reqs' baseurl
272243
273244 where pname = symbolVal (Proxy :: Proxy sym)
274245 p prm = QueryPartParam $ fmap qParamToQueryPart prm
@@ -289,8 +260,8 @@ instance (KnownSymbol sym,
289260 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
290261 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
291262
292− clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =
293− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
263+ clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =
264+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
294265
295266 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }
296267 pname = symbolVal (Proxy :: Proxy sym)
@@ -308,8 +279,8 @@ instance (KnownSymbol sym,
308279 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
309280 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
310281
311− clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =
312− clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts
282+ clientWithRouteMulti Proxy q f' tag reqs baseurl flags =
283+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl
313284
314285 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
315286 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
@@ -323,10 +294,10 @@ instance (SupportsServantReflex t m,
323294 -> Event t tag
324295 -> m (Event t (f (ReqResult tag ())))
325296
326− clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do
297+ clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do
327298 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
328299 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
329− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''
300+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync rawReqs''
330301 return resps
331302 where
332303 aux (tag, Right r) = ResponseSuccess tag () r
@@ -342,8 +313,8 @@ instance (MimeRender ct a,
342313 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
343314 Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
344315
345− clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
346− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
316+ clientWithRouteMulti Proxy q f tag reqs baseurl bodies =
317+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
347318 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
348319 ctProxy = Proxy :: Proxy ct
349320 ctString = T.pack $ show $ contentType ctProxy
@@ -394,8 +365,8 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
394365 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))
395366 -> ClientMulti t m api f tag
396367
397− clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =
398− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts
368+ clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =
369+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl
399370 where
400371 req' a r = r { authData = Just (constDyn a) }
401372 reqs' = liftA2 req' <$> authdatas <*> reqs
src/Servant/Reflex/Tuple.hsnew file+245
@@ -0,0 +1,245 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE InstanceSigs #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE OverloadedStrings #-}
11+{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TupleSections #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE TypeOperators #-}
16+{-# LANGUAGE UndecidableInstances #-}
17+
18+-- #include "overlapping-compat.h"
19+-- | This module provides 'client' which can automatically generate
20+-- querying functions for each endpoint just from the type representing your
21+-- API.
22+module Servant.Reflex.Tuple
23+ ( client
24+ , BuildHeaderKeysTo(..)
25+ , toHeaders
26+ , HasClient(..)
27+ , module Servant.Common.Req
28+ , module Servant.Common.BaseUrl
29+ ) where
30+
31+------------------------------------------------------------------------------
32+import Control.Applicative
33+import Data.CaseInsensitive (mk)
34+import Data.Functor.Identity
35+import qualified Data.Map as Map
36+import Data.Monoid ((<>))
37+import Data.Proxy (Proxy (..))
38+import qualified Data.Set as Set
39+import Data.Text (Text)
40+import qualified Data.Text as T
41+import qualified Data.Text.Encoding as E
42+import GHC.TypeLits (KnownSymbol, symbolVal)
43+import Servant.API ((:<|>) (..), (:>), BasicAuth,
44+ BasicAuthData, BuildHeadersTo (..),
45+ Capture, Header, Headers (..),
46+ HttpVersion, IsSecure, MimeRender (..),
47+ MimeUnrender, NoContent, QueryFlag,
48+ QueryParam, QueryParams, Raw,
49+ ReflectMethod (..), RemoteHost,
50+ ReqBody, ToHttpApiData (..), Vault,
51+ Verb, contentType)
52+
53+import Reflex.Dom (Dynamic, Event, Reflex,
54+ XhrRequest (..), XhrResponse (..),
55+ XhrResponseHeaders (..),
56+ attachPromptlyDynWith, constDyn, ffor,
57+ fmapMaybe, leftmost,
58+ performRequestsAsync)
59+------------------------------------------------------------------------------
60+import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
61+ SupportsServantReflex, baseUrlWidget,
62+ showBaseUrl)
63+import Servant.Common.Req (QParam (..), QueryPart (..), Req,
64+ ReqIO, ReqResult (..), addHeaderIO,
65+ authData, defReqIO, evalResponse,
66+ performRequestsCT,
67+ performRequestsNoBody,
68+ performSomeRequestsAsync,
69+ prependToPathPartsIO, qParamToQueryPart,
70+ qParams, reqBody, reqFailure,
71+ reqMethodIO, reqSuccess, reqTag,
72+ respHeadersIO, response)
73+
74+type family ToTuple a :: *
75+
76+type instance ToTuple () = ()
77+type instance ToTuple (a,()) = a
78+type instance ToTuple (a,(b,())) = (a,b)
79+type instance ToTuple (a,(b,(c,()))) = (a,b,c)
80+type instance ToTuple (a,(b,(c,(d,())))) = (a,b,c)
81+type instance ToTuple (a,(b,(c,(d,(e,()))))) = (a,b,c,d,e)
82+
83+client :: (HasClient layout t m, HasInp layout) => Proxy layout -> Proxy m -> BaseUrl -> Client layout t m
84+client = undefined
85+
86+class HasInp layout where
87+ type Inp layout :: *
88+ type Out layout :: *
89+ inpToReq :: Proxy layout -> Inp layout -> ReqIO
90+
91+class HasClient layout (t :: *) (m :: * -> *) where
92+ type Client layout t m :: *
93+
94+instance (HasClient a t m,
95+ HasClient b t m,
96+ HasInp a,
97+ HasInp b
98+ ) => HasClient (a :<|> b) t m where
99+ type Client (a :<|> b) t m = Client a t m :<|> Client b t m
100+
101+instance (ToHttpApiData a, HasInp sublayout) => HasInp (Capture capture a :> sublayout) where
102+ type Inp (Capture capture a :> sublayout) = (a, Inp sublayout)
103+ type Out (Capture capture a :> sublayout) = Out sublayout
104+ inpToReq _ (a, otherInp) = prependToPathPartsIO (toUrlPiece a) $ inpToReq (Proxy :: Proxy sublayout) otherInp
105+
106+instance (HasInp (Capture capture a :> sublayout)) => HasClient (Capture capture a :> sublayout) t m where
107+ type Client (Capture capture a :> sublayout) t m =
108+ Event t (ToTuple (Inp (Capture capture a :> sublayout))) ->
109+ m (Event t (Out (Capture capture a :> sublayout)))
110+
111+
112+
113+instance {-# OVERLAPPABLE #-}
114+ (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
115+ ) => HasInp (Verb method status cts' a) where
116+ type Inp (Verb method status cts' a) = ()
117+ type Out (Verb method status cts' a) = Either Text a
118+ inpToReq _ _ = defReqIO
119+
120+instance {-# OVERLAPPABLE #-}
121+ (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
122+ ) => HasClient (Verb method status cts' a) t m where
123+ type Client (Verb method status cts' a) t m = Event t (ToTuple (Inp (Verb method status cts' a))) ->
124+ m (Event t (Out (Verb method status cts' a)))
125+
126+
127+instance {-# OVERLAPPING #-}
128+ (ReflectMethod method) => HasInp (Verb method status cts NoContent) where
129+ type Inp (Verb method status cts NoContent) = ()
130+ type Out (Verb method status cts NoContent) = Either Text NoContent
131+
132+
133+instance {-# OVERLAPPING #-}
134+ (ReflectMethod method, SupportsServantReflex t m)
135+ => HasClient (Verb method status cts NoContent) t m where
136+ type Client (Verb method status cts NoContent) t m =
137+ Event t (ToTuple (Inp (Verb method status cts NoContent))) ->
138+ m (Event t (Out (Verb method status cts NoContent)))
139+
140+
141+instance {-# OVERLAPPABLE #-}
142+ (MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
143+ ReflectMethod method, cts' ~ (ct ': cts)
144+ ) => HasInp (Verb method status cts' (Headers ls a)) where
145+ type Inp (Verb method status cts' (Headers ls a)) = ()
146+ type Out (Verb method status cts' (Headers ls a)) = Either Text (Headers ls a)
147+ inpToReq _ _ = defReqIO { respHeadersIO =
148+ OnlyHeaders (Set.fromList
149+ (buildHeaderKeysTo
150+ (Proxy :: Proxy ls)))
151+ }
152+
153+
154+------------------------------------------------------------------------------
155+instance {-# OVERLAPPABLE #-}
156+ HasInp (Verb method status cts' (Headers ls a))
157+ => HasClient (Verb method status cts' (Headers ls a)) t m where
158+ type Client (Verb method status cts' (Headers ls a)) t m =
159+ Event t (ToTuple (Inp (Verb method status cts' (Headers ls a)))) ->
160+ m (Event t (Out (Verb method status cts' (Headers ls a))))
161+
162+
163+------------------------------------------------------------------------------
164+instance {-# OVERLAPPING #-}
165+ (BuildHeadersTo ls,
166+ BuildHeaderKeysTo ls
167+ ) => HasInp (Verb method status cts' (Headers ls NoContent)) where
168+ type Inp (Verb method status cts' (Headers ls NoContent)) = ()
169+ type Out (Verb method status cts' (Headers ls NoContent)) =
170+ Either Text (Headers ls NoContent)
171+ inpToReq _ _ = defReqIO { respHeadersIO =
172+ OnlyHeaders (Set.fromList
173+ (buildHeaderKeysTo
174+ (Proxy :: Proxy ls)))
175+ }
176+
177+
178+------------------------------------------------------------------------------
179+instance {-# OVERLAPPING #-}
180+ (BuildHeadersTo ls,
181+ BuildHeaderKeysTo ls,
182+ SupportsServantReflex t m
183+ ) => HasClient (Verb method status cts' (Headers ls NoContent)) t m where
184+ type Client (Verb method status cts' (Headers ls NoContent)) t m =
185+ Event t (ToTuple (Inp (Verb method status cts' (Headers ls NoContent)))) ->
186+ m (Event t (Out (Verb method status cts' (Headers ls NoContent))))
187+
188+
189+------------------------------------------------------------------------------
190+toHeaders
191+ :: BuildHeadersTo ls
192+ => ReqResult tag a
193+ -> ReqResult tag (Headers ls a)
194+toHeaders r =
195+ let toBS = E.encodeUtf8
196+ hdrs = maybe []
197+ (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
198+ (Map.toList $ _xhrResponse_headers xhr))
199+ (response r)
200+ in ffor r $ \a -> Headers {getResponse = a
201+ ,getHeadersHList = buildHeadersTo hdrs
202+ }
203+
204+
205+------------------------------------------------------------------------------
206+class BuildHeaderKeysTo hs where
207+ buildHeaderKeysTo :: Proxy hs -> [T.Text]
208+
209+
210+------------------------------------------------------------------------------
211+instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
212+ where buildHeaderKeysTo _ = []
213+
214+
215+------------------------------------------------------------------------------
216+instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
217+ => BuildHeaderKeysTo ((Header h v) ': xs) where
218+ buildHeaderKeysTo _ =
219+ T.pack (symbolVal (Proxy :: Proxy h)) :
220+ buildHeaderKeysTo (Proxy :: Proxy xs)
221+
222+
223+------------------------------------------------------------------------------
224+instance (KnownSymbol sym,
225+ ToHttpApiData a,
226+ HasInp sublayout
227+ ) => HasInp (Header sym a :> sublayout) where
228+ type Inp (Header sym a :> sublayout) = (Maybe a, Inp sublayout)
229+ type Out (Header sym a :> sublayout) = Out sublayout
230+ inpToReq _ (h, vs) =
231+ (addHeaderIO hname h) (inpToReq (Proxy :: Proxy sublayout) vs)
232+ where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
233+
234+
235+------------------------------------------------------------------------------
236+instance (KnownSymbol sym,
237+ ToHttpApiData a,
238+ HasClient sublayout t m
239+ ) => HasClient (Header sym a :> sublayout) t m where
240+ type Client (Header sym a :> sublayout) t m =
241+ Event t (ToTuple (Inp (Header sym a :> sublayout)))
242+ -> m (Event t (Out (Header sym a :> sublayout)))
243+
244+
245+------------------------------------------------------------------------------
testdriver/test/Servant/ReflexSpec.hs+1−2
@@ -9,7 +9,6 @@ import qualified Data.Text as T
99import Data.Foldable
1010import Test.WebDriver.Commands.Wait
1111import Test.Hspec.WebDriver
12−import Test.Hspec.WebDriver (chromeCaps)
1312
1413
1514clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()
@@ -29,7 +28,7 @@ spec :: Spec
2928spec = do
3029 describe "servant-reflex tests" $ do
3130
32− session "test page" $ using [chromeCaps] $ do
31+ session "test page" $ using Chrome $ do
3332
3433 it "opens the page" $ runWD $
3534 openPage "http://localhost:8000"
testserver/API.hsmode 100644 → 120000+1−69
@@ -1,69 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TypeOperators #-}
4−
5−module API where
6−
7−import Data.Aeson
8−import Data.Aeson.Types (typeMismatch)
9−import Data.Text (Text)
10−import Servant.API
11−
12−newtype Question = Question { unQuestion :: Text } deriving (Show)
13−
14−instance ToJSON Question where
15− toJSON (Question txt) = object ["question" .= txt]
16−
17−instance FromJSON Question where
18− parseJSON (Object v) = Question <$> v .: "question"
19− parseJSON x = typeMismatch "Couldn't find key 'question'" x
20−
21−newtype Answer = Answer { unAnswer :: Text } deriving (Show)
22−
23−instance ToJSON Answer where
24− toJSON (Answer txt) = object ["answer" .= txt]
25−
26−instance FromJSON Answer where
27− parseJSON (Object v) = Answer <$> v .: "answer"
28− parseJSON x = typeMismatch "Couldn't find key 'answer'" x
29−
30−
31−-- | API spec for server, client, and docs
32−type API = "getunit" :> Get '[JSON] ()
33− :<|> "getint" :> Get '[JSON] Int
34− :<|> "sayhi" :> QueryParam "username" Text
35− :> QueryParams "greetings" Text
36− :> QueryFlag "gusto"
37− :> Get '[JSON] Text
38− :<|> "double" :> ReqBody '[JSON] Double
39− :> Post '[JSON] Double
40− :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
41− :<|> "qna" :> ReqBody '[JSON] Question
42− :> Post '[JSON] Answer
43− :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
44− :<|> Raw
45−
46−type GET = Get '[JSON] ()
47−
48−-- Imported the comprehensive API example for testing.
49−-- https://github.com/haskell-servant/servant/blob/master/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs
50−type ComprehensiveAPI =
51− GET :<|>
52− Get '[JSON] Int :<|>
53− Capture "foo" Int :> GET :<|>
54− Header "foo" Int :> GET :<|>
55− HttpVersion :> GET :<|>
56− IsSecure :> GET :<|>
57− QueryParam "foo" Int :> GET :<|>
58− QueryParams "foo" Int :> GET :<|>
59− QueryFlag "foo" :> GET :<|>
60−-- Raw :<|>
61− RemoteHost :> GET :<|>
62− ReqBody '[JSON] Int :> GET :<|>
63− Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>
64− "foo" :> GET :<|>
65− Vault :> GET :<|>
66− Verb 'POST 204 '[JSON] () :<|>
67− Verb 'POST 204 '[JSON] Int
68−-- This one isn't in scope
69−-- :<|> WithNamedContext "foo" '[] GET
@@ -0,0 +1 @@
1+../exec/API.hs
testserver/Main.hs+5−20
@@ -2,17 +2,14 @@
22{-# LANGUAGE DeriveGeneric #-}
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE TypeApplications #-}
65{-# LANGUAGE TypeFamilies #-}
76{-# LANGUAGE TypeOperators #-}
87
98import Control.Monad.IO.Class (liftIO)
10−import Control.Monad.Reader (reader)
119import Data.Aeson
1210import Data.Bool
1311import Data.Char (toUpper)
1412import qualified Data.List as L
15−import Data.Maybe (fromMaybe)
1613import Data.Monoid
1714import Data.Proxy
1815import Data.Text hiding (head, length, map,
@@ -27,7 +24,6 @@ import Snap.Http.Server
2724import Servant
2825import Servant.Server
2926-- import Snap.Util.FileServe
30−import System.Environment (lookupEnv)
3127import API
3228import Snap
3329
@@ -43,7 +39,7 @@ instance ToJSON Greet
4339testApi :: Proxy API
4440testApi = Proxy
4541
46−data App = App { appStaticDir :: String }
42+data App = App
4743
4844-- Server-side handlers.
4945--
@@ -51,10 +47,8 @@ data App = App { appStaticDir :: String }
5147-- that represents the API, are glued together using :<|>.
5248--
5349-- Each handler runs in the 'ExceptT ServantErr IO' monad.
54−server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
55−server = return () :<|> return 100 :<|> sayhi :<|> dbl
56− :<|> multi :<|> qna :<|> serveSecret
57− :<|> statics
50+server :: Server API (Handler App App)
51+server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> serveDirectory "static"
5852 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
5953 sayhi nm greetings withGusto = case nm of
6054 Nothing -> return ("Sorry, who are you?" :: Text)
@@ -75,27 +69,18 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl
7569 putStrLn $ "qna got: " ++ show q
7670 T.putStrLn $ unQuestion q
7771 return $ Answer $ unQuestion q
78− serveSecret _ = do
79− req <- getRequest
80− liftIO $ putStrLn (show req)
81− return 101
82− statics = do
83− staticDir <- reader appStaticDir
84− serveDirectory staticDir
8572
8673-- Turn the server into a WAI app. 'serve' is provided by servant,
8774-- more precisely by the Servant.Server module.
8875test :: Handler App App ()
89−test = serveSnapWithContext testApi
90− (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server
76+test = serveSnap testApi server
9177
9278initApp :: SnapletInit App App
9379initApp = makeSnaplet "myapp" "example" Nothing $ do
94− staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")
9580 addRoutes [("", test)
9681 ,("", serveDirectory "static")
9782 ]
98− return (App staticDir)
83+ return App
9984
10085-- Put this all to work!
10186main :: IO ()
testserver/run-wd-tests.shnew file+5
@@ -0,0 +1,5 @@
1+#!/usr/bin/env bash
2+
3+dist/build/back/back -p 8000 &
4+phantomjs --webdriver=127.0.0.1:4444 &
5+dist/build/spec/spec
testserver/testserver.cabal+7−8
@@ -19,14 +19,13 @@ executable back
1919 main-is: Main.hs
2020 -- other-modules:
2121 -- other-extensions:
22− build-depends: aeson >= 0.9 && < 1.5
23− , base >=4.8 && < 5
24− , mtl
25− , snap >= 1.0 && < 1.2
26− , snap-server >= 1.0 && < 1.2
22+ build-depends: aeson >= 0.9 && < 1.1
23+ , base >=4.8 && <4.10
24+ , snap >= 1.0 && < 1.1
25+ , snap-server >= 1.0 && < 1.1
2726 , snap-core >= 1.0 && < 1.1
28− , servant >= 0.16 && < 0.18
29− , servant-snap >= 0.8 && < 0.9
30− , text >= 1.0 && < 1.3
27+ , servant >= 0.8 && < 0.11
28+ , servant-snap >= 0.7.2 && < 0.8
29+ , text >= 1.2 && < 1.3
3130 -- hs-source-dirs:
3231 default-language: Haskell2010
testserver/tr.nixnew file+32
@@ -0,0 +1,32 @@
1+{ reflex-platform, ... }:
2+let
3+
4+ dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;
5+ cabal2nixResult = reflex-platform.cabal2nixResult;
6+ nixpkgs = (import <nixpkgs> {});
7+in
8+reflex-platform.ghc.override {
9+ overrides = self: super: {
10+ servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});
11+ snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap) {});
12+ io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});
13+ io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});
14+ heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});
15+ xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});
16+ snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});
17+ snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});
18+ snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});
19+ snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});
20+ hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});
21+
22+ # servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});
23+ # servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});
24+ # servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});
25+ # servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});
26+ # servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});
27+ # servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});
28+ # servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});
29+ # servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});
30+
31+ };
32+}
travis.nixdeleted−70
@@ -1,70 +0,0 @@
1−{
2− nativeCompiler ? "ghc",
3− # ^ Choose a GHC for compiling backend components (web server, selenium)
4− # (ghc, ghc8_0, ghc8_2, ghc8_4 or ghcHEAD)
5−
6− jsCompiler ? "ghcjs"
7− # ^ Choose a GHCJS for compiling the frontend
8− # (ghcjs, ghcjs8_0, ghcjs8_2 or ghcjs8_4)
9−
10−}:
11−
12−let
13−
14− reflexPlatform = import ./nix/reflex-platform.nix;
15−
16− lib = reflexPlatform.nixpkgs.haskell.lib;
17− do = funs: pkg: builtins.foldl' (a: b: b a) pkg funs;
18−
19− ghcjsPkgs = with lib; reflexPlatform.${jsCompiler}.override {
20− overrides = self: super: {
21− http-media = dontCheck super.http-media;
22− servant = dontCheck super.servant;
23− lens-aeson = dontCheck super.lens-aeson;
24− servant-reflex = lib.appendConfigureFlag
25− (self.callPackage ./default.nix {}) "-fExample";
26− };
27− };
28−
29− ghcPkgs = with lib; reflexPlatform.${nativeCompiler}.override {
30− overrides = self: super: {
31− servant-snap = dontCheck ((import ./nix/servant-snap.nix {}) self super);
32− testdriver = self.callCabal2nix "testdriver" ./testdriver {};
33− testserver = import nix/testserver.nix ghcjsPkgs.servant-reflex self super;
34− servant-reflex = self.callPackage ./default.nix {};
35− };
36− };
37−
38− testresults = import ./nix/testresults.nix
39− { inherit reflexPlatform;
40− inherit (ghcPkgs) testserver testdriver;
41− inherit (reflexPlatform.nixpkgs) curl;
42− phantomjs = reflexPlatform.nixpkgs.phantomjs2;
43− };
44−
45−in
46− rec {
47−
48− inherit reflexPlatform ghcPkgs ghcjsPkgs;
49−
50− build = ghcjsPkgs.servant-reflex;
51− buildGhc = ghcPkgs.servant-reflex;
52− testserver = ghcPkgs.testserver;
53− testdriver = ghcPkgs.testdriver;
54− inherit testresults;
55−
56− cabalBuild = reflexPlatform.${jsCompiler}.shellFor {
57− name = "servant-reflex-cabal-builder";
58−
59− packages = p: [
60− build
61− ];
62−
63− shellHook = ''
64− cabal configure --ghcjs -f Example
65− cabal build
66− exec/toSite.sh
67− exit $?
68− '';
69− };
70− }