on afed558 help sign in
35 files changed+625−1264
since splitsnapshots
unifiedsplit
.gitignore−3 .gitmodules+15 .travis.yml+58−12 ChangeLog.md−60 README.md+28−114 build.sh+3 default.nix−21 deps/http-api-data+1 deps/reflex+1 deps/reflex-dom+1 deps/servant+1 deps/servant-snap+1 exec/API.hs+4−29 exec/Example.hs+19−69 nix/nix.conf−3 nix/reflex-platform.nix−7 nix/servant-snap.nix−7 nix/testresults.nix−17 nix/testserver.nix−9 overrides-ghc.nix+18 overrides.nix+14 servant-reflex.cabal+19−36 shell.nix−1 src/Servant/Common/BaseUrl.hs+8−8 src/Servant/Common/Req.hs+131−204 src/Servant/Reflex.hs+107−216 src/Servant/Reflex/Multi.hs+127−195 stack.yaml−56 testdriver/test/Servant/ReflexSpec.hs+1−2 testserver/API.hs+1−69 testserver/Main.hs+14−39 testserver/run-wd-tests.sh+5 testserver/testserver.cabal+16−17 testserver/tr.nix+32 travis.nix−70
.gitignore−3
@@ -6,6 +6,3 @@ log
66*.webapp
77*.stats
88out
9−/.stack-work/
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+58−12
@@ -1,17 +1,63 @@
1−language: nix
2−nix: 2.3.6
3−sudo: require
1+sudo: required
2+
3+before_cache:
4+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
5+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
6+
7+addons:
8+ apt:
9+ - phantomjs
10+
11+matrix:
12+ include:
13+ - env: CABALVER=1.24 GHCVER=7.10.3
14+ compiler: ": #GHC 7.10.3"
15+ addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3], sources: [hvr-ghc]}}
16+ - env: CABALVER=1.24 GHCVER=8.0.1
17+ compiler: ": #GHC 8.0.1"
18+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
19+
20+
421
522before_install:
6− - sudo cp -rT $TRAVIS_BUILD_DIR/nix /etc/nix
23+ - openssl aes-256-cbc -K $encrypted_3c89d919c82e_key -iv $encrypted_3c89d919c82e_iv -in deploy_key.enc -out deploy_key -d
24+ - unset CC
25+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
26+ - git submodule update --init --recursive
727
8−before_script:
9− - sudo systemctl restart nix-daemon.service
10− - git config --global user.email "travis-ci@example.com"
11− - git config --global user.name "Travis-CI"
28+install:
29+ - cabal --version
30+ - BENCH=${BENCH---enable-benchmarks}
31+ - TEST=${TEST---enable-tests}
32+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
33+ - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
34+ then
35+ zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
36+ $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
37+ fi
38+ - travis_retry cabal update -v
39+ - git clone https://github.com/reflex-frp/reflex-platform
40+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
41+ - reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal configure && cabal build"
42+ - reflex-platform/work-on ghc ./testdriver --command "cd testdriver && cabal configure && cabal build"
43+ - cd testserver && dist/build/back/back -p 8000 &
44+ - sleep 3
45+ - phantomjs --webdriver=127.0.0.1:4444 &
46+ - sleep 3
1247
1348script:
14− - nix-build travis.nix -A build
15− - nix-build travis.nix -A buildGhc
16− - nix-build travis.nix -A testserver
17− - nix-build travis.nix -A testresults
49+ - git config --global user.email "travis-ci@example.com"
50+ - git config --global user.name "Travis-CI"
51+ - ./build.sh
52+ - testdriver/dist/build/spec/spec
53+
54+cache:
55+ directories:
56+ - /nix
57+ - $HOME/.cabal/packages
58+ - $HOME/.cabal/store
59+
60+env:
61+ global:
62+ - ENCRYPTION_LABEL: "3c89d919c82e"
63+ - COMMIT_AUTHOR_EMAIL: "imalsogreg@gmail.com"
ChangeLog.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 @@
22
33[![Build Status](https://travis-ci.org/imalsogreg/servant-reflex.svg?branch=master)](https://travis-ci.org/imalsogreg/servant-reflex)
44
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.
69
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.
1410
1511
1612## Example
1713
18−We have a webservice API defined in a module where both the server (compiled
19−with ghc) and the frontend (compiled with ghcjs) can see it:
14+We have a webservice API defined in a module where both the server (compiled with ghc) and the frontend (compiled with ghcjs) can see it:
2015
2116```haskell
2217type API = "getint" :> Get '[JSON] Int
@@ -29,8 +24,7 @@ type API = "getint" :> Get '[JSON] Int
2924 :<|> Raw
3025```
3126
32−`servant-reflex` then computes client functions that can query the API through
33−an `XhrRequest`.
27+`servant-reflex` then computes client functions that can query the API through an `XhrRequest`.
3428
3529```haskell
3630
@@ -39,26 +33,16 @@ an `XhrRequest`.
3933 -- servant-reflex computes FRP functions for each API endpoint
4034 let (getint :<|> sayhi :<|> doubleit :<|> _) = client (Proxy :: Proxy API)
4135 (Proxy :: Proxy m)
42− (Proxy :: Proxy ())
4336 (constDyn (BasePath "/"))
4437```
4538
46−These client functions are computed from your API type. They manage
47−serialization, `XhrRequest` generation, and deserialization for you. `a`
48−parameters used in URL captures become `Dynamic t (Either Text a)` parameters
49−in the client functions. `QueryFlag`, `QueryParams` and `QueryParam` API
50−parameters map to `Dynamic t Bool`, `Dynamic t [a]` and `Dynamic t (QParam a)`
51−respectively. These parameters to the client function are wrapped with failure
52−possibility to allow you to indicate at any time whether input validation for
53−that parameter has failed and no valid XHR request can be generated. The final
54−parameter is a trigger event for the XHR request. The return value
55−`Event t (ReqResult a)` contains responses from the API server.
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.
5640
5741```haskell
5842 -- No need to write these functions. servant-reflex creates them for you!
5943 getint :: MonadWidget t m
6044 => Event t () -- ^ Trigger the XHR Request
61− -> m (Event t (ReqResult () Int)) -- ^ Consume the answer
45+ -> m (Event t (ReqResult Int)) -- ^ Consume the answer
6246
6347 sayhi :: MonadWidget t m
6448 => Dynamic t (QParam Text)
@@ -69,21 +53,15 @@ parameter is a trigger event for the XHR request. The return value
6953 -- ^ Flag for capitalizing the response
7054 -> Event t ()
7155 -- ^ Trigger the XHR Request
72− -> m (Event t (ReqResult () Text))
56+ -> m (Event t (ReqResult Text))
7357
7458 doubleit :: MonadWidget t m
7559 => Dynamic t (Either Text Double)
7660 -> Event t ()
77− -> m (Event t (ReqResult () Double))
61+ -> m (Event t (ReqResult Double))
7862```
7963
80−`ReqResult tag a` is defined in
81−[`Servant.Common.Req`](https://github.com/imalsogreg/servant-reflex/blob/6d866e338edb9bf6fd8f8d5083ff0187b4d8c0d2/src/Servant/Common/Req.hs#L40-L42)
82−and reports whether or not your request was sent (if validation fails, the
83−request won't be sent), and how decoding of the response went. You can pattern
84−match on these explicitly, but usually you'll want to use
85−`fmapMaybe :: (a -> Maybe b) -> Event t a -> Event t b` and one of the
86−elimination functions to filter the result type you care about, like this:
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:
8765
8866```haskell
8967 -- ... continued ...
@@ -101,8 +79,7 @@ elimination functions to filter the result type you care about, like this:
10179 dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])
10280```
10381
104−This example builds some input fields to enter API parameters, buttons to
105−trigger the API calls, and text elements to show the results:
82+This example builds some input fields to enter API parameters, buttons to trigger the API calls, and text elements to show the results:
10683
10784```haskell
10885 elClass "div" "int-demo" $ do
@@ -125,100 +102,37 @@ trigger the API calls, and text elements to show the results:
125102 display =<< holdDyn Nothing outputDouble
126103```
127104
128−For a great introduction to recative DOM building, see the
129−[README](https://github.com/reflex-frp/reflex-platform) for the
130−`reflex-platform`. For more information about servant, see their
131−[documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to
132−the respective authors of these fabulous libraries.
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.
133106
134107
135108## Building the library and test server
136109
137−This repository comes with a small example of an API shared between a
138−ghcjs-compiled frontend
139−([exec/](https://github.com/imalsogreg/servant-reflex/tree/master/exec)) and a
140−ghc-compiled backend
141−([testserver/](https://github.com/imalsogreg/servant-reflex/tree/master/testserver).
142−To build these components, we will use the nix packages for the testserver. It
143−manages the frontend build as a dependency.
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:
144111
145−```
146−nix build -f travis.nix testserver -o server
147−```
148112
149−Point it at the static directory and run it:
113+First build the library:
150114
151115```
152−STATIC_DIR=server/static server/back -p 8000
116+git submodule update --init --recursive
117+./build.sh
153118```
154119
155−Browse to [http://localhost:8000](http://localhost:8000) and click around.
156−Open the firefox or chrome developer tools and examine the XHR activity
157−under the Network tab.
158−
159−**For a larger example of a project that shares types between backend and
160−frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
120+Then build the test server:
161121
122+```
123+deps/reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal build"
124+```
162125
163−## Tagging requests
164126
165−The input and the return type of a client function like `getDouble` are both
166−event streams. The individual input events and responses occur at different
167−times and aren't automatically paired up, but you can recover the
168−relationship by tagging the requests.
127+## Running the example site
169128
170−So far we have used an `Event t ()` to trigger sending a request. If we choose
171−e.g. `Double` for the third `Proxy` argument to `client`, then `Event t Double`
172−will be used to trigger requests, and each `ReqResult` will carry the tag of
173−its request. Imagine we wanted to display not just the last "double" from
174−`doubleIt`, but a whole table of valid inputs and their doubled responses:
129+The server must be run from the directory where static assets live:
175130
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− ...
200131```
201−
202−## Simultaneous requests
203−
204−`Servant.Reflex.Multi` provides an alternative client-generation function
205−called `clientA` (client applicative). Choose a container type that has both
206−`Applicative` and `Traversable` instances, and pass it to `clientA` through
207−another `Proxy`. Our `sayHi` client function will then have this type:
208−
209−```haskell
210−sayHi
211− :: Dynamic t (f (QParam Text))
212− -> Dynamic t (f [Text])
213− -> Dynamic t (f Bool)
214− -> Event t tag
215− -> m (Event t (f (ReqResult tag Text)))
132+cd testserver
133+dist/build/back/back -p 8001
216134```
217135
218−The dynamic params are each wrapped in `f`. For every firing of the trigger
219−event `tag`, all of these parameters will be combined according to `f`'s
220−`Applicative` instance (when `f` is `[]`, you will get all combinations of
221−all parameters taken together as a request; when `f` is `ZipList`, the Nth
222−elemens of each parameters list will be taken together as a request). Using
223−this interface, you can trigger many XHR's from a single event occurence, and
224−expect the responses to be structured the same way as the requests.
136+And simply browse to `localhost:8001`
137+
138+**For a larger example of a project that shares types between backend and frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
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+4−29
@@ -1,32 +1,10 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TypeOperators #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE TypeOperators #-}
43
54module API where
65
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−
6+import Data.Text (Text)
7+import Servant.API
308
319-- | API spec for server, client, and docs
3210type API = "getunit" :> Get '[JSON] ()
@@ -38,9 +16,6 @@ type API = "getunit" :> Get '[JSON] ()
3816 :<|> "double" :> ReqBody '[JSON] Double
3917 :> Post '[JSON] Double
4018 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
41− :<|> "qna" :> ReqBody '[JSON] Question
42− :> Post '[JSON] Answer
43− :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
4419 :<|> Raw
4520
4621type GET = Get '[JSON] ()
exec/Example.hs+19−69
@@ -1,4 +1,3 @@
1−{-# LANGUAGE DataKinds #-}
21{-# LANGUAGE FlexibleContexts #-}
32{-# LANGUAGE GADTs #-}
43{-# LANGUAGE OverloadedStrings #-}
@@ -15,14 +14,11 @@ import Control.Monad.Fix (MonadFix)
1514import Data.Monoid (First(..), (<>))
1615import Data.Text (Text)
1716import qualified Data.Text as T
18−import qualified Data.Text.Encoding as T
19−import GHC.TypeLits
2017import Servant.API
2118import API
2219import Data.Proxy
2320import Text.Read (readMaybe)
24−import Reflex.Dom.Core hiding (run, mainWidget)
25−import Reflex.Dom (mainWidget)
21+import Reflex.Dom
2622------------------------------------------------------------------------------
2723import Servant.Reflex
2824import Servant.Reflex.Multi
@@ -46,36 +42,18 @@ runMulti :: forall t m. (SupportsServantReflex t m,
4642runMulti = do
4743 url <- baseUrlWidget
4844 el "br" blank
49− let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =
45+ let (_ :<|> _ :<|> _ :<|> dbl :<|> _ :<|> _ ) =
5046 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
51−
5247 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
5348 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
5551 b <- button "Run dbl multi"
56− reqCount :: Dynamic t Int <- count b
57− r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)
58− dynText =<< holdDyn "Waiting" (T.pack . show . fmap reqSuccess <$> r)
59−
60− lastInd <- holdDyn [] $ fmap reqTag <$> r
52+ reqCount <- count b
53+ r <- dbl [num,num2] (tag (current reqCount) b)
54+ dynText =<< holdDyn "Waiting" (T.pack . show . fmapMaybe reqSuccess .snd <$> r)
55+ lastInd <- holdDyn Nothing (Just . fst <$> r)
6156 display lastInd
62−
63− divClass "demo-group" $ do
64− nms <- fmap (fmap T.words . value) $ divClass "" $ do
65− text "Names"
66− textInput def
67− grts <- fmap (fmap T.words . value) $ divClass "" $ do
68− text "Greetings"
69− textInput def
70− gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
71− b <- button "Go"
72− r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)
73− (constDyn [True, False]) (1 <$ b)
74−
75− dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .
76− fmap reqSuccess <$> r')
77−
78−
7957 return ()
8058
8159run :: forall t m. (SupportsServantReflex t m,
@@ -97,26 +75,21 @@ run = mdo
9775 el "br" (return ())
9876
9977 -- Name the computed API client functions
100− let tweakRequest = ClientOptions $ \r -> do
101− return $ r & withCredentials .~ True
102− let (getUnit :<|> getInt :<|> sayhi :<|> dbl
103− :<|> multi :<|> qna :<|> secret :<|> doRaw) =
104− clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest
105−
106− c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
78+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> doRaw) =
79+ client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url
10780
10881 (unitBtn, intBtn) <- elClass "div" "demo-group" $ do
10982 unitBtn <- divClass "unit-button" $ button "Get unit"
11083 intBtn <- divClass "int-button" $ button "Get int"
11184
11285 unitResponse <- getUnit $ tag (current reqCount) unitBtn
113− intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn
86+ intResponse :: Event t (Int, ReqResult Int) <- getInt $ tag (current reqCount) intBtn
11487
115− score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))
88+ score <- foldDyn (+) 0 (fmapMaybe reqSuccess (snd <$> intResponse))
11689
11790 r <- holdDyn "Waiting" $ fmap showXhrResponse $
118− leftmost [fmapMaybe response (unitResponse)
119− ,fmapMaybe response (intResponse)
91+ leftmost [fmapMaybe response (snd <$> unitResponse)
92+ ,fmapMaybe response (snd <$> intResponse)
12093 ]
12194 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score
12295 return (unitBtn, intBtn)
@@ -144,8 +117,8 @@ run = mdo
144117
145118 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)
146119 divClass "greeting-response" $ dynText =<<
147− holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)
148− , fmapMaybe reqFailure (resp)])
120+ holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (snd <$> resp)
121+ , fmapMaybe reqFailure (snd <$> resp)])
149122 return sayHiClicks
150123
151124 dblBtn <- elClass "div" "demo-group" $ do
@@ -156,11 +129,11 @@ run = mdo
156129 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
157130 dblinp) (tag (current reqCount) dblBtn)
158131 divClass "double-errors" $ dynText =<<
159− holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))
132+ holdDyn "(no errors)" (fmapMaybe reqFailure (snd <$> dblResp))
160133 el "br" (return ())
161134 divClass "double-result" $ el "p" $ dynText =<<
162135 holdDyn "No number yet" (fmap tShow $
163− fmapMaybe reqSuccess (dblResp))
136+ fmapMaybe reqSuccess (snd <$> dblResp))
164137 return dblBtn
165138
166139 mpGo <- elClass "div" "demo-group" $ do
@@ -170,34 +143,11 @@ run = mdo
170143 multiResp <- multi b (tag (current reqCount) mpGo)
171144 dynText =<< holdDyn "No res yet" (fmap tShow $
172145 fmapMaybe reqSuccess $
173− (multiResp))
146+ (snd <$> multiResp))
174147 return mpGo
175148
176149 return ()
177150
178− el "br" $ return ()
179−
180− elClass "div" "demo-group" $ do
181− text "JSON Unicode encoding test"
182− txt <- value <$> textInput def
183− ev <- fmap (1 <$) $ button "Question"
184− let dQ = Right . Question <$> traceDyn "will send: " txt
185− rr <- qna dQ ev
186− el "p" $
187− dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
188−
189− divClass "demo-group" $ do
190− un <- fmap value $ text "Username" >> textArea def
191− pw <- fmap value $ text "Unhidden PW" >> textArea def
192− let ba :: Dynamic t (BasicAuthData ) = BasicAuthData
193− <$> fmap T.encodeUtf8 un
194− <*> fmap T.encodeUtf8 pw
195− b <- button "Get secret"
196− r <- secret (Just <$> ba) (0 <$ b)
197− res <- holdDyn Nothing (reqSuccess <$> r)
198− display res
199−
200−
201151showXhrResponse :: XhrResponse -> Text
202152showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
203153 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+18
@@ -0,0 +1,18 @@
1+{ reflex-platform, ... }:
2+let
3+ pkgs = import <nixpkgs> {};
4+ c2n = reflex-platform.cabal2nixResult;
5+in reflex-platform.ghc.override {
6+ overrides = self: super: {
7+ servant-snap = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap) {});
8+ snap = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap) {});
9+ snap-server = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-server) {});
10+ io-streams = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams) {});
11+ io-streams-haproxy = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});
12+ heist = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});
13+ xmlhtml = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
14+ snap-core = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-core) {});
15+ servant = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant/servant) {});
16+ http-api-data = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/http-api-data) {});
17+ };
18+}
overrides.nixnew file+14
@@ -0,0 +1,14 @@
1+{ reflex-platform, ... }:
2+let
3+
4+ nixpkgs = (import <nixpkgs> {});
5+ dontCheck = nixpkgs.pkgs.haskell.lib.dontCheck;
6+ cabal2nixResult = reflex-platform.cabal2nixResult;
7+
8+in
9+reflex-platform.ghcjs.override {
10+ overrides = self: super: {
11+ servant = dontCheck (self.callPackage (cabal2nixResult deps/servant/servant) {});
12+ http-api-data = dontCheck (self.callPackage (cabal2nixResult deps/http-api-data) {});
13+ };
14+}
servant-reflex.cabal+19−36
@@ -1,8 +1,8 @@
11Name: servant-reflex
2−Version: 0.3.6
3−Synopsis: servant API generator for reflex apps
4−Description: Generate reflex-compatible client functions from servant API descriptions
5−License: BSD3
2+Version: 0.3
3+Synopsis: Servant reflex API generator
4+Description: Servant reflex API generator
5+License: AllRightsReserved
66License-file: LICENSE.md
77Author: Greg Hale, Doug Beardsley
88Maintainer: imalsogreg@gmail.com
@@ -11,59 +11,42 @@ Category: Web
1111Build-type: Simple
1212Cabal-version: >=1.10
1313
14−Flag Example
15− description: Enable example
16− default: False
17−
1814library
1915 exposed-modules:
20− Servant.Common.BaseUrl
21− Servant.Common.Req
2216 Servant.Reflex
2317 Servant.Reflex.Multi
2418
19+ other-modules:
20+ Servant.Common.BaseUrl
21+ Servant.Common.Req
22+
2523 hs-source-dirs: src
2624 build-depends:
27− base >= 4.8 && < 5,
25+ base >= 4.8 && < 4.10,
2826 bytestring >= 0.10 && < 0.11,
2927 case-insensitive >= 1.2.0.4 && < 1.3,
30− containers >= 0.5.6 && < 0.7,
28+ containers >= 0.5.6 && < 0.6,
3129 data-default >= 0.5 && < 0.8,
32− exceptions >= 0.8 && < 0.11,
33− ghcjs-dom >= 0.2 && < 0.10,
34− http-api-data >= 0.3.6 && < 0.5,
35− http-media >= 0.6 && < 0.9,
36− jsaddle >= 0.8 && < 0.10,
30+ exceptions >= 0.8 && < 0.9,
31+ ghcjs-dom >= 0.2 && < 0.3,
32+ http-api-data >= 0.2 && < 0.4,
33+ http-media >= 0.6 && < 0.7,
3734 mtl >= 2.2.1 && < 2.3,
3835 network-uri >= 2.6 && < 2.7,
39− reflex >= 0.5 && < 0.9,
40− reflex-dom-core >= 0.6 && < 0.7,
36+ reflex >= 0.5 && < 0.6,
37+ reflex-dom == 0.4 && < 0.5,
4138 safe >= 0.3.9 && < 0.4,
42− servant >= 0.16 && < 0.18,
43− servant-auth >= 0.2.1 && < 0.4,
39+ servant >= 0.5 && < 0.9,
4440 string-conversions >= 0.4 && < 0.5,
4541 text >= 1.2 && < 1.3,
4642 transformers >= 0.4 && < 0.6
4743
48− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
44+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
4945
5046 default-language: Haskell2010
5147
5248executable example
53− if flag(Example)
54− buildable: True
55− else
56− buildable: False
57− build-depends:
58− aeson,
59− reflex,
60− servant-reflex,
61− base,
62− scientific,
63− servant,
64− reflex-dom,
65− reflex-dom-core,
66− text
49+ build-depends: reflex, servant-reflex, base, scientific, servant, reflex-dom, text
6750 default-language: Haskell2010
6851 main-is: Example.hs
6952 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 (
2020) where
2121
2222import Control.Monad (join)
23−-- import Control.Monad.IO.Class (MonadIO)
23+import Control.Monad.IO.Class (MonadIO)
2424import Control.Monad.Fix (MonadFix)
2525import Data.Monoid ((<>))
2626import Data.Text (Text)
2727import qualified Data.Text as T
2828import GHC.Generics
29−import Language.Javascript.JSaddle.Monad (MonadJSM)
3029import Reflex
31−import Reflex.Dom.Core
30+import Reflex.Dom
3231import Text.Read
3332
3433
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))
3635
3736-- | URI scheme to use
3837data Scheme =
@@ -85,14 +84,15 @@ baseUrlWidget = elClass "div" "base-url" $ do
8584 where pathWidget :: m (Dynamic t BaseUrl)
8685 pathWidget = do
8786 text "Url base path"
88− t <- inputElement def
87+ t <- textInput (def {_textInputConfig_attributes =
88+ constDyn ("placeholder" =: "/a/b")})
8989 return $ BasePath <$> value t
9090 fullUrlWidget :: m (Dynamic t BaseUrl)
9191 fullUrlWidget = do
9292 schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def
93− srv <- inputElement def
93+ srv <- textInput def {_textInputConfig_attributes = constDyn $ "placeholder" =: "example.com"}
9494 text ":"
95− prt <- inputElement def
95+ prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}
9696 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" }
9898 return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path
src/Servant/Common/Req.hs+131−204
@@ -1,119 +1,63 @@
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
13{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveFunctor #-}
34{-# LANGUAGE FlexibleContexts #-}
45{-# LANGUAGE GADTs #-}
56{-# LANGUAGE OverloadedStrings #-}
67{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE RankNTypes #-}
88{-# LANGUAGE ScopedTypeVariables #-}
99{-# LANGUAGE TupleSections #-}
1010
11+{-# LANGUAGE EmptyCase #-}
1112module Servant.Common.Req where
1213
1314-------------------------------------------------------------------------------
14−import Control.Applicative (liftA2, liftA3)
15−import Control.Arrow ((&&&))
1615import Control.Concurrent
17−import Control.Monad (join)
16+import Control.Applicative (liftA2, liftA3)
17+import Control.Arrow (second)
1818import Control.Monad.IO.Class (MonadIO, liftIO)
19−import Data.Bifunctor (first)
20−import qualified Data.ByteString.Builder as Builder
2119import qualified Data.ByteString.Lazy.Char8 as BL
22−import Data.ByteString (ByteString)
2320import qualified Data.Map as Map
24−import Data.Maybe (catMaybes, fromMaybe)
21+import Data.Maybe (catMaybes)
2522import Data.Functor.Compose
2623import Data.Monoid ((<>))
2724import Data.Proxy (Proxy(..))
2825import Data.Text (Text)
2926import qualified Data.Text as T
3027import qualified Data.Text.Encoding as TE
31−import Data.Traversable (forM)
32−import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
33−import qualified Network.URI as N
34−import Reflex.Dom.Core hiding (tag)
35−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
36− SupportsServantReflex)
28+import Data.Traversable
29+import Reflex.Dom
30+import Servant.Common.BaseUrl (BaseUrl, showBaseUrl, SupportsServantReflex)
3731import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
3832import Web.HttpApiData (ToHttpApiData(..))
3933-------------------------------------------------------------------------------
4034import Servant.API.BasicAuth
4135
4236
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'
7237
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
79−reqSuccess _ = Nothing
38+data ReqResult a = ResponseSuccess a XhrResponse
39+ | ResponseFailure Text XhrResponse
40+ | RequestFailure Text
8041
42+instance Functor ReqResult where
43+ fmap f (ResponseSuccess a xhr) = ResponseSuccess (f a) xhr
44+ fmap _ (ResponseFailure r x) = ResponseFailure r x
45+ fmap _ (RequestFailure r) = RequestFailure r
8146
82−------------------------------------------------------------------------------
83−-- | Simple filter/accessor like 'reqSuccess', but keeping the request tag
84−reqSuccess' :: ReqResult tag a -> Maybe (tag,a)
85−reqSuccess' (ResponseSuccess tag x _) = Just (tag,x)
86−reqSuccess' _ = Nothing
47+reqSuccess :: ReqResult a -> Maybe a
48+reqSuccess (ResponseSuccess x _) = Just x
49+reqSuccess _ = Nothing
8750
51+reqFailure :: ReqResult a -> Maybe Text
52+reqFailure (ResponseFailure s _) = Just s
53+reqFailure (RequestFailure s) = Just s
54+reqFailure _ = Nothing
8855
89−------------------------------------------------------------------------------
90−-- | Simple filter/accessor for any failure case
91−reqFailure :: ReqResult tag a -> Maybe Text
92−reqFailure (ResponseFailure _ s _) = Just s
93−reqFailure (RequestFailure _ s) = Just s
94−reqFailure _ = Nothing
95−
96−------------------------------------------------------------------------------
97−-- | Simple filter/accessor like 'reqFailure', but keeping the request tag
98−reqFailure' :: ReqResult tag a -> Maybe (tag,Text)
99−reqFailure' (ResponseFailure tag s _) = Just (tag,s)
100−reqFailure' (RequestFailure tag s) = Just (tag,s)
101−reqFailure' _ = Nothing
102−
103−
104−------------------------------------------------------------------------------
105−-- | Simple filter/accessor for the raw XHR response
106−response :: ReqResult tag a -> Maybe XhrResponse
107−response (ResponseSuccess _ _ x) = Just x
108−response (ResponseFailure _ _ x) = Just x
109−response _ = Nothing
56+response :: ReqResult a -> Maybe XhrResponse
57+response (ResponseSuccess _ x) = Just x
58+response (ResponseFailure _ x) = Just x
59+response _ = Nothing
11060
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
11761
11862-------------------------------------------------------------------------------
11963-- | You must wrap the parameter of a QueryParam endpoint with 'QParam' to
@@ -126,13 +70,11 @@ data QParam a = QParamSome a
12670 | QParamInvalid Text
12771 -- ^ Indication that your validation failed (the request isn't valid)
12872
129−
13073qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)
13174qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)
13275qParamToQueryPart QNone = Right Nothing
13376qParamToQueryPart (QParamInvalid e) = Left e
13477
135−
13678data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
13779 | QueryPartParams (Dynamic t [Text])
13880 | QueryPartFlag (Dynamic t Bool)
@@ -165,10 +107,10 @@ addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . t
165107reqToReflexRequest
166108 :: forall t. Reflex t
167109 => Text
168− -> Dynamic t BaseUrl
169110 -> Req t
170− -> Dynamic t (Either Text (XhrRequest XhrPayload))
171−reqToReflexRequest reqMeth reqHost req =
111+ -> Dynamic t BaseUrl
112+ -> (Dynamic t (Either Text (XhrRequest XhrPayload)))
113+reqToReflexRequest reqMeth req reqHost =
172114 let t :: Dynamic t [Either Text Text]
173115 t = sequence $ reverse $ reqPathParts req
174116
@@ -179,22 +121,18 @@ reqToReflexRequest reqMeth reqHost req =
179121 urlParts = fmap sequence t
180122
181123 urlPath :: Dynamic t (Either Text Text)
182− urlPath = (fmap.fmap)
183− (T.intercalate "/" . fmap escape)
184− urlParts
124+ urlPath = (fmap.fmap) (T.intercalate "/") urlParts
185125
186126 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
187127 queryPartString (pName, qp) = case qp of
188128 QueryPartParam p -> ffor p $ \case
189129 Left e -> Just (Left e)
190− Right (Just a) -> Just (Right $ pName <> "=" <> escape a)
130+ Right (Just a) -> Just (Right $ pName <> "=" <> a)
191131 Right Nothing -> Nothing
192132 QueryPartParams ps -> ffor ps $ \pStrings ->
193133 if null pStrings
194134 then Nothing
195− else Just . Right
196− . T.intercalate "&"
197− $ fmap (\p -> pName <> "=" <> escape p) pStrings
135+ else Just $ Right (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) pStrings))
198136 QueryPartFlag fl -> ffor fl $ \case
199137 True -> Just $ Right pName
200138 False -> Nothing
@@ -229,10 +167,10 @@ reqToReflexRequest reqMeth reqHost req =
229167 Right $ XhrRequestConfig
230168 { _xhrRequestConfig_sendData = bytesToPayload bBytes
231169 , _xhrRequestConfig_headers =
232− Map.insert "Content-Type" bCT (Map.fromList hs)
170+ Map.insert "Content-Type" bCT (Map.fromList hs)
233171 , _xhrRequestConfig_user = Nothing
234172 , _xhrRequestConfig_password = Nothing
235− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
173+ , _xhrRequestConfig_responseType = Nothing
236174 , _xhrRequestConfig_withCredentials = False
237175 , _xhrRequestConfig_responseHeaders = def
238176 }
@@ -244,8 +182,8 @@ reqToReflexRequest reqMeth reqHost req =
244182 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
245183 , _xhrRequestConfig_user = Nothing
246184 , _xhrRequestConfig_password = Nothing
247− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
248− , _xhrRequestConfig_sendData = mempty
185+ , _xhrRequestConfig_responseType = Nothing
186+ , _xhrRequestConfig_sendData = ""
249187 , _xhrRequestConfig_withCredentials = False
250188 }
251189 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
@@ -272,55 +210,40 @@ reqToReflexRequest reqMeth reqHost req =
272210displayHttpRequest :: Text -> Text
273211displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
274212
275−-- | This function performs the request
213+-- | This function actually performs the request.
276214performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
277215 => Text
278− -> Dynamic t (f (Req t))
216+ -> f (Req t)
279217 -> Dynamic t BaseUrl
280− -> ClientOptions
281218 -> Event t tag
282219 -> m (Event t (tag, f (Either Text XhrResponse)))
283−performRequests reqMeth rs reqHost opts trigger = do
284− let xhrReqs =
285− join $ (\(fxhr :: f (Req t)) -> sequence $
286− reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
287−
288− -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
289− reqs = attachPromptlyDynWith
290− (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
291−
292− resps <- performSomeRequestsAsync opts reqs
220+performRequests reqMeth rs reqHost trigger = do
221+ let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))
222+ let reqs = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
223+ resps <- performSomeRequestsAsync reqs
293224 return $ getCompose <$> resps
294225
295−-- | Issues a collection of requests when the supplied Event fires.
296−-- When ALL requests from a given firing complete, the results are
297−-- collected and returned via the return Event.
226+-- | 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.
298227performSomeRequestsAsync
299228 :: (MonadIO (Performable m),
300− MonadJSM (Performable m),
301229 HasWebView (Performable m),
302230 PerformEvent t m,
303231 TriggerEvent t m,
304232 Traversable f,
305− IsXhrPayload a,
306− Show a
307− )
308− => ClientOptions
309− -> Event t (f (Either Text (XhrRequest a)))
233+ IsXhrPayload a)
234+ => Event t (f (Either Text (XhrRequest a)))
310235 -> m (Event t (f (Either Text XhrResponse)))
311−performSomeRequestsAsync opts =
312− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
236+performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return
313237
314238
315239------------------------------------------------------------------------------
316240-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
317241-- that accepts 'f (Either e (XhrRequestb))' events
318242performSomeRequestsAsync'
319− :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
320− => ClientOptions
321− -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
243+ :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
244+ => (XhrRequest b -> (a -> IO ()) -> Performable m XMLHttpRequest)
322245 -> 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
246+performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
324247 rs <- hrs
325248 resps <- forM rs $ \r -> case r of
326249 Left e -> do
@@ -328,92 +251,103 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs
328251 return resp
329252 Right r' -> do
330253 resp <- liftIO newEmptyMVar
331− r'' <- liftJSM $ (optsRequestFixup opts) r'
332− _ <- newXhr r'' $ liftIO . putMVar resp . Right
254+ _ <- newXhr r' $ liftIO . putMVar resp . Right
333255 return resp
334256 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
335257 return ()
336258
337259
338260
339−type XhrPayload = ByteString
340−bytesToPayload :: BL.ByteString -> XhrPayload
341−bytesToPayload = BL.toStrict
261+-- | This function actually performs the request.
262+performRequest :: forall t m tag .(SupportsServantReflex t m)
263+ => Text
264+ -> (Req t)
265+ -> Dynamic t BaseUrl
266+ -> Event t tag
267+ -> m (Event t (tag, XhrResponse), Event t (tag, Text))
268+performRequest reqMeth req reqHost trigger = do
342269
270+ let xhrReq = reqToReflexRequest reqMeth req reqHost
271+ let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger
272+ okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) e) reqs
273+ badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) e) reqs
343274
344−performRequestsCT
275+ resps <- performRequestsAsync okReqs
276+
277+ return (resps, badReqs)
278+
279+
280+#ifdef ghcjs_HOST_OS
281+type XhrPayload = String
282+bytesToPayload :: BL.ByteString -> XhrPayload
283+bytesToPayload = BL.unpack
284+#else
285+type XhrPayload = T.Text
286+bytesToPayload :: BL.ByteString -> XhrPayload
287+bytesToPayload = T.pack . BL.unpack
288+#endif
289+
290+performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)
291+ => Text
292+ -> Req t
293+ -> Dynamic t BaseUrl
294+ -> Event t tag -> m (Event t (tag, ReqResult NoContent))
295+performRequestNoBody reqMeth req reqHost trigger = do
296+ (resp, badReq) <- performRequest reqMeth req reqHost trigger
297+ return $ leftmost [ fmap (ResponseSuccess NoContent) <$> resp, fmap RequestFailure <$> badReq]
298+
299+performRequestsNoBody :: forall t m f tag. (SupportsServantReflex t m, Traversable f)
300+ => Text
301+ -> f (Req t)
302+ -> Dynamic t BaseUrl
303+ -> Event t tag -> m (Event t (tag, f (ReqResult NoContent)))
304+performRequestsNoBody reqMeth reqs reqHost trigger = do
305+ resp <- performRequests reqMeth reqs reqHost trigger
306+ return $ (fmap . fmap) aux <$> resp
307+ where
308+ aux (Right x) = ResponseSuccess NoContent x
309+ aux (Left e) = RequestFailure e
310+ -- return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]
311+
312+
313+performRequestCT
345314 :: (SupportsServantReflex t m,
346− MimeUnrender ct a, Traversable f)
315+ MimeUnrender ct a)
347316 => Proxy ct
348317 -> Text
349− -> Dynamic t (f (Req t))
318+ -> Req t
350319 -> Dynamic t BaseUrl
351− -> ClientOptions
352320 -> Event t tag
353− -> m (Event t (f (ReqResult tag a)))
354−performRequestsCT ct reqMeth reqs reqHost opts trigger = do
355− resps <- performRequests reqMeth reqs reqHost opts trigger
356− let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
357− first T.pack .
358− mimeUnrender ct $
359− BL.fromStrict x
360− decodeResp _ = Left "No body"
361− return $ fmap
362− (\(t,rs) -> ffor rs $ \r -> case r of
363− Left e -> RequestFailure t e
364− Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
365− )
366− resps
367−
368−
369−performRequestsNoBody
321+ -> m (Event t (tag, ReqResult a))
322+performRequestCT ct reqMeth req reqHost trigger = do
323+ (resp, badReq) <- performRequest reqMeth req reqHost trigger
324+ let decodes = ffor resp $ fmap (\xhr ->
325+ ((mimeUnrender ct . BL.fromStrict . TE.encodeUtf8)
326+ =<< note "No body text" (_xhrResponse_responseText xhr), xhr))
327+ reqs = ffor decodes $ fmap (\case
328+ (Right a, r) -> ResponseSuccess a r
329+ (Left e, r) -> ResponseFailure (T.pack e) r)
330+ return $ leftmost [reqs, fmap RequestFailure <$> badReq]
331+
332+performRequestsCT
370333 :: (SupportsServantReflex t m,
371− Traversable f)
372− => Text
373− -> Dynamic t (f (Req t))
334+ MimeUnrender ct a, Traversable f)
335+ => Proxy ct
336+ -> Text
337+ -> f (Req t)
374338 -> Dynamic t BaseUrl
375− -> ClientOptions
376339 -> Event t tag
377− -> m (Event t (f (ReqResult tag NoContent)))
378−performRequestsNoBody reqMeth reqs reqHost opts trigger = do
379− resps <- performRequests reqMeth reqs reqHost opts trigger
380− let decodeResp = const $ Right NoContent
381− return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
382− Left e -> RequestFailure tag e
383− Right g -> evalResponse decodeResp (tag,g)
384−
385−
386−------------------------------------------------------------------------------
387−evalResponse
388− :: (XhrResponse -> Either Text a)
389− -> (tag, XhrResponse)
390− -> ReqResult tag a
391−evalResponse decode (tag, xhr) =
392− let status = _xhrResponse_status xhr
393− okStatus = status >= 200 && status < 400
394− errMsg = fromMaybe
395− ("Empty response with error code " <>
396− T.pack (show $ _xhrResponse_status xhr))
397− (_xhrResponse_responseText xhr)
398− respPayld = if okStatus
399− then either
400− (\e -> ResponseFailure tag e xhr)
401− (\v -> ResponseSuccess tag v xhr)
402− (decode xhr)
403− else ResponseFailure tag errMsg xhr
404− in respPayld
405−
406−------------------------------------------------------------------------------
407−-- | Utility for simultaneously accessing/filtering Success and Failure
408−-- response 'Event's,
409−fanReqResult :: Reflex t => Event t (ReqResult tag a) -> (Event t Text, Event t a)
410−fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess
411−
412−------------------------------------------------------------------------------
413−-- | Utility for simultaneously accessing/filtering Success and Failure
414−-- response 'Event's, but keeping the request tag
415−fanReqResult' :: Reflex t => Event t (ReqResult tag a) -> (Event t (tag, Text), Event t (tag, a))
416−fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'
340+ -> m (Event t (tag, f (ReqResult a)))
341+performRequestsCT ct reqMeth reqs reqHost trigger = do
342+ resps <- performRequests reqMeth reqs reqHost trigger
343+ return $ fmap (second (fmap reqToResult)) resps
344+ where
345+ reqToResult (Left e) = RequestFailure e
346+ reqToResult (Right x) = case _xhrResponse_responseText x of
347+ Nothing -> ResponseFailure "No request body" x
348+ Just bod -> case mimeUnrender ct . BL.fromStrict . TE.encodeUtf8 $ bod of
349+ Left e -> ResponseFailure (T.pack e) x
350+ Right v -> ResponseSuccess v x
417351
418352
419353note :: e -> Maybe a -> Either e a
@@ -422,10 +356,3 @@ note e = maybe (Left e) Right
422356fmapL :: (e -> e') -> Either e a -> Either e' a
423357fmapL _ (Right a) = Right a
424358fmapL 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+107−216
@@ -1,23 +1,17 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE InstanceSigs #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE Rank2Types #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TupleSections #-}
14−{-# LANGUAGE TypeFamilies #-}
15−{-# LANGUAGE TypeOperators #-}
16−{-# LANGUAGE UndecidableInstances #-}
17−
18−#if MIN_VERSION_base(4,9,0)
19−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
20−#endif
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE InstanceSigs #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+{-# LANGUAGE MultiParamTypeClasses #-}
2115
2216-- #include "overlapping-compat.h"
2317-- | This module provides 'client' which can automatically generate
@@ -25,71 +19,56 @@
2519-- API.
2620module Servant.Reflex
2721 ( client
28− , clientWithOpts
29− , clientWithOptsAndResultHandler
30− , clientWithRoute
31− , clientWithRouteAndResultHandler
3222 , BuildHeaderKeysTo(..)
3323 , toHeaders
34− , HasClient
35− , Client
24+ , HasClient(..)
3625 , module Servant.Common.Req
3726 , module Servant.Common.BaseUrl
3827 ) where
3928
4029------------------------------------------------------------------------------
4130import Control.Applicative
42−import qualified Data.CaseInsensitive as CI
43−import Data.Functor.Identity
44−import qualified Data.Map as Map
4531import Data.Monoid ((<>))
46−import Data.Proxy (Proxy (..))
4732import qualified Data.Set as Set
33+import qualified Data.Text.Encoding as E
34+import Data.CaseInsensitive (mk)
35+import Data.Proxy (Proxy (..))
36+import qualified Data.Map as Map
4837import Data.Text (Text)
4938import qualified Data.Text as T
50−import qualified Data.Text.Encoding as E
51−import GHC.Exts (Constraint)
5239import GHC.TypeLits (KnownSymbol, symbolVal)
53−import Servant.API ((:<|>) (..), (:>), BasicAuth,
54− BasicAuthData, BuildHeadersTo (..),
55− Capture, Header, Headers (..),
56− HttpVersion, IsSecure,
57− MimeRender (..), MimeUnrender,
40+import Servant.API ((:<|>)(..),(:>), BasicAuth,
41+ BasicAuthData, BuildHeadersTo(..),
42+ Capture, contentType, Header,
43+ Headers(..), HttpVersion, IsSecure,
44+ MimeRender(..), MimeUnrender,
5845 NoContent, QueryFlag, QueryParam,
59− QueryParams, Raw, ReflectMethod (..),
46+ QueryParams, Raw, ReflectMethod(..),
6047 RemoteHost, ReqBody,
61− ToHttpApiData (..), Vault, Verb,
62− contentType)
63−import Servant.API.Description (Summary)
64−import qualified Servant.Auth as Auth
65−
66−import Reflex.Dom.Core (Dynamic, Event, Reflex,
67− XhrRequest (..), XhrResponse (..),
68− XhrResponseHeaders (..),
69− attachPromptlyDynWith, constDyn, ffor,
70− fmapMaybe, leftmost,
71− performRequestsAsync)
48+ ToHttpApiData(..), Vault, Verb)
49+
50+import Reflex.Dom (Dynamic, Event, Reflex,
51+ XhrRequest(..),
52+ XhrResponseHeaders(..),
53+ XhrResponse(..), attachPromptlyDynWith, ffor, fmapMaybe,
54+ leftmost, performRequestsAsync,
55+ )
7256------------------------------------------------------------------------------
7357import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
7458 showBaseUrl,
7559 SupportsServantReflex)
76−import Servant.Common.Req (ClientOptions(..),
77− defaultClientOptions,
78− Req, ReqResult(..), QParam(..),
60+import Servant.Common.Req (Req, ReqResult(..), QParam(..),
7961 QueryPart(..), addHeader, authData,
80− defReq, evalResponse, prependToPathParts,
81− -- performRequestCT,
62+ defReq, prependToPathParts,
63+ performRequestCT,
8264 performRequestsCT,
83− -- performRequestNoBody,
65+ performRequestNoBody,
8466 performRequestsNoBody,
8567 performSomeRequestsAsync,
8668 qParamToQueryPart, reqBody,
8769 reqSuccess, reqFailure,
88− reqMethod, respHeaders,
89− response,
90− reqTag,
91− qParams, withCredentials)
92−
70+ reqMethod, respHeaders, response,
71+ qParams)
9372
9473-- * Accessing APIs as a Client
9574
@@ -103,75 +82,28 @@ import Servant.Common.Req (ClientOptions(..),
10382-- >
10483-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
10584-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
106−-- > -> m (Event t (l, ReqResult Book)))
85+-- -> m (Event t (l, ReqResult Book)))
10786-- > (getAllBooks :<|> postNewBook) = client myApi host
10887-- > where host = constDyn $ BaseUrl Http "localhost" 8080
109−client
110− :: (HasClient t m layout tag)
111− => Proxy layout
112− -> Proxy m
113− -> Proxy tag
114− -> Dynamic t BaseUrl
115− -> Client t m layout tag
116−client p q t baseurl = clientWithRoute p q t defReq baseurl defaultClientOptions
117−
118−clientWithOpts
119− :: (HasClient t m layout tag)
120− => Proxy layout
121− -> Proxy m
122− -> Proxy tag
123− -> Dynamic t BaseUrl
124− -> ClientOptions
125− -> Client t m layout tag
126−clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
127−
128−-- | Like 'clientWithOpts' but allows passing a function which will process the
129−-- result event in some way. This can be used to handle errors in a uniform way
130−-- across call sites.
131−clientWithOptsAndResultHandler
132− :: (HasClient t m layout tag)
133− => Proxy layout
134− -> Proxy m
135− -> Proxy tag
136− -> Dynamic t BaseUrl
137− -> ClientOptions
138− -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
139− -> Client t m layout tag
140−clientWithOptsAndResultHandler p q t = clientWithRouteAndResultHandler p q t defReq
88+client :: (HasClient t m layout tag)
89+ => Proxy layout -> Proxy m -> Proxy tag -> Dynamic t BaseUrl -> Client t m layout tag
90+client p q t baseurl = clientWithRoute p q t defReq baseurl
14191
14292
14393-- | This class lets us define how each API combinator
14494-- influences the creation of an HTTP request. It's mostly
14595-- an internal class, you can just use 'client'.
146−class Monad m => HasClient t m layout (tag :: *) where
96+class HasClient t m layout (tag :: *) where
14797 type Client t m layout tag :: *
148− clientWithRoute
149− :: Proxy layout
150− -> Proxy m
151− -> Proxy tag
152− -> Req t
153− -> Dynamic t BaseUrl
154− -> ClientOptions
155− -> Client t m layout tag
156− clientWithRoute l m t r b o = clientWithRouteAndResultHandler l m t r b o return
157−
158− clientWithRouteAndResultHandler
159− :: Proxy layout
160− -> Proxy m
161− -> Proxy tag
162− -> Req t
163− -> Dynamic t BaseUrl
164− -> ClientOptions
165− -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))
166− -> Client t m layout tag
98+ clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> Client t m layout tag
16799
168100
169101instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
170102 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
171103
172− clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =
173− clientWithRouteAndResultHandler (Proxy :: Proxy a) q pTag req baseurl opts wrap :<|>
174− clientWithRouteAndResultHandler (Proxy :: Proxy b) q pTag req baseurl opts wrap
104+ clientWithRoute Proxy q pTag req baseurl =
105+ clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>
106+ clientWithRoute (Proxy :: Proxy b) q pTag req baseurl
175107
176108
177109-- Capture. Example:
@@ -192,9 +124,11 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta
192124 type Client t m (Capture capture a :> sublayout) tag =
193125 Dynamic t (Either Text a) -> Client t m sublayout tag
194126
195− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
196− clientWithRouteAndResultHandler
197− (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
127+ clientWithRoute Proxy q t req baseurl val =
128+ clientWithRoute (Proxy :: Proxy sublayout)
129+ q t
130+ (prependToPathParts p req)
131+ baseurl
198132 where p = (fmap . fmap) (toUrlPiece) val
199133
200134
@@ -204,11 +138,11 @@ instance {-# OVERLAPPABLE #-}
204138 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
205139 ) => HasClient t m (Verb method status cts' a) tag where
206140 type Client t m (Verb method status cts' a) tag =
207− Event t tag -> m (Event t (ReqResult tag a))
141+ Event t tag -> m (Event t (tag, ReqResult a))
208142 -- TODO how to access input types here?
209143 -- ExceptT ServantError IO a
210− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
211− wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
144+ clientWithRoute Proxy _ _ req baseurl trigs =
145+ performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs
212146 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
213147 req' = req { reqMethod = method }
214148
@@ -218,36 +152,32 @@ instance {-# OVERLAPPING #-}
218152 (ReflectMethod method, SupportsServantReflex t m) =>
219153 HasClient t m (Verb method status cts NoContent) tag where
220154 type Client t m (Verb method status cts NoContent) tag =
221− Event t tag -> m (Event t (ReqResult tag NoContent))
155+ Event t tag -> m (Event t (tag, ReqResult NoContent))
222156 -- TODO: how to access input types here?
223157 -- ExceptT ServantError IO NoContent
224− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
225− wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
158+ clientWithRoute Proxy _ _ req baseurl =
159+ performRequestNoBody method req baseurl
226160 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
227161
228162
229−toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
163+toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)
230164toHeaders r =
231− let hdrs = maybe []
232− (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
165+ let toBS = E.encodeUtf8
166+ hdrs = maybe []
167+ (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))
233168 (Map.toList $ _xhrResponse_headers xhr))
234169 (response r)
235170 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
236171
237−
238172class BuildHeaderKeysTo hs where
239− buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
173+ buildHeaderKeysTo :: Proxy hs -> [T.Text]
240174
241175instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
242176 where buildHeaderKeysTo _ = []
243177
244178instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
245− => BuildHeaderKeysTo ((Header h v) ': xs) where
246− buildHeaderKeysTo _ =
247− let
248− thisKey = CI.mk $ T.pack (symbolVal (Proxy :: Proxy h))
249− in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)
250−
179+ => BuildHeaderKeysTo '[(Header h v) ': xs] where
180+ buildHeaderKeysTo _ = (T.pack $ symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
251181
252182-- HEADERS Verb (Content) --
253183-- Headers combinator not treated in fully general case,
@@ -261,11 +191,11 @@ instance {-# OVERLAPPABLE #-}
261191 SupportsServantReflex t m
262192 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
263193 type Client t m (Verb method status cts' (Headers ls a)) tag =
264− Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
265− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
194+ Event t tag -> m (Event t (tag, ReqResult (Headers ls a)))
195+ clientWithRoute Proxy _ _ req baseurl = do
266196 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
267− resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
268− wrap $ toHeaders <$> resp
197+ resp <- performRequestCT (Proxy :: Proxy ct) method req' baseurl
198+ return $ (fmap . fmap) toHeaders <$> resp
269199 where req' = req { respHeaders =
270200 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
271201 }
@@ -277,11 +207,11 @@ instance {-# OVERLAPPABLE #-}
277207 SupportsServantReflex t m
278208 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
279209 type Client t m (Verb method status cts (Headers ls NoContent)) tag
280− = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
281− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
210+ = Event t tag -> m (Event t (tag, ReqResult (Headers ls NoContent)))
211+ clientWithRoute Proxy _ _ req baseurl = do
282212 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
283− resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
284− wrap $ toHeaders <$> resp
213+ resp <- performRequestNoBody method req' baseurl
214+ return $ (fmap . fmap) toHeaders <$> resp
285215 where req' = req {respHeaders =
286216 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
287217 }
@@ -308,11 +238,11 @@ instance (KnownSymbol sym, ToHttpApiData a,
308238 type Client t m (Header sym a :> sublayout) tag =
309239 Dynamic t (Either Text a) -> Client t m sublayout tag
310240
311− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =
312− clientWithRouteAndResultHandler
313− (Proxy :: Proxy sublayout) q t
314− (Servant.Common.Req.addHeader hname eVal req)
315− baseurl opts wrap
241+ clientWithRoute Proxy q t req baseurl eVal =
242+ clientWithRoute (Proxy :: Proxy sublayout)
243+ q t
244+ (Servant.Common.Req.addHeader hname eVal req)
245+ baseurl
316246 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
317247
318248
@@ -326,20 +256,8 @@ instance HasClient t m sublayout tag
326256 type Client t m (HttpVersion :> sublayout) tag =
327257 Client t m sublayout tag
328258
329− clientWithRouteAndResultHandler Proxy =
330− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
331−
332−-- | Using a 'Summary' combinator in your API doesn't affect the client
333−-- functions.
334−instance (HasClient t m sublayout tag, KnownSymbol sym)
335− => HasClient t m (Summary sym :> sublayout) tag where
336−
337− type Client t m (Summary sym :> sublayout) tag =
338− Client t m sublayout tag
339−
340− clientWithRouteAndResultHandler Proxy =
341− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)
342−
259+ clientWithRoute Proxy q t =
260+ clientWithRoute (Proxy :: Proxy sublayout) q t
343261
344262
345263
@@ -376,9 +294,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
376294 Dynamic t (QParam a) -> Client t m sublayout tag
377295
378296 -- if mparam = Nothing, we don't add it to the query string
379− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
380− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
381− (req {qParams = paramPair : qParams req}) baseurl opts wrap
297+ clientWithRoute Proxy q t req baseurl mparam =
298+ clientWithRoute (Proxy :: Proxy sublayout) q t
299+ (req {qParams = paramPair : qParams req}) baseurl
382300
383301 where pname = symbolVal (Proxy :: Proxy sym)
384302 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
@@ -422,12 +340,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
422340 type Client t m (QueryParams sym a :> sublayout) tag =
423341 Dynamic t [a] -> Client t m sublayout tag
424342
425− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
426− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
343+ clientWithRoute Proxy q t req baseurl paramlist =
344+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
427345
428346 where req' = req { qParams = (T.pack pname, params') : qParams req }
429347 pname = symbolVal (Proxy :: Proxy sym)
430− params' = QueryPartParams $ (fmap . fmap) toQueryParam
348+ params' = QueryPartParams $ (fmap . fmap) (toQueryParam)
431349 paramlist
432350
433351
@@ -462,8 +380,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
462380 type Client t m (QueryFlag sym :> sublayout) tag =
463381 Dynamic t Bool -> Client t m sublayout tag
464382
465− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
466− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
383+ clientWithRoute Proxy q t req baseurl flag =
384+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
467385
468386 where req' = req { qParams = thisPair : qParams req }
469387 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
@@ -475,9 +393,9 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
475393instance SupportsServantReflex t m => HasClient t m Raw tag where
476394 type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))
477395 -> Event t tag
478− -> m (Event t (ReqResult tag ()))
396+ -> m (Event t (tag, ReqResult ()))
479397
480− clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
398+ clientWithRoute _ _ _ _ baseurl xhrs triggers = do
481399
482400 let xhrs' = liftA2 (\x path -> case x of
483401 Left e -> Left e
@@ -488,9 +406,8 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
488406 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
489407
490408 resps <- performRequestsAsync okReq
491− wrap $ leftmost [ uncurry RequestFailure <$> badReq
492− , evalResponse (const $ Right ()) <$> resps
493− ]
409+ return $ leftmost [ fmap (ResponseSuccess ()) <$> resps
410+ , fmap (RequestFailure) <$> badReq ]
494411
495412
496413-- | If you use a 'ReqBody' in one of your endpoints in your API,
@@ -519,8 +436,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
519436 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
520437 Dynamic t (Either Text a) -> Client t m sublayout tag
521438
522− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
523− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
439+ clientWithRoute Proxy q t req baseurl body =
440+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
524441 where req' = req { reqBody = bodyBytesCT }
525442 ctProxy = Proxy :: Proxy ct
526443 ctString = T.pack $ show $ contentType ctProxy
@@ -534,9 +451,10 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
534451instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
535452 type Client t m (path :> sublayout) tag = Client t m sublayout tag
536453
537− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =
538− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
539− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap
454+ clientWithRoute Proxy q t req baseurl =
455+ clientWithRoute (Proxy :: Proxy sublayout) q t
456+ (prependToPathParts (pure (Right $ T.pack p)) req)
457+ baseurl
540458
541459 where p = symbolVal (Proxy :: Proxy path)
542460
@@ -544,23 +462,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient
544462instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
545463 type Client t m (Vault :> api) tag = Client t m api tag
546464
547− clientWithRouteAndResultHandler Proxy =
548− clientWithRouteAndResultHandler (Proxy :: Proxy api)
465+ clientWithRoute Proxy q t req baseurl =
466+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
549467
550468
551469instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
552470 type Client t m (RemoteHost :> api) tag = Client t m api tag
553471
554− clientWithRouteAndResultHandler Proxy =
555− clientWithRouteAndResultHandler (Proxy :: Proxy api)
472+ clientWithRoute Proxy q t req baseurl =
473+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
556474
557475
558476
559477instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
560478 type Client t m (IsSecure :> api) tag = Client t m api tag
561479
562− clientWithRouteAndResultHandler Proxy =
563− clientWithRouteAndResultHandler (Proxy :: Proxy api)
480+ clientWithRoute Proxy q t req baseurl =
481+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
564482
565483
566484instance (HasClient t m api tag, Reflex t)
@@ -569,8 +487,8 @@ instance (HasClient t m api tag, Reflex t)
569487 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
570488 -> Client t m api tag
571489
572− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
573− clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
490+ clientWithRoute Proxy q t req baseurl authdata =
491+ clientWithRoute (Proxy :: Proxy api) q t req' baseurl
574492 where
575493 req' = req { authData = Just authdata }
576494
@@ -596,30 +514,3 @@ non-empty lists, but is otherwise more specific, no instance will be overall
596514more specific. This in turn generally means adding yet another instance (one
597515for empty and one for non-empty lists).
598516-}
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+127−195
@@ -1,138 +1,96 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE InstanceSigs #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE InstanceSigs #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TupleSections #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
714{-# 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
3515
16+module Servant.Reflex.Multi
17+ ( clientA
3618 , HasClientMulti(..)
3719 ) where
3820
3921------------------------------------------------------------------------------
40−import Control.Applicative (liftA2)
41−import Data.Functor.Compose (Compose (..), getCompose)
42−import Data.Proxy (Proxy (..))
22+import Control.Applicative
23+import Control.Arrow (second)
24+import Data.Functor.Compose
25+import Data.Monoid ((<>))
4326import 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
4431import Data.Text (Text)
4532import qualified Data.Text as T
46−import qualified Data.Text.Encoding as E
4733import GHC.TypeLits (KnownSymbol, symbolVal)
48−import Servant.API ((:<|>) (..), (:>), BasicAuth,
49− BasicAuthData, BuildHeadersTo (..),
50− Capture, Header, Headers (..),
51− HttpVersion, IsSecure,
52− MimeRender (..), MimeUnrender,
34+import Servant.API ((:<|>)(..),(:>), BasicAuth,
35+ BasicAuthData, BuildHeadersTo(..),
36+ Capture, contentType, Header,
37+ Headers(..), HttpVersion, IsSecure,
38+ MimeRender(..), MimeUnrender,
5339 NoContent, QueryFlag, QueryParam,
54− QueryParams, Raw, ReflectMethod (..),
40+ QueryParams, Raw, ReflectMethod(..),
5541 RemoteHost, ReqBody,
56− ToHttpApiData (..), Vault, Verb,
57− contentType)
58−import Servant.API.Description (Summary)
59−
60−import Reflex.Dom.Core (Dynamic, Event, Reflex,
61− XhrRequest (..),
62− XhrResponseHeaders (..),
63− attachPromptlyDynWith, constDyn)
42+ ToHttpApiData(..), Vault, Verb)
43+
44+import Reflex.Dom (Dynamic, Event, Reflex,
45+ XhrRequest(..),
46+ XhrResponseHeaders(..),
47+ XhrResponse(..), ffor, fmapMaybe,
48+ leftmost, performRequestAsync, attachPromptlyDynWith,
49+ tagPromptlyDyn )
6450------------------------------------------------------------------------------
65−import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
66− SupportsServantReflex)
67−import Servant.Common.Req (ClientOptions,
68− QParam (..), QueryPart (..), Req,
69− ReqResult (..), addHeader, authData,
70− defReq,
71− defaultClientOptions,
72− performRequestsCT,
73− performRequestsNoBody,
74− performSomeRequestsAsync,
75− prependToPathParts, qParamToQueryPart,
76− qParams, reqBody, reqFailure,
77− reqMethod, reqSuccess, reqSuccess',
78− respHeaders, response, withCredentials)
79−import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
80−
51+import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
52+ showBaseUrl,
53+ SupportsServantReflex)
54+import Servant.Common.Req (Req, ReqResult(..), QParam(..),
55+ QueryPart(..), addHeader, authData,
56+ defReq, prependToPathParts,
57+ performRequestCT,
58+ performRequestsCT,
59+ performRequestNoBody,
60+ performRequestsNoBody,
61+ performSomeRequestsAsync,
62+ qParamToQueryPart, reqBody,
63+ reqSuccess, reqFailure,
64+ reqMethod, respHeaders, response,
65+ qParams)
66+import Servant.Reflex (BuildHeaderKeysTo(..), toHeaders)
67+
68+clientA :: (HasClientMulti t m layout f tag, Applicative f)
69+ => Proxy layout -> Proxy m -> Proxy f -> Proxy tag -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
70+clientA p q f tag baseurl = clientWithRouteMulti p q f tag (pure defReq) baseurl
8171
82−------------------------------------------------------------------------------
83−clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
84− => Proxy layout -> Proxy m -> Proxy f -> Proxy tag
85− -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
86−clientA p q f tag baseurl =
87− clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
88− defaultClientOptions
89−
90−
91−-- | A version of @client@ that sets the withCredentials flag
92−-- on requests. Use this function for clients of CORS API's
93−clientWithOptsA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
94− => Proxy layout -> Proxy m -> Proxy f -> Proxy tag
95− -> Dynamic t BaseUrl -> ClientOptions -> ClientMulti t m layout f tag
96−clientWithOptsA p q f tag baseurl opts =
97− clientWithRouteMulti p q f tag
98− (constDyn (pure defReq)) baseurl opts
99−
100−------------------------------------------------------------------------------
10172class HasClientMulti t m layout f (tag :: *) where
10273 type ClientMulti t m layout f tag :: *
103− clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
104− -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
105− -> ClientOptions -> ClientMulti t m layout f tag
106−
74+ clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag -> f (Req t) -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
10775
108−------------------------------------------------------------------------------
109−instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>
110− HasClientMulti t m (a :<|> b) f tag where
111− type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>
112− ClientMulti t m b f tag
113− clientWithRouteMulti Proxy q f tag reqs baseurl opts =
114− clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>
115− clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts
76+instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) => HasClientMulti t m (a :<|> b) f tag where
77+ type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|> ClientMulti t m b f tag
78+ clientWithRouteMulti Proxy q f tag reqs baseurl =
79+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl :<|>
80+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl
11681
11782
118−------------------------------------------------------------------------------
119−instance (SupportsServantReflex t m,
120− ToHttpApiData a,
121− HasClientMulti t m sublayout f tag,
122− Applicative f)
83+instance (SupportsServantReflex t m, ToHttpApiData a, HasClientMulti t m sublayout f tag, Applicative f)
12384 => HasClientMulti t m (Capture capture a :> sublayout) f tag where
12485
12586 type ClientMulti t m (Capture capture a :> sublayout) f tag =
12687 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
12788
128− clientWithRouteMulti _ q f tag reqs baseurl opts vals =
129− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
89+ clientWithRouteMulti l q f tag reqs baseurl vals = clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
13090 where
131− reqs' = (prependToPathParts <$> ps <*>) <$> reqs
91+ reqs' = prependToPathParts <$> ps <*> reqs
13292 ps = (fmap . fmap . fmap) toUrlPiece vals
13393
134−
135−------------------------------------------------------------------------------
13694-- VERB (Returning content) --
13795instance {-# OVERLAPPABLE #-}
13896 -- Note [Non-Empty Content Types]
@@ -144,29 +102,25 @@ instance {-# OVERLAPPABLE #-}
144102 ) => HasClientMulti t m (Verb method status cts' a) f tag where
145103
146104 type ClientMulti t m (Verb method status cts' a) f tag =
147− Event t tag -> m (Event t (f (ReqResult tag a)))
105+ Event t tag -> m (Event t (tag, f (ReqResult a)))
148106
149− clientWithRouteMulti _ _ _ _ reqs baseurl opts =
150− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts
107+ clientWithRouteMulti _ _ f tag reqs baseurl =
108+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
151109 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
152− reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
153−
110+ reqs' = (\r -> r { reqMethod = method }) <$> reqs
154111
155−------------------------------------------------------------------------------
156112-- -- VERB (No content) --
157113instance {-# OVERLAPPING #-}
158114 (ReflectMethod method, SupportsServantReflex t m, Traversable f) =>
159115 HasClientMulti t m (Verb method status cts NoContent) f tag where
160116 type ClientMulti t m (Verb method status cts NoContent) f tag =
161− Event t tag -> m (Event t (f (ReqResult tag NoContent)))
117+ Event t tag -> m (Event t (tag, f (ReqResult NoContent)))
162118 -- TODO: how to access input types here?
163119 -- ExceptT ServantError IO NoContent
164− clientWithRouteMulti Proxy _ _ _ req baseurl opts =
165− performRequestsNoBody method req baseurl opts
120+ clientWithRouteMulti Proxy _ _ tag req baseurl =
121+ performRequestsNoBody method req baseurl
166122 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
167123
168−
169−------------------------------------------------------------------------------
170124instance {-# OVERLAPPABLE #-}
171125 -- Note [Non-Empty Content Types]
172126 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
@@ -175,41 +129,35 @@ instance {-# OVERLAPPABLE #-}
175129 Traversable f
176130 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where
177131 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))))
179− clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
132+ Event t tag -> m (Event t (tag, f (ReqResult (Headers ls a))))
133+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
180134 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)))
182− return $ fmap toHeaders <$> resp
183− where
184− reqs' = fmap (\r ->
185− r { respHeaders =
186− OnlyHeaders (Set.fromList
187− (buildHeaderKeysTo (Proxy :: Proxy ls)))
188− }) <$> reqs
135+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl triggers :: m (Event t (tag, f (ReqResult a)))
136+ return $ (fmap . fmap) toHeaders <$> resp
137+ where reqs' = ffor reqs $ \r -> r { respHeaders =
138+ OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
139+ }
189140
190141
191−------------------------------------------------------------------------------
192142instance {-# OVERLAPPABLE #-}
193143 ( BuildHeadersTo ls,
194144 BuildHeaderKeysTo ls,
195145 ReflectMethod method,
196146 SupportsServantReflex t m,
197147 Traversable f
198− ) => HasClientMulti t m (Verb method status
199− cts (Headers ls NoContent)) f tag where
148+ ) => HasClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag where
200149 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))))
202− clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do
150+ = Event t tag -> m (Event t (tag, f (ReqResult (Headers ls NoContent))))
151+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
203152 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
204− resp <- performRequestsNoBody method reqs' baseurl opts triggers
205− return $ fmap toHeaders <$> resp
206− where reqs' = fmap (\req ->
153+ resp <- performRequestsNoBody method reqs' baseurl triggers
154+ return $ (fmap . fmap) toHeaders <$> resp
155+ where reqs' = ffor reqs $ \req ->
207156 req {respHeaders = OnlyHeaders (Set.fromList
208157 (buildHeaderKeysTo (Proxy :: Proxy ls)))
209− }) <$> reqs
158+ }
210159
211160
212−------------------------------------------------------------------------------
213161instance (KnownSymbol sym,
214162 ToHttpApiData a,
215163 HasClientMulti t m sublayout f tag,
@@ -221,17 +169,16 @@ instance (KnownSymbol sym,
221169 type ClientMulti t m (Header sym a :> sublayout) f tag =
222170 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
223171
224− clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =
172+ clientWithRouteMulti Proxy f q tag reqs baseurl eVals =
225173 clientWithRouteMulti (Proxy :: Proxy sublayout) f
226174 q tag
227175 reqs'
228− baseurl opts
176+ baseurl
229177 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
230− reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
231− <$> eVals <*>) <$> reqs
178+ reqs' = (\eVal req -> Servant.Common.Req.addHeader hname eVal req)
179+ <$> eVals <*> reqs
232180
233181
234−------------------------------------------------------------------------------
235182instance HasClientMulti t m sublayout f tag
236183 => HasClientMulti t m (HttpVersion :> sublayout) f tag where
237184
@@ -242,40 +189,22 @@ instance HasClientMulti t m sublayout f tag
242189 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
243190
244191
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−------------------------------------------------------------------------------
257−instance (KnownSymbol sym,
258− ToHttpApiData a,
259− HasClientMulti t m sublayout f tag,
260− Reflex t,
261− Applicative f)
192+instance (KnownSymbol sym, ToHttpApiData a, HasClientMulti t m sublayout f tag, Reflex t, Traversable f, Applicative f)
262193 => HasClientMulti t m (QueryParam sym a :> sublayout) f tag where
263194
264195 type ClientMulti t m (QueryParam sym a :> sublayout) f tag =
265− Dynamic t (f (QParam a)) -> ClientMulti t m sublayout f tag
196+ f (Dynamic t (QParam a)) -> ClientMulti t m sublayout f tag
266197
267198 -- if mparam = Nothing, we don't add it to the query string
268199 -- TODO: Check the above comment
269− clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =
200+ clientWithRouteMulti Proxy q f tag reqs baseurl mparams =
270201 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
271− reqs' baseurl opts
202+ reqs' baseurl
272203
273204 where pname = symbolVal (Proxy :: Proxy sym)
274205 p prm = QueryPartParam $ fmap qParamToQueryPart prm
275206 paramPair mp = (T.pack pname, p mp)
276− -- reqs' = (\params reqs -> (\req param -> req {qParams = paramPair param : qParams req}) <$> reqs <*> params)
277− -- <$> mparams <*> reqs
278− reqs' = liftA2 (\(pr :: QParam a) (r :: Req t) -> r { qParams = paramPair (constDyn pr) : qParams r })
207+ reqs' = (\param req -> req {qParams = paramPair param : qParams req})
279208 <$> mparams <*> reqs
280209
281210
@@ -283,74 +212,77 @@ instance (KnownSymbol sym,
283212 ToHttpApiData a,
284213 HasClientMulti t m sublayout f tag,
285214 Reflex t,
215+ Traversable f,
286216 Applicative f)
287217 => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where
288218
289219 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
290− Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
220+ f (Dynamic t [a]) -> ClientMulti t m sublayout f tag
291221
292− clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =
293− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
222+ clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =
223+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
294224
295− where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }
225+ where req' l r = r { qParams = (T.pack pname, params' l) : qParams r }
296226 pname = symbolVal (Proxy :: Proxy sym)
297227 params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)
298228 l
299− reqs' = liftA2 req' <$> paramlists <*> reqs
229+ reqs' = req' <$> paramlists <*> reqs
300230
301231
302232instance (KnownSymbol sym,
303233 HasClientMulti t m sublayout f tag,
304234 Reflex t,
235+ Traversable f,
305236 Applicative f)
306237 => HasClientMulti t m (QueryFlag sym :> sublayout) f tag where
307238
308239 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
309− Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
240+ f (Dynamic t Bool) -> ClientMulti t m sublayout f tag
310241
311− clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =
312− clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts
242+ clientWithRouteMulti Proxy q f tag reqs baseurl flags =
243+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
313244
314− where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
245+ where req' f req = req { qParams = thisPair f : qParams req }
315246 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
316247 pName = symbolVal (Proxy :: Proxy sym)
317− reqs' = liftA2 req' <$> flags <*> reqs
248+ reqs' = req' <$> flags <*> reqs
318249
319250
320251instance (SupportsServantReflex t m,
321− Traversable f, Applicative f) => HasClientMulti t m Raw f tag where
252+ Traversable f) => HasClientMulti t m Raw f tag where
322253 type ClientMulti t m Raw f tag = f (Dynamic t (Either Text (XhrRequest ())))
323254 -> Event t tag
324− -> m (Event t (f (ReqResult tag ())))
255+ -> m (Event t (tag, f (ReqResult ())))
325256
326− clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do
257+ clientWithRouteMulti _ _ _ _ oldReqs baseurl rawReqs triggers = do
327258 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
328259 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
329− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''
260+ resps <- fmap (second (fmap aux) . getCompose) <$> performSomeRequestsAsync rawReqs''
330261 return resps
331262 where
332− aux (tag, Right r) = ResponseSuccess tag () r
333− aux (tag, Left e) = RequestFailure tag e
263+ aux (Right r) = ResponseSuccess () r
264+ aux (Left e) = RequestFailure e
334265
335266
336267instance (MimeRender ct a,
337268 HasClientMulti t m sublayout f tag,
338269 Reflex t,
270+ Traversable f,
339271 Applicative f)
340272 => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where
341273
342274 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
343− Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
275+ f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
344276
345− clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =
346− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts
347− where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
277+ clientWithRouteMulti Proxy q f tag reqs baseurl bodies =
278+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
279+ where req' b r = r { reqBody = bodyBytesCT b }
348280 ctProxy = Proxy :: Proxy ct
349281 ctString = T.pack $ show $ contentType ctProxy
350282 bodyBytesCT b = Just $ (fmap . fmap)
351283 (\b' -> (mimeRender ctProxy b', ctString))
352284 b
353− reqs' = liftA2 req' <$> bodies <*> reqs
285+ reqs' = req' <$> bodies <*> reqs
354286
355287
356288instance (KnownSymbol path,
@@ -361,7 +293,7 @@ instance (KnownSymbol path,
361293
362294 clientWithRouteMulti Proxy q f tag reqs baseurl =
363295 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
364− (fmap (prependToPathParts (pure (Right $ T.pack p))) <$> reqs)
296+ (prependToPathParts (pure (Right $ T.pack p)) <$> reqs)
365297 baseurl
366298
367299 where p = symbolVal (Proxy :: Proxy path)
@@ -388,14 +320,14 @@ instance HasClientMulti t m api f tag => HasClientMulti t m (IsSecure :> api) f
388320 clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl
389321
390322
391−instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
323+instance (HasClientMulti t m api f tag, Reflex t, Traversable f, Applicative f)
392324 => HasClientMulti t m (BasicAuth realm usr :> api) f tag where
393325
394− type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))
326+ type ClientMulti t m (BasicAuth realm usr :> api) f tag = f (Dynamic t (Maybe BasicAuthData))
395327 -> ClientMulti t m api f tag
396328
397− clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =
398− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts
329+ clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =
330+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl
399331 where
400− req' a r = r { authData = Just (constDyn a) }
401− reqs' = liftA2 req' <$> authdatas <*> reqs
332+ req' a r = r { authData = Just a }
333+ reqs' = 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
99import Data.Foldable
1010import Test.WebDriver.Commands.Wait
1111import Test.Hspec.WebDriver
12−import Test.Hspec.WebDriver (chromeCaps)
1312
1413
1514clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()
@@ -29,7 +28,7 @@ spec :: Spec
2928spec = do
3029 describe "servant-reflex tests" $ do
3130
32− session "test page" $ using [chromeCaps] $ do
31+ session "test page" $ using Chrome $ do
3332
3433 it "opens the page" $ runWD $
3534 openPage "http://localhost:8000"
testserver/API.hsmode 100644 → 120000+1−69
@@ -1,69 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TypeOperators #-}
4−
5−module API where
6−
7−import Data.Aeson
8−import Data.Aeson.Types (typeMismatch)
9−import Data.Text (Text)
10−import Servant.API
11−
12−newtype Question = Question { unQuestion :: Text } deriving (Show)
13−
14−instance ToJSON Question where
15− toJSON (Question txt) = object ["question" .= txt]
16−
17−instance FromJSON Question where
18− parseJSON (Object v) = Question <$> v .: "question"
19− parseJSON x = typeMismatch "Couldn't find key 'question'" x
20−
21−newtype Answer = Answer { unAnswer :: Text } deriving (Show)
22−
23−instance ToJSON Answer where
24− toJSON (Answer txt) = object ["answer" .= txt]
25−
26−instance FromJSON Answer where
27− parseJSON (Object v) = Answer <$> v .: "answer"
28− parseJSON x = typeMismatch "Couldn't find key 'answer'" x
29−
30−
31−-- | API spec for server, client, and docs
32−type API = "getunit" :> Get '[JSON] ()
33− :<|> "getint" :> Get '[JSON] Int
34− :<|> "sayhi" :> QueryParam "username" Text
35− :> QueryParams "greetings" Text
36− :> QueryFlag "gusto"
37− :> Get '[JSON] Text
38− :<|> "double" :> ReqBody '[JSON] Double
39− :> Post '[JSON] Double
40− :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
41− :<|> "qna" :> ReqBody '[JSON] Question
42− :> Post '[JSON] Answer
43− :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
44− :<|> Raw
45−
46−type GET = Get '[JSON] ()
47−
48−-- Imported the comprehensive API example for testing.
49−-- https://github.com/haskell-servant/servant/blob/master/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs
50−type ComprehensiveAPI =
51− GET :<|>
52− Get '[JSON] Int :<|>
53− Capture "foo" Int :> GET :<|>
54− Header "foo" Int :> GET :<|>
55− HttpVersion :> GET :<|>
56− IsSecure :> GET :<|>
57− QueryParam "foo" Int :> GET :<|>
58− QueryParams "foo" Int :> GET :<|>
59− QueryFlag "foo" :> GET :<|>
60−-- Raw :<|>
61− RemoteHost :> GET :<|>
62− ReqBody '[JSON] Int :> GET :<|>
63− Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>
64− "foo" :> GET :<|>
65− Vault :> GET :<|>
66− Verb 'POST 204 '[JSON] () :<|>
67− Verb 'POST 204 '[JSON] Int
68−-- This one isn't in scope
69−-- :<|> WithNamedContext "foo" '[] GET
@@ -0,0 +1 @@
1+../exec/API.hs
testserver/Main.hs+14−39
@@ -2,34 +2,27 @@
22{-# LANGUAGE DeriveGeneric #-}
33{-# LANGUAGE OverloadedStrings #-}
44{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE TypeApplications #-}
65{-# LANGUAGE TypeFamilies #-}
76{-# LANGUAGE TypeOperators #-}
87
9−import Control.Monad.IO.Class (liftIO)
10−import Control.Monad.Reader (reader)
118import Data.Aeson
129import Data.Bool
13−import Data.Char (toUpper)
14−import qualified Data.List as L
15−import Data.Maybe (fromMaybe)
10+import Data.Char (toUpper)
11+import qualified Data.List as L
1612import Data.Monoid
1713import Data.Proxy
18−import Data.Text hiding (head, length, map,
19− null, toUpper)
20−import qualified Data.Text as T
21−import qualified Data.Text.IO as T
14+import Data.Text hiding (length, null, map, head, toUpper)
15+import qualified Data.Text as T
2216import GHC.Generics
23−import Servant.Server.Internal.SnapShims
24−import Snap.Core
2517import Snap.Http.Server
18+import Snap.Core
19+import Servant.Server.Internal.SnapShims
2620
27−import Servant
21+import Servant -- hiding (serveDirectory)
2822import Servant.Server
2923-- import Snap.Util.FileServe
30−import System.Environment (lookupEnv)
3124import API
32−import Snap
25+import Snap
3326
3427-- * Example
3528
@@ -43,7 +36,7 @@ instance ToJSON Greet
4336testApi :: Proxy API
4437testApi = Proxy
4538
46−data App = App { appStaticDir :: String }
39+data App = App
4740
4841-- Server-side handlers.
4942--
@@ -51,10 +44,8 @@ data App = App { appStaticDir :: String }
5144-- that represents the API, are glued together using :<|>.
5245--
5346-- Each handler runs in the 'ExceptT ServantErr IO' monad.
54−server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
55−server = return () :<|> return 100 :<|> sayhi :<|> dbl
56− :<|> multi :<|> qna :<|> serveSecret
57− :<|> statics
47+server :: Server API (Handler App App)
48+server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> serveDirectory "static"
5849 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
5950 sayhi nm greetings withGusto = case nm of
6051 Nothing -> return ("Sorry, who are you?" :: Text)
@@ -66,36 +57,20 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl
6657 | otherwise = T.intercalate ", " (L.init greetings)
6758 <> ", and " <> L.last greetings <> ", "
6859 return . modifier $ greetPart <> n
69− dbl x = if x `elem` [4,13]
70− then throwError $ err500 { errBody = "No unlucky numbers please" }
71− else return $ x * 2
60+ dbl x = return $ x * 2
7261 multi = return . bool "Box unchecked" "Box Checked"
73− qna q = do
74− liftIO $ do
75− putStrLn $ "qna got: " ++ show q
76− T.putStrLn $ unQuestion q
77− return $ Answer $ unQuestion q
78− serveSecret _ = do
79− req <- getRequest
80− liftIO $ putStrLn (show req)
81− return 101
82− statics = do
83− staticDir <- reader appStaticDir
84− serveDirectory staticDir
8562
8663-- Turn the server into a WAI app. 'serve' is provided by servant,
8764-- more precisely by the Servant.Server module.
8865test :: Handler App App ()
89−test = serveSnapWithContext testApi
90− (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server
66+test = serveSnap testApi server
9167
9268initApp :: SnapletInit App App
9369initApp = makeSnaplet "myapp" "example" Nothing $ do
94− staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")
9570 addRoutes [("", test)
9671 ,("", serveDirectory "static")
9772 ]
98− return (App staticDir)
73+ return App
9974
10075-- Put this all to work!
10176main :: 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+16−17
@@ -1,32 +1,31 @@
1−-- Initial back.cabal generated by cabal init. For further documentation,
1+-- Initial back.cabal generated by cabal init. For further documentation,
22-- see http://haskell.org/cabal/users-guide/
33
44name: testserver
55version: 0.1.0.0
6−-- synopsis:
7−-- description:
6+-- synopsis:
7+-- description:
88license: BSD3
99license-file: LICENSE
1010author: Greg Hale
1111maintainer: imalsogreg@gmail.com
12−-- copyright:
13−-- category:
12+-- copyright:
13+-- category:
1414build-type: Simple
15−-- extra-source-files:
15+-- extra-source-files:
1616cabal-version: >=1.10
1717
1818executable back
1919 main-is: Main.hs
20− -- other-modules:
21− -- other-extensions:
22− build-depends: aeson >= 0.9 && < 1.5
23− , base >=4.8 && < 5
24− , mtl
25− , snap >= 1.0 && < 1.2
26− , snap-server >= 1.0 && < 1.2
20+ -- other-modules:
21+ -- other-extensions:
22+ build-depends: aeson >= 0.9 && < 1.1
23+ , base >=4.8 && <4.10
24+ , snap >= 1.0 && < 1.1
25+ , snap-server >= 1.0 && < 1.1
2726 , snap-core >= 1.0 && < 1.1
28− , servant >= 0.16 && < 0.18
29− , servant-snap >= 0.8 && < 0.9
30− , text >= 1.0 && < 1.3
31− -- hs-source-dirs:
27+ , servant >= 0.7.1 && < 0.9
28+ , servant-snap >= 0.7 && < 0.8
29+ , text >= 1.2 && < 1.3
30+ -- hs-source-dirs:
3231 default-language: Haskell2010
testserver/tr.nixnew file+32
@@ -0,0 +1,32 @@
1+{ reflex-platform, ... }:
2+let
3+
4+ dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;
5+ cabal2nixResult = reflex-platform.cabal2nixResult;
6+ nixpkgs = (import <nixpkgs> {});
7+in
8+reflex-platform.ghc.override {
9+ overrides = self: super: {
10+ servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});
11+ snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap) {});
12+ io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});
13+ io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});
14+ heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});
15+ xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});
16+ snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});
17+ snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});
18+ snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});
19+ snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});
20+ hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});
21+
22+ # servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});
23+ # servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});
24+ # servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});
25+ # servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});
26+ # servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});
27+ # servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});
28+ # servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});
29+ # servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});
30+
31+ };
32+}
travis.nixdeleted−70
@@ -1,70 +0,0 @@
1−{
2− nativeCompiler ? "ghc",
3− # ^ Choose a GHC for compiling backend components (web server, selenium)
4− # (ghc, ghc8_0, ghc8_2, ghc8_4 or ghcHEAD)
5−
6− jsCompiler ? "ghcjs"
7− # ^ Choose a GHCJS for compiling the frontend
8− # (ghcjs, ghcjs8_0, ghcjs8_2 or ghcjs8_4)
9−
10−}:
11−
12−let
13−
14− reflexPlatform = import ./nix/reflex-platform.nix;
15−
16− lib = reflexPlatform.nixpkgs.haskell.lib;
17− do = funs: pkg: builtins.foldl' (a: b: b a) pkg funs;
18−
19− ghcjsPkgs = with lib; reflexPlatform.${jsCompiler}.override {
20− overrides = self: super: {
21− http-media = dontCheck super.http-media;
22− servant = dontCheck super.servant;
23− lens-aeson = dontCheck super.lens-aeson;
24− servant-reflex = lib.appendConfigureFlag
25− (self.callPackage ./default.nix {}) "-fExample";
26− };
27− };
28−
29− ghcPkgs = with lib; reflexPlatform.${nativeCompiler}.override {
30− overrides = self: super: {
31− servant-snap = dontCheck ((import ./nix/servant-snap.nix {}) self super);
32− testdriver = self.callCabal2nix "testdriver" ./testdriver {};
33− testserver = import nix/testserver.nix ghcjsPkgs.servant-reflex self super;
34− servant-reflex = self.callPackage ./default.nix {};
35− };
36− };
37−
38− testresults = import ./nix/testresults.nix
39− { inherit reflexPlatform;
40− inherit (ghcPkgs) testserver testdriver;
41− inherit (reflexPlatform.nixpkgs) curl;
42− phantomjs = reflexPlatform.nixpkgs.phantomjs2;
43− };
44−
45−in
46− rec {
47−
48− inherit reflexPlatform ghcPkgs ghcjsPkgs;
49−
50− build = ghcjsPkgs.servant-reflex;
51− buildGhc = ghcPkgs.servant-reflex;
52− testserver = ghcPkgs.testserver;
53− testdriver = ghcPkgs.testdriver;
54− inherit testresults;
55−
56− cabalBuild = reflexPlatform.${jsCompiler}.shellFor {
57− name = "servant-reflex-cabal-builder";
58−
59− packages = p: [
60− build
61− ];
62−
63− shellHook = ''
64− cabal configure --ghcjs -f Example
65− cabal build
66− exec/toSite.sh
67− exit $?
68− '';
69− };
70− }