git.iko.soy/servant-reflex
on 5d0ef87 help sign in
f76dbeb
swap
0 ahead, 102 behind
.gitignore+1−3
since splitsnapshots
unifiedsplit
@@ -6,6 +6,4 @@ log
6*.webapp
6*.webapp
7*.stats
7*.stats
8out
8out
9−/.stack-work/
9+reflex-platform
10−TAGS
11−dist-newstyle
.gitmodules+15
@@ -0,0 +1,15 @@
1+[submodule "deps/reflex-dom"]
2+ path = deps/reflex-dom
3+ url = https://github.com/reflex-frp/reflex-dom.git
4+[submodule "deps/reflex"]
5+ path = deps/reflex
6+ url = https://github.com/reflex-frp/reflex.git
7+[submodule "deps/http-api-data"]
8+ path = deps/http-api-data
9+ url = https://github.com/fizruk/http-api-data
10+[submodule "deps/servant"]
11+ path = deps/servant
12+ url = https://github.com/haskell-servant/servant
13+[submodule "deps/servant-snap"]
14+ path = deps/servant-snap
15+ url = https://github.com/haskell-servant/servant-snap
.travis.yml+57−12
@@ -1,17 +1,62 @@
1−language: nix
1+sudo: required
2−nix: 2.3.6
2+
3−sudo: require
3+before_cache:
4+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
5+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
6+
7+addons:
8+ apt:
9+ - phantomjs
10+
11+matrix:
12+ include:
13+ - env: CABALVER=1.24 GHCVER=7.10.3
14+ compiler: ": #GHC 7.10.3"
15+ addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3], sources: [hvr-ghc]}}
16+ - env: CABALVER=1.24 GHCVER=8.0.1
17+ compiler: ": #GHC 8.0.1"
18+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
19+
20+
4
21
5before_install:
22before_install:
6− - sudo cp -rT $TRAVIS_BUILD_DIR/nix /etc/nix
23+ - unset CC
24+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
25+ - git submodule update --init --recursive
7
26
8−before_script:
27+install:
9− - sudo systemctl restart nix-daemon.service
28+ - cabal --version
10− - git config --global user.email "travis-ci@example.com"
29+ - BENCH=${BENCH---enable-benchmarks}
11− - git config --global user.name "Travis-CI"
30+ - TEST=${TEST---enable-tests}
31+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
32+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
33+ then
34+ zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
35+ $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
36+ fi
37+ - travis_retry cabal update -v
38+ - git clone https://github.com/reflex-frp/reflex-platform
39+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
40+ - reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal configure && cabal build"
41+ - reflex-platform/work-on ghc ./testdriver --command "cd testdriver && cabal configure && cabal build"
42+ - cd testserver && dist/build/back/back -p 8000 &
43+ - sleep 3
44+ - phantomjs --webdriver=127.0.0.1:4444 &
45+ - sleep 3
12
46
13script:
47script:
14− - nix-build travis.nix -A build
48+ - git config --global user.email "travis-ci@example.com"
15− - nix-build travis.nix -A buildGhc
49+ - git config --global user.name "Travis-CI"
16− - nix-build travis.nix -A testserver
50+ - ./build.sh
17− - nix-build travis.nix -A testresults
51+ - testdriver/dist/build/spec/spec
52+
53+cache:
54+ directories:
55+ - /nix
56+ - $HOME/.cabal/packages
57+ - $HOME/.cabal/store
58+
59+env:
60+ global:
61+ - ENCRYPTION_LABEL: "3c89d919c82e"
62+ - COMMIT_AUTHOR_EMAIL: "imalsogreg@gmail.com"
ChangeLog.mddeleted−60
@@ -1,60 +0,0 @@
1−0.3.5
2−-----
3−
4− - Require reflex-dom-core >= 0.6 (for internal handling of case-insensitive headers)
5− - Require servant >= 0.16
6− - Eliminate use of deprecated widgets from reflex-dom-core
7− - Bump the version of reflex-platform used in nix-shell and test suite
8−
9−0.3.4
10−-----
11−
12−Add selenium-based test suite
13−
14−0.3.3
15−-----
16−
17−- Fix encoding issue: Explicitly escape reserved characters from path pieces and query parameters
18−
19−
20−0.3.2
21−-----
22−
23−- **Addition of 'Servant.Reflex.Common.Req.ClientOpts'** which
24−allows the users to apply a final adjustment to Requests before
25−thery are sent, such as setting the 'withCredentials' flag
26−or print the Request to the console for debugging
27−[PR #47](https://github.com/imalsogreg/servant-reflex/pull/47)
28−
29−0.3
30−---
31−
32−- **Addition of the 'Servant.Reflex.Multi' module** which allows the user
33−to choose some '(Applicative f, Traversable f) => f' for collecting
34−endpoint parameters. The traversable instance is used for passing
35−multiple 'XhrRequest's in response to a single event trigger. The
36−Applicative instance is used to combine parameters. For example,
37−'Capture "id" Name :> QueryParam "greeting" Text :> Get '[JSON] Text'
38−will generate a client function:
39−`Dynamic t (f Name) -> Dynamic t (f greeting) -> Event t tag ->
40− m (Event t (f (ReqResult tag Text)))`
41−Calling that function with 'f' chosen to be list ('[]'), this call
42−`clientFun
43−(constDyn ["Greg", "Bernie"])
44−(constDyn ["Greetings", "Hey"])
45−trigger`
46−would produce four XhrRequests per 'trigger' event, one for each
47−combination of possible parameters, and one response event
48−would carry a list of the four responses.
49−A 'zip-wise' combination of the parameters can be chosen with
50−a different applicative wrapper: 'ZipList'
51−
52−- **Event tags**. A new type parameter lets users choose a payload
53−value to attach to outgoing requests at the point of triggering,
54−and which is embedded in the response, allowing individual
55−request-response pairs to be followed. The response's tag has been
56−added to each constructor `ReqResult tag a` type.
57−
58−- **Improved Unicode support** Thanks to Schell Scivally
59−(https://github.com/schell) for identifying and fixing a UTF-8
60−encoding bug!
README.md+28−114
@@ -2,21 +2,16 @@
2
2
3[![Build Status](https://travis-ci.org/imalsogreg/servant-reflex.svg?branch=master)](https://travis-ci.org/imalsogreg/servant-reflex)
3[![Build Status](https://travis-ci.org/imalsogreg/servant-reflex.svg?branch=master)](https://travis-ci.org/imalsogreg/servant-reflex)
4
4
5−## `servant-reflex` lets you share your `servant` APIs with the frontend
5+## The problem `servant-reflex` solves
6+
7+Keeping your frontend in sync with your API server can be difficult - when the API changes its input parameters or return type, XHR requests from the frontend will fail at runtime. If your API is defined by [servant](haskell-servant.readthedocs.io) combinators, you can use `servant-reflex` to share the API between the server and frontend.
8+Syncronization between is checked at compile time, and rather than building XHR requests by hand, API endpoints are available behind `reflex`'s FRP semantics.
6
9
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.
14
10
15
11
16## Example
12## Example
17
13
18−We have a webservice API defined in a module where both the server (compiled
14+We have a webservice API defined in a module where both the server (compiled with ghc) and the frontend (compiled with ghcjs) can see it:
19−with ghc) and the frontend (compiled with ghcjs) can see it:
20
15
21```haskell
16```haskell
22type API = "getint" :> Get '[JSON] Int
17type API = "getint" :> Get '[JSON] Int
@@ -29,8 +24,7 @@ type API = "getint" :> Get '[JSON] Int
29 :<|> Raw
24 :<|> Raw
30```
25```
31
26
32−`servant-reflex` then computes client functions that can query the API through
27+`servant-reflex` then computes client functions that can query the API through an `XhrRequest`.
33−an `XhrRequest`.
34
28
35```haskell
29```haskell
36
30
@@ -39,26 +33,16 @@ an `XhrRequest`.
39 -- servant-reflex computes FRP functions for each API endpoint
33 -- servant-reflex computes FRP functions for each API endpoint
40 let (getint :<|> sayhi :<|> doubleit :<|> _) = client (Proxy :: Proxy API)
34 let (getint :<|> sayhi :<|> doubleit :<|> _) = client (Proxy :: Proxy API)
41 (Proxy :: Proxy m)
35 (Proxy :: Proxy m)
42− (Proxy :: Proxy ())
43 (constDyn (BasePath "/"))
36 (constDyn (BasePath "/"))
44```
37```
45
38
46−These client functions are computed from your API type. They manage
39+These client functions are computed from your API type. They manage serialization, XhrRequest generation, and deserialization for you. `a` parameters used in URL captures become `Dynamic t (Either Text a)` parameters in the client functions. 'QueryFlag', 'QueryParams' and 'QueryParam' API parameters map to 'Dynamic t Bool', 'Dynamic t [a]' and 'Dynamic t (QParam a)' respectively. These parameters to the client function are wrapped with failure possibility to allow you to indicate at any time whether input validation for that parameter has failed and no valid XHR request can be generated. The final parameter is a trigger event for the XHR request. The return value `Event t (ReqResult a)` contains responses from the API server.
47−serialization, `XhrRequest` generation, and deserialization for you. `a`
48−parameters used in URL captures become `Dynamic t (Either Text a)` parameters
49−in the client functions. `QueryFlag`, `QueryParams` and `QueryParam` API
50−parameters map to `Dynamic t Bool`, `Dynamic t [a]` and `Dynamic t (QParam a)`
51−respectively. These parameters to the client function are wrapped with failure
52−possibility to allow you to indicate at any time whether input validation for
53−that parameter has failed and no valid XHR request can be generated. The final
54−parameter is a trigger event for the XHR request. The return value
55−`Event t (ReqResult a)` contains responses from the API server.
56
40
57```haskell
41```haskell
58 -- No need to write these functions. servant-reflex creates them for you!
42 -- No need to write these functions. servant-reflex creates them for you!
59 getint :: MonadWidget t m
43 getint :: MonadWidget t m
60 => Event t () -- ^ Trigger the XHR Request
44 => Event t () -- ^ Trigger the XHR Request
61− -> m (Event t (ReqResult () Int)) -- ^ Consume the answer
45+ -> m (Event t (ReqResult Int)) -- ^ Consume the answer
62
46
63 sayhi :: MonadWidget t m
47 sayhi :: MonadWidget t m
64 => Dynamic t (QParam Text)
48 => Dynamic t (QParam Text)
@@ -69,21 +53,15 @@ parameter is a trigger event for the XHR request. The return value
69 -- ^ Flag for capitalizing the response
53 -- ^ Flag for capitalizing the response
70 -> Event t ()
54 -> Event t ()
71 -- ^ Trigger the XHR Request
55 -- ^ Trigger the XHR Request
72− -> m (Event t (ReqResult () Text))
56+ -> m (Event t (ReqResult Text))
73
57
74 doubleit :: MonadWidget t m
58 doubleit :: MonadWidget t m
75 => Dynamic t (Either Text Double)
59 => Dynamic t (Either Text Double)
76 -> Event t ()
60 -> Event t ()
77− -> m (Event t (ReqResult () Double))
61+ -> m (Event t (ReqResult Double))
78```
62```
79
63
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)
64+`ReqResult a` is defined in [`Servant.Common.Req`](https://github.com/imalsogreg/servant-reflex/blob/6d866e338edb9bf6fd8f8d5083ff0187b4d8c0d2/src/Servant/Common/Req.hs#L40-L42) and reports whether or not your request was sent (if validation fails, the request won't be sent), and how decoding of the response went. You can pattern match on these explicitly, but usually you'll want to use `fmapMaybe :: (a -> Maybe b) -> Event t a -> Event t b` and one of the elimination functions to filter the result type you care about, like this:
82−and reports whether or not your request was sent (if validation fails, the
83−request won't be sent), and how decoding of the response went. You can pattern
84−match on these explicitly, but usually you'll want to use
85−`fmapMaybe :: (a -> Maybe b) -> Event t a -> Event t b` and one of the
86−elimination functions to filter the result type you care about, like this:
87
65
88```haskell
66```haskell
89 -- ... continued ...
67 -- ... continued ...
@@ -101,8 +79,7 @@ elimination functions to filter the result type you care about, like this:
101 dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])
79 dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])
102```
80```
103
81
104−This example builds some input fields to enter API parameters, buttons to
82+This example builds some input fields to enter API parameters, buttons to trigger the API calls, and text elements to show the results:
105−trigger the API calls, and text elements to show the results:
106
83
107```haskell
84```haskell
108 elClass "div" "int-demo" $ do
85 elClass "div" "int-demo" $ do
@@ -125,100 +102,37 @@ trigger the API calls, and text elements to show the results:
125 display =<< holdDyn Nothing outputDouble
102 display =<< holdDyn Nothing outputDouble
126```
103```
127
104
128−For a great introduction to recative DOM building, see the
105+For a great introduction to recative DOM building, see the [README](https://github.com/reflex-frp/reflex-platform) for the `reflex-platform`. For more information about servant, see their [documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to the respective authors of these fabulous libraries.
129−[README](https://github.com/reflex-frp/reflex-platform) for the
130−`reflex-platform`. For more information about servant, see their
131−[documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to
132−the respective authors of these fabulous libraries.
133
106
134
107
135## Building the library and test server
108## Building the library and test server
136
109
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).
110+This repository comes with a small example of an API shared between a ghcjs-compiled frontend ([exec/](https://github.com/imalsogreg/servant-reflex/tree/master/exec)) and a ghc-compiled backend ([testserver/](https://github.com/imalsogreg/servant-reflex/tree/master/testserver). To build these components:
142−To build these components, we will use the nix packages for the testserver. It
143−manages the frontend build as a dependency.
144
111
145−```
146−nix build -f travis.nix testserver -o server
147−```
148
112
149−Point it at the static directory and run it:
113+First build the library:
150
114
151```
115```
152−STATIC_DIR=server/static server/back -p 8000
116+git submodule update --init --recursive
117+./build.sh
153```
118```
154
119
155−Browse to [http://localhost:8000](http://localhost:8000) and click around.
120+Then build the test server:
156−Open the firefox or chrome developer tools and examine the XHR activity
157−under the Network tab.
158−
159−**For a larger example of a project that shares types between backend and
160−frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
161
121
122+```
123+deps/reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal build"
124+```
162
125
163−## Tagging requests
164
126
165−The input and the return type of a client function like `getDouble` are both
127+## Running the example site
166−event streams. The individual input events and responses occur at different
167−times and aren't automatically paired up, but you can recover the
168−relationship by tagging the requests.
169
128
170−So far we have used an `Event t ()` to trigger sending a request. If we choose
129+The server must be run from the directory where static assets live:
171−e.g. `Double` for the third `Proxy` argument to `client`, then `Event t Double`
172−will be used to trigger requests, and each `ReqResult` will carry the tag of
173−its request. Imagine we wanted to display not just the last "double" from
174−`doubleIt`, but a whole table of valid inputs and their doubled responses:
175
130
176−```haskell
177− ...
178− inp <- textInput def
179−
180− -- Convert the raw text into an `Either Text Double`
181− let inpNum = maybe (Left "No Parse") Right . readMaybe . T.unpack <$> value inp
182− go <- button "Double It"
183−
184− -- Call 'doubleIt' with triggers that coincide with good input parses
185− rs <- doubleIt inpNum (fforMaybe (tagPromptlyDyn inpNum go) $ \case
186− Left _ -> Nothing
187− Right a -> Just a
188− )
189−
190− -- Accumulate good responses in a map
191− doubleTable <- foldDyn (<>) mempty $ ffor rs $ \case
192− ResponseSuccess tag v _ -> tag =: v
193− _ -> mempty
194−
195− el "table" $ do
196− listWithKey doubleTable $ \k dv -> el "tr" $ do
197− el "td" $ text (T.pack $ show k)
198− el "td" $ dynText (T.pack . show <$> dv)
199− ...
200```
131```
201−
132+cd testserver
202−## Simultaneous requests
133+dist/build/back/back -p 8001
203−
204−`Servant.Reflex.Multi` provides an alternative client-generation function
205−called `clientA` (client applicative). Choose a container type that has both
206−`Applicative` and `Traversable` instances, and pass it to `clientA` through
207−another `Proxy`. Our `sayHi` client function will then have this type:
208−
209−```haskell
210−sayHi
211− :: Dynamic t (f (QParam Text))
212− -> Dynamic t (f [Text])
213− -> Dynamic t (f Bool)
214− -> Event t tag
215− -> m (Event t (f (ReqResult tag Text)))
216```
134```
217
135
218−The dynamic params are each wrapped in `f`. For every firing of the trigger
136+And simply browse to `localhost:8001`
219−event `tag`, all of these parameters will be combined according to `f`'s
137+
220−`Applicative` instance (when `f` is `[]`, you will get all combinations of
138+**For a larger example of a project that shares types between backend and frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
221−all parameters taken together as a request; when `f` is `ZipList`, the Nth
222−elemens of each parameters list will be taken together as a request). Using
223−this interface, you can trigger many XHR's from a single event occurence, and
224−expect the responses to be structured the same way as the requests.
build.shnew file+3
@@ -0,0 +1,3 @@
1+#!/usr/bin/env bash
2+
3+reflex-platform/work-on ./overrides.nix ./. --run "cabal configure --ghcjs && cabal build && exec/toSite.sh"
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/reflexnew file+1

Submodule changed.

deps/reflex-domnew file+1

Submodule changed.

deps/servantnew file+1

Submodule changed.

deps/servant-snapnew file+1

Submodule changed.

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