fcfa875..master · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

35 files changed+837−1053

unifiedsplit

.gitignore+2 .gitmodules−12 .travis.yml+12−56 changelog.md → ChangeLog.md+28 README.md+70−33 build.sh−3 default.nix+21 deps/http-api-data−1 deps/reflex-platform−1 deps/servant−1 deps/servant-snap−1 exec/API.hs+1 exec/Example.hs+45−27 exec/TupleExample.hs−35 nix/nix.conf+3 nix/reflex-platform.nix+7 nix/servant-snap.nix+7 nix/testresults.nix+17 nix/testserver.nix+9 overrides-ghc.nix−11 overrides.nix−9 servant-reflex.cabal+26−20 shell.nix+1 src/Servant/Common/BaseUrl.hs+10−7 src/Servant/Common/Req.hs+114−305 src/Servant/Reflex.hs+213−182 src/Servant/Reflex/Multi.hs+82−53 src/Servant/Reflex/Tuple.hs−245 testdriver/test/Servant/ReflexSpec.hs+2−1 testserver/API.hs+69−1 testserver/Main.hs+20−5 testserver/run-wd-tests.sh−5 testserver/testserver.cabal+8−7 testserver/tr.nix−32 travis.nix+70

.gitignore+2

@@ -7,3 +7,5 @@ log

77*.stats

88out

99/.stack-work/

10+TAGS

11+dist-newstyle

.gitmodules−12

@@ -1,12 +0,0 @@

1−[submodule "deps/http-api-data"]

2− path = deps/http-api-data

3− url = https://github.com/fizruk/http-api-data

4−[submodule "deps/servant"]

5− path = deps/servant

6− url = https://github.com/haskell-servant/servant

7−[submodule "deps/servant-snap"]

8− path = deps/servant-snap

9− url = https://github.com/haskell-servant/servant-snap

10−[submodule "deps/reflex-platform"]

11− path = deps/reflex-platform

12− url = https://github.com/reflex-frp/reflex-platform

.travis.yml+12−56

@@ -1,61 +1,17 @@

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−

1+language: nix

2+nix: 2.3.6

3+sudo: require

214

225before_install:

23− - unset CC

24− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH

25− - git submodule update --init --recursive

6+ - sudo cp -rT $TRAVIS_BUILD_DIR/nix /etc/nix

267

27−install:

28− - cabal --version

29− - BENCH=${BENCH---enable-benchmarks}

30− - TEST=${TEST---enable-tests}

31− - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"

32− - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];

33− then

34− zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >

35− $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;

36− fi

37− - travis_retry cabal update -v

38− - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config

39− - deps/reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal configure -fExample && cabal build"

40− - deps/reflex-platform/work-on ghc ./testdriver --command "cd testdriver && cabal configure && cabal build"

41− - cd testserver && dist/build/back/back -p 8000 &

42− - sleep 3

43− - phantomjs --webdriver=127.0.0.1:4444 &

44− - sleep 3

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"

4512

4613script:

47− - git config --global user.email "travis-ci@example.com"

48− - git config --global user.name "Travis-CI"

49− - ./build.sh

50− # - testdriver/dist/build/spec/spec

51−

52−cache:

53− directories:

54− - /nix

55− - $HOME/.cabal/packages

56− - $HOME/.cabal/store

57−

58−env:

59− global:

60− - ENCRYPTION_LABEL: "3c89d919c82e"

61− - COMMIT_AUTHOR_EMAIL: "imalsogreg@gmail.com"

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

changelog.md → ChangeLog.mdrenamed+28

@@ -1,3 +1,31 @@

1+0.3.5

2+-----

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

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+

1290.3

230---

331

README.md+70−33

@@ -4,14 +4,19 @@

55## `servant-reflex` lets you share your `servant` APIs with the frontend

7−Keeping your frontend in sync with your API server can be difficult - when the API changes its input parameters or return type, XHR requests from the frontend will fail at runtime. If your API is defined by [servant](haskell-servant.readthedocs.io) combinators, you can use `servant-reflex` to share the API between the server and frontend.

8−Syncronization between is checked at compile time, and rather than building XHR requests by hand, API endpoints are available behind `reflex`'s FRP semantics.

9−

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.

1014

1115

1216## Example

1317

14−We have a webservice API defined in a module where both the server (compiled with ghc) and the frontend (compiled with ghcjs) can see it:

18+We have a webservice API defined in a module where both the server (compiled

19+with ghc) and the frontend (compiled with ghcjs) can see it:

1520

1621```haskell

1722type API = "getint" :> Get '[JSON] Int

@@ -24,7 +29,8 @@ type API = "getint" :> Get '[JSON] Int

2429 :<|> Raw

2530```

2631

27−`servant-reflex` then computes client functions that can query the API through an `XhrRequest`.

32+`servant-reflex` then computes client functions that can query the API through

33+an `XhrRequest`.

2834

2935```haskell

3036

@@ -37,7 +43,16 @@ type API = "getint" :> Get '[JSON] Int

3743 (constDyn (BasePath "/"))

3844```

3945

40−These client functions are computed from your API type. They manage serialization, XhrRequest generation, and deserialization for you. `a` parameters used in URL captures become `Dynamic t (Either Text a)` parameters in the client functions. 'QueryFlag', 'QueryParams' and 'QueryParam' API parameters map to 'Dynamic t Bool', 'Dynamic t [a]' and 'Dynamic t (QParam a)' respectively. These parameters to the client function are wrapped with failure possibility to allow you to indicate at any time whether input validation for that parameter has failed and no valid XHR request can be generated. The final parameter is a trigger event for the XHR request. The return value `Event t (ReqResult a)` contains responses from the API server.

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.

4156

4257```haskell

4358 -- No need to write these functions. servant-reflex creates them for you!

@@ -62,7 +77,13 @@ These client functions are computed from your API type. They manage serializatio

6277 -> m (Event t (ReqResult () Double))

6378```

6479

65−`ReqResult tag a` is defined in [`Servant.Common.Req`](https://github.com/imalsogreg/servant-reflex/blob/6d866e338edb9bf6fd8f8d5083ff0187b4d8c0d2/src/Servant/Common/Req.hs#L40-L42) and reports whether or not your request was sent (if validation fails, the request won't be sent), and how decoding of the response went. You can pattern match on these explicitly, but usually you'll want to use `fmapMaybe :: (a -> Maybe b) -> Event t a -> Event t b` and one of the elimination functions to filter the result type you care about, like this:

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:

6687

6788```haskell

6889 -- ... continued ...

@@ -80,7 +101,8 @@ These client functions are computed from your API type. They manage serializatio

80101 dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])

81102```

82103

83−This example builds some input fields to enter API parameters, buttons to trigger the API calls, and text elements to show the results:

104+This example builds some input fields to enter API parameters, buttons to

105+trigger the API calls, and text elements to show the results:

84106

85107```haskell

86108 elClass "div" "int-demo" $ do

@@ -103,47 +125,53 @@ This example builds some input fields to enter API parameters, buttons to trigge

103125 display =<< holdDyn Nothing outputDouble

104126```

105127

106−For a great introduction to recative DOM building, see the [README](https://github.com/reflex-frp/reflex-platform) for the `reflex-platform`. For more information about servant, see their [documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to the respective authors of these fabulous libraries.

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.

107133

108134

109135## Building the library and test server

110136

111−This repository comes with a small example of an API shared between a ghcjs-compiled frontend ([exec/](https://github.com/imalsogreg/servant-reflex/tree/master/exec)) and a ghc-compiled backend ([testserver/](https://github.com/imalsogreg/servant-reflex/tree/master/testserver). To build these components:

112−

113−

114−First build the library:

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.

115144

116145```

117−git submodule update --init --recursive

118−./build.sh

146+nix build -f travis.nix testserver -o server

119147```

120148

121−Then build the test server:

122−

123−```

124−deps/reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal build"

125−```

126−

127−

128−## Running the example site

129−

130−The server must be run from the directory where static assets live:

149+Point it at the static directory and run it:

131150

132151```

133−cd testserver

134−dist/build/back/back -p 8001

152+STATIC_DIR=server/static server/back -p 8000

135153```

136154

137−And simply browse to `localhost:8001`

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.

138158

139−**For a larger example of a project that shares types between backend and frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**

159+**For a larger example of a project that shares types between backend and

160+frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**

140161

141162

142163## Tagging requests

143164

144−The input and the return type of a client function like `getDouble` are both event streams. The individual input events and responses occur at different times and aren't automatically paired up, but you can recover the relationship by tagging the requests.

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.

145169

146−So far we have used an `Event t ()` to trigger sending a request. If we choose e.g. `Double` for the third `Proxy` argument to `client`, then `Event t Double` will be used to trigger requests, and each `ReqResult` will carry the tag of its request. Imagine we wanted to display not just the last "double" from `doubleIt`, but a whole table of valid inputs and their doubled responses:

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:

147175

148176```haskell

149177 ...

@@ -173,7 +201,10 @@ So far we have used an `Event t ()` to trigger sending a request. If we choose e

173201

174202## Simultaneous requests

175203

176−'Servant.Reflex.Multi' provides an alternative client-generation function called 'clientA' (client applicative). Choose a container type that has both `Applicative` and `Traversable` instances, and pass it to `clientA` through another 'Proxy'. Our `sayHi` client function will then have this type:

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:

177208

178209```haskell

179210sayHi

@@ -184,4 +215,10 @@ sayHi

184215 -> m (Event t (f (ReqResult tag Text)))

185216```

186217

187−The dynamic params are each wrapped in `f`. For every firing of the trigger event `tag`, all of these parameters will be combined according to `f`'s applicative instance (when `f` is `[]`, you will get all combinations of all parameters taken together as a request; when `f` is 'ZipList', the Nth elemens of each parameters list will be taken together as a request). Using this interface, you can trigger many XHR's from a single event occurence, and expect the responses to be structured the same way as the requests.

218+The dynamic params are each wrapped in `f`. For every firing of the trigger

219+event `tag`, all of these parameters will be combined according to `f`'s

220+`Applicative` instance (when `f` is `[]`, you will get all combinations of

221+all parameters taken together as a request; when `f` is `ZipList`, the Nth

222+elemens of each parameters list will be taken together as a request). Using

223+this interface, you can trigger many XHR's from a single event occurence, and

224+expect the responses to be structured the same way as the requests.

build.shdeleted−3

@@ -1,3 +0,0 @@

1−#!/usr/bin/env bash

2−

3−deps/reflex-platform/work-on ./overrides.nix ./. --run "cabal configure --ghcjs && cabal build && exec/toSite.sh"

default.nixnew file+21

@@ -0,0 +1,21 @@

1+{ mkDerivation, base, bytestring, case-insensitive, containers

2+, data-default, exceptions, ghcjs-dom, http-api-data, http-media

3+, jsaddle, mtl, network-uri, reflex, reflex-dom, reflex-dom-core

4+, safe, servant, servant-auth, stdenv, string-conversions, text

5+, transformers

6+}:

7+mkDerivation {

8+ pname = "servant-reflex";

9+ version = "0.3.6";

10+ src = ./.;

11+ isLibrary = true;

12+ isExecutable = true;

13+ libraryHaskellDepends = [

14+ base bytestring case-insensitive containers data-default exceptions

15+ ghcjs-dom http-api-data http-media jsaddle mtl network-uri reflex

16+ reflex-dom reflex-dom-core safe servant servant-auth string-conversions

17+ text transformers

18+ ];

19+ description = "servant API generator for reflex apps";

20+ license = stdenv.lib.licenses.bsd3;

21+}

deps/http-api-datadeleted−1

Submodule changed.

deps/reflex-platformdeleted−1

Submodule changed.

deps/servantdeleted−1

Submodule changed.

deps/servant-snapdeleted−1

Submodule changed.

exec/API.hs+1

@@ -40,6 +40,7 @@ type API = "getunit" :> Get '[JSON] ()

4040 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text

4141 :<|> "qna" :> ReqBody '[JSON] Question

4242 :> Post '[JSON] Answer

43+ :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int

4344 :<|> Raw

4445

4546type GET = Get '[JSON] ()

exec/Example.hs+45−27

@@ -1,3 +1,4 @@

1+{-# LANGUAGE DataKinds #-}

12{-# LANGUAGE FlexibleContexts #-}

23{-# LANGUAGE GADTs #-}

34{-# LANGUAGE OverloadedStrings #-}

@@ -14,16 +15,17 @@ import Control.Monad.Fix (MonadFix)

1415import Data.Monoid (First(..), (<>))

1516import Data.Text (Text)

1617import qualified Data.Text as T

18+import qualified Data.Text.Encoding as T

1719import GHC.TypeLits

1820import Servant.API

1921import API

2022import Data.Proxy

2123import Text.Read (readMaybe)

22−import Reflex.Dom hiding (run)

24+import Reflex.Dom.Core hiding (run, mainWidget)

25+import Reflex.Dom (mainWidget)

2326------------------------------------------------------------------------------

2427import Servant.Reflex

2528import Servant.Reflex.Multi

26−import qualified TupleExample

2729

2830

2931api :: Proxy API

@@ -31,10 +33,8 @@ api = Proxy

3133

3234main :: IO ()

3335main = mainWidget $ do

34− el "h1" $ text "Wowzers!"

3536 divClass "example-base" run

3637 divClass "example-multi" runMulti

37− divClass "example-tuple" TupleExample.run

3838

3939

4040runMulti :: forall t m. (SupportsServantReflex t m,

@@ -46,7 +46,7 @@ runMulti :: forall t m. (SupportsServantReflex t m,

4646runMulti = do

4747 url <- baseUrlWidget

4848 el "br" blank

49− let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ ) =

49+ let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =

5050 clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url

5151

5252 num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def

@@ -67,11 +67,14 @@ runMulti = do

6767 grts <- fmap (fmap T.words . value) $ divClass "" $ do

6868 text "Greetings"

6969 textInput def

70− gust <- fmap value $ divClass "gusto-input" $ checkbox False def

70+ gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def

7171 b <- button "Go"

72− r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) grts) (constDyn [True, False]) (1 <$ b)

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')

7377

74− dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes . fmap reqSuccess <$> r')

7578

7679 return ()

7780

@@ -94,8 +97,11 @@ run = mdo

9497 el "br" (return ())

9598

9699 -- Name the computed API client functions

98− client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url

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

99105

100106 c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now

101107

@@ -106,11 +112,11 @@ run = mdo

106112 unitResponse <- getUnit $ tag (current reqCount) unitBtn

107113 intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn

108114

109− score <- foldDyn (+) 0 (fmapMaybe reqSuccess intResponse)

115+ score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))

110116

111− r <- holdDyn "Waiting" $ showXhrResponse <$>

112− leftmost [fmapMaybe response unitResponse

113− ,fmapMaybe response intResponse

117+ r <- holdDyn "Waiting" $ fmap showXhrResponse $

118+ leftmost [fmapMaybe response (unitResponse)

119+ ,fmapMaybe response (intResponse)

114120 ]

115121 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score

116122 return (unitBtn, intBtn)

@@ -119,14 +125,14 @@ run = mdo

119125

120126 text "Name"

121127 el "br" $ return ()

122− inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ textInput def

128+ inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ (textInput def)

123129 let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp

124130 el "br" $ return ()

125131

126132 text "Greetings (space-separated)"

127133 el "br" $ return ()

128134 greetings <- fmap (fmap T.words . value) $

129− divClass "greetings-input" $ textInput def

135+ divClass "greetings-input" $ (textInput def)

130136

131137 el "br" $ return ()

132138

@@ -138,23 +144,23 @@ run = mdo

138144

139145 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)

140146 divClass "greeting-response" $ dynText =<<

141− holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess resp

142− , fmapMaybe reqFailure resp])

147+ holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)

148+ , fmapMaybe reqFailure (resp)])

143149 return sayHiClicks

144150

145151 dblBtn <- elClass "div" "demo-group" $ do

146152 text "A Double to double"

147153 el "br" $ return ()

148154 dblinp <- fmap value $ divClass "double-input" $ textInput def

149− dblBtn <- divClass "double-button" $ button "Double it"

150− dblResp <- dbl ((note "read failure" . readMaybe . T.unpack) <$>

155+ (dblBtn) <- divClass "double-button" $ button "Double it"

156+ dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $

151157 dblinp) (tag (current reqCount) dblBtn)

152158 divClass "double-errors" $ dynText =<<

153− holdDyn "(no errors)" (fmapMaybe reqFailure dblResp)

159+ holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))

154160 el "br" (return ())

155161 divClass "double-result" $ el "p" $ dynText =<<

156− holdDyn "No number yet" (tShow <$>

157− fmapMaybe reqSuccess dblResp)

162+ holdDyn "No number yet" (fmap tShow $

163+ fmapMaybe reqSuccess (dblResp))

158164 return dblBtn

159165

160166 mpGo <- elClass "div" "demo-group" $ do

@@ -162,9 +168,9 @@ run = mdo

162168 b <- value <$> checkbox False def

163169 mpGo <- button "Test"

164170 multiResp <- multi b (tag (current reqCount) mpGo)

165− dynText =<< holdDyn "No res yet" (tShow <$>

166− fmapMaybe reqSuccess

167− multiResp)

171+ dynText =<< holdDyn "No res yet" (fmap tShow $

172+ fmapMaybe reqSuccess $

173+ (multiResp))

168174 return mpGo

169175

170176 return ()

@@ -174,12 +180,24 @@ run = mdo

174180 elClass "div" "demo-group" $ do

175181 text "JSON Unicode encoding test"

176182 txt <- value <$> textInput def

177− ev <- (1 <$) <$> button "Question"

183+ ev <- fmap (1 <$) $ button "Question"

178184 let dQ = Right . Question <$> traceDyn "will send: " txt

179185 rr <- qna dQ ev

180186 el "p" $

181187 dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)

182188

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+

183201showXhrResponse :: XhrResponse -> Text

184202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

185203 T.unlines ["stat: " <> tShow stat

exec/TupleExample.hsdeleted−35

@@ -1,35 +0,0 @@

1−{-# LANGUAGE RankNTypes #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE OverloadedStrings #-}

5−{-# LANGUAGE TypeOperators #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE TypeApplications #-}

8−

9−module TupleExample where

10−

11−import Data.Aeson

12−import Data.Proxy

13−import Data.Text

14−import GHC.TypeLits

15−import Reflex.Dom

16−import Servant.API

17−import Servant.Reflex.Tuple

18−

19−type TestAPI = Get '[JSON] Int

20− -- :<|> Post '[JSON] Int

21− :<|> Capture "name" Text :> Post '[JSON] Text

22−

23−

24−run :: forall t m. (SupportsServantReflex t m, MonadWidget t m) => m ()

25−run = do

26− let (getInt :<|> greet) = client (Proxy @TestAPI) (Proxy @m) (BasePath "/")

27− -- let getInt = client (Proxy @TestAPI) (Proxy @m) (BasePath "/")

28− b <- button "Go for it"

29− g <- ("greg" <$) <$> button "Hello"

30− -- g <- button "Hello"

31− b' <- getInt b

32− display =<< holdDyn (Left "Waiting") b'

33− g' <- greet g

34− display =<< holdDyn (Left "Waiting") g'

35−

nix/nix.confnew file+3

@@ -0,0 +1,3 @@

1+substituters = https://cache.nixos.org/ https://nixcache.reflex-frp.org/

2+trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=

3+trusted-users = travis

nix/reflex-platform.nixnew file+7

@@ -0,0 +1,7 @@

1+let

2+ rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;

3+in import (builtins.fetchTarball

4+ {

5+ url = "https://github.com/reflex-frp/reflex-platform/archive/${rev}.tar.gz";

6+ sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;

7+ }) {}

nix/servant-snap.nixnew file+7

@@ -0,0 +1,7 @@

1+# Servant-snap is marked broken in nixpkgs

2+{ nixpkgs ? import <nixpkgs> {}}: self: super:

3+self.callCabal2nix "servant-snap" (nixpkgs.fetchgit {

4+ url = "https://github.com/haskell-servant/servant-snap.git";

5+ rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";

6+ sha256 = "sha256-fzzQGwG8Ko72OO/kwLMG52eNZSt3F2dxhNgM9gaO4yQ=";

7+}) {}

nix/testresults.nixnew file+17

@@ -0,0 +1,17 @@

1+{ curl, reflexPlatform, testdriver, testserver, phantomjs }:

3+reflexPlatform.nixpkgs.pkgs.runCommand "runWebdriveTest.sh" {} ''

4+ echo About to phantom

5+ ${phantomjs}/bin/phantomjs --webdriver=127.0.0.1:4444 &

6+ sleep 3

7+ echo About to Server

8+ STATIC_DIR=${testserver}/static ${testserver}/back -q --no-access-log --no-error-log -p 8000 &

9+ sleep 3

10+ ${curl}/bin/curl localhost:8000

11+ ${curl}/bin/curl localhost:8000/runmain.js

12+ echo About to testdrive

13+ ${testdriver}/bin/spec > $out 2>&1

14+ echo Done

15+ trap "exit" INT TERM

16+ trap "kill 0" EXIT

17+ ''

nix/testserver.nixnew file+9

@@ -0,0 +1,9 @@

1+servant-reflex: self: super:

3+(self.callCabal2nix "testserver" ../testserver {}).overrideDerivation (drv: {

4+ postInstall = ''

5+ cp dist/build/back/back $out/back

6+ mkdir $out/static

7+ cp ${servant-reflex}/bin/example.jsexe/* $out/static/

8+ '';

9+})

overrides-ghc.nixdeleted−11

@@ -1,11 +0,0 @@

1−{ reflex-platform, ... }:

2−let

3− c2n = reflex-platform.cabal2nixResult;

4− dc = reflex-platform.lib.dontCheck;

5−in reflex-platform.ghc.override {

6− overrides = self: super: {

7− servant-snap = dc (self.callPackage (c2n deps/servant-snap) {});

8− heist = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});

9− xmlhtml = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});

10− };

11−}

overrides.nixdeleted−9

@@ -1,9 +0,0 @@

1−{ reflex-platform, ... }:

2−let

3− dc = reflex-platform.lib.dontCheck;

4− c2n = reflex-platform.cabal2nixResult;

5−in

6−reflex-platform.ghcjs.override {

7− overrides = self: super: {

8− };

9−}

servant-reflex.cabal+26−20

@@ -1,8 +1,8 @@

11Name: servant-reflex

2−Version: 0.3.1

3−Synopsis: Servant reflex API generator

4−Description: Servant reflex API generator

5−License: AllRightsReserved

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

66License-file: LICENSE.md

77Author: Greg Hale, Doug Beardsley

88Maintainer: imalsogreg@gmail.com

@@ -17,37 +17,35 @@ Flag Example

1717

1818library

1919 exposed-modules:

20− Servant.Reflex

21− Servant.Reflex.Multi

22− Servant.Reflex.Tuple

23−

24− other-modules:

2520 Servant.Common.BaseUrl

2621 Servant.Common.Req

22+ Servant.Reflex

23+ Servant.Reflex.Multi

2724

2825 hs-source-dirs: src

2926 build-depends:

30− base >= 4.8 && < 4.10,

27+ base >= 4.8 && < 5,

3128 bytestring >= 0.10 && < 0.11,

3229 case-insensitive >= 1.2.0.4 && < 1.3,

33− containers >= 0.5.6 && < 0.6,

30+ containers >= 0.5.6 && < 0.7,

3431 data-default >= 0.5 && < 0.8,

35− exceptions >= 0.8 && < 0.9,

32+ exceptions >= 0.8 && < 0.11,

3633 ghcjs-dom >= 0.2 && < 0.10,

37− http-api-data >= 0.2 && < 0.4,

38− http-media >= 0.6 && < 0.7,

34+ http-api-data >= 0.3.6 && < 0.5,

35+ http-media >= 0.6 && < 0.9,

3936 jsaddle >= 0.8 && < 0.10,

4037 mtl >= 2.2.1 && < 2.3,

4138 network-uri >= 2.6 && < 2.7,

42− reflex >= 0.5 && < 0.6,

43− reflex-dom == 0.4 && < 0.5,

39+ reflex >= 0.5 && < 0.9,

40+ reflex-dom-core >= 0.6 && < 0.8,

4441 safe >= 0.3.9 && < 0.4,

45− servant >= 0.8 && < 0.11,

42+ servant >= 0.16 && < 0.19,

43+ servant-auth >= 0.2.1 && < 0.4,

4644 string-conversions >= 0.4 && < 0.5,

4745 text >= 1.2 && < 1.3,

4846 transformers >= 0.4 && < 0.6

4947

50− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

48+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields

5149

5250 default-language: Haskell2010

5351

@@ -56,9 +54,17 @@ executable example

5654 buildable: True

5755 else

5856 buildable: False

59− build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text

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

6067 default-language: Haskell2010

6168 main-is: Example.hs

6269 other-modules: API

63− TupleExample

6470 hs-source-dirs: exec

shell.nixnew file+1

@@ -0,0 +1 @@

1+(import ./travis.nix {nativeCompiler = "ghc";}).ghcPkgs.servant-reflex.env

src/Servant/Common/BaseUrl.hs+10−7

@@ -1,4 +1,5 @@

11{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE CPP #-}

23{-# LANGUAGE DeriveDataTypeable #-}

34{-# LANGUAGE DeriveGeneric #-}

45{-# LANGUAGE FlexibleContexts #-}

@@ -28,11 +29,14 @@ import qualified Data.Text as T

2829import GHC.Generics

2930import Language.Javascript.JSaddle.Monad (MonadJSM)

3031import Reflex

31−import Reflex.Dom

32+import Reflex.Dom.Core

3233import Text.Read

3334

34−

35+#if !MIN_VERSION_reflex_dom_core(0,7,0)

3536type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadJSM (Performable m))

37+#else

38+type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, MonadJSM (Performable m))

39+#endif

3640

3741-- | URI scheme to use

3842data Scheme =

@@ -85,15 +89,14 @@ baseUrlWidget = elClass "div" "base-url" $ do

8589 where pathWidget :: m (Dynamic t BaseUrl)

8690 pathWidget = do

8791 text "Url base path"

88− t <- textInput (def {_textInputConfig_attributes =

89− constDyn ("placeholder" =: "/a/b")})

92+ t <- inputElement def

9093 return $ BasePath <$> value t

9194 fullUrlWidget :: m (Dynamic t BaseUrl)

9295 fullUrlWidget = do

9396 schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def

94− srv <- textInput def {_textInputConfig_attributes = constDyn $ "placeholder" =: "example.com"}

97+ srv <- inputElement def

9598 text ":"

96− prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}

99+ prt <- inputElement def

97100 port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))

98− path <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "a/b" }

101+ path <- inputElement def

99102 return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path

src/Servant/Common/Req.hs+114−305

@@ -4,18 +4,22 @@

44{-# LANGUAGE GADTs #-}

55{-# LANGUAGE OverloadedStrings #-}

66{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE RankNTypes #-}

78{-# LANGUAGE ScopedTypeVariables #-}

89{-# LANGUAGE TupleSections #-}

910

1011module Servant.Common.Req where

1112

1213-------------------------------------------------------------------------------

13−import Control.Concurrent

1414import Control.Applicative (liftA2, liftA3)

15+import Control.Arrow ((&&&))

16+import Control.Concurrent

1517import Control.Monad (join)

1618import Control.Monad.IO.Class (MonadIO, liftIO)

1719import Data.Bifunctor (first)

20+import qualified Data.ByteString.Builder as Builder

1821import qualified Data.ByteString.Lazy.Char8 as BL

22+import Data.ByteString (ByteString)

1923import qualified Data.Map as Map

2024import Data.Maybe (catMaybes, fromMaybe)

2125import Data.Functor.Compose

@@ -26,8 +30,8 @@ import qualified Data.Text as T

2630import qualified Data.Text.Encoding as TE

2731import Data.Traversable (forM)

2832import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)

29−import Reflex.Dom hiding (tag)

30−import Reflex.Dom.Xhr (newXMLHttpRequest)

33+import qualified Network.URI as N

34+import Reflex.Dom.Core hiding (tag)

3135import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,

3236 SupportsServantReflex)

3337import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))

@@ -48,6 +52,23 @@ data ReqResult tag a

4852 -- ^ A failure to construct the request tagged with 'tag' at trigger time

4953 deriving (Functor)

5054

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'

5172

5273------------------------------------------------------------------------------

5374-- | Simple filter/accessor for successful responses, when you want to

@@ -72,6 +93,13 @@ reqFailure (ResponseFailure _ s _) = Just s

7293reqFailure (RequestFailure _ s) = Just s

7394reqFailure _ = Nothing

7495

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+

75103

76104------------------------------------------------------------------------------

77105-- | Simple filter/accessor for the raw XHR response

@@ -109,10 +137,6 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))

109137 | QueryPartParams (Dynamic t [Text])

110138 | QueryPartFlag (Dynamic t Bool)

111139

112−data QueryPartIO = QueryPartParamIO (Maybe Text)

113− | QueryPartParamsIO [Text]

114− | QueryPartFlagIO Bool

115−

116140

117141-------------------------------------------------------------------------------

118142-- The data structure used to build up request information while traversing

@@ -127,38 +151,16 @@ data Req t = Req

127151 , authData :: Maybe (Dynamic t (Maybe BasicAuthData))

128152 }

129153

130−data ReqIO = ReqIO

131− { reqMethodIO :: Text

132− , reqPathPartsIO :: [Text]

133− , qParamsIO :: [(Text, QueryPartIO)]

134− , reqBodyIO :: Maybe (BL.ByteString, Text)

135− , headersIO :: [(Text, Text)]

136− , respHeadersIO :: XhrResponseHeaders

137− , authDataIO :: Maybe BasicAuthData

138− }

139−

140154defReq :: Req t

141155defReq = Req "GET" [] [] Nothing [] def Nothing

142156

143−defReqIO :: ReqIO

144−defReqIO = ReqIO "GET" [] [] Nothing [] def Nothing

145−

146157prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t

147158prependToPathParts p req =

148159 req { reqPathParts = p : reqPathParts req }

149160

150−

151161addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t

152162addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }

153163

154−prependToPathPartsIO :: Text -> ReqIO -> ReqIO

155−prependToPathPartsIO p req =

156− req { reqPathPartsIO = p : reqPathPartsIO req }

157−

158−addHeaderIO :: (ToHttpApiData a) => Text -> a -> ReqIO -> ReqIO

159−addHeaderIO name val req = req { headersIO = (name, (TE.decodeUtf8 . toHeader) val) : headersIO req }

160−

161−

162164

163165reqToReflexRequest

164166 :: forall t. Reflex t

@@ -177,18 +179,22 @@ reqToReflexRequest reqMeth reqHost req =

177179 urlParts = fmap sequence t

178180

179181 urlPath :: Dynamic t (Either Text Text)

180− urlPath = (fmap.fmap) (T.intercalate "/") urlParts

182+ urlPath = (fmap.fmap)

183+ (T.intercalate "/" . fmap escape)

184+ urlParts

181185

182186 queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))

183187 queryPartString (pName, qp) = case qp of

184188 QueryPartParam p -> ffor p $ \case

185189 Left e -> Just (Left e)

186− Right (Just a) -> Just (Right $ pName <> "=" <> a)

190+ Right (Just a) -> Just (Right $ pName <> "=" <> escape a)

187191 Right Nothing -> Nothing

188192 QueryPartParams ps -> ffor ps $ \pStrings ->

189193 if null pStrings

190194 then Nothing

191− else Just $ Right (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) pStrings))

195+ else Just . Right

196+ . T.intercalate "&"

197+ $ fmap (\p -> pName <> "=" <> escape p) pStrings

192198 QueryPartFlag fl -> ffor fl $ \case

193199 True -> Just $ Right pName

194200 False -> Nothing

@@ -196,9 +202,7 @@ reqToReflexRequest reqMeth reqHost req =

196202

197203 queryPartStrings :: [Dynamic t (Maybe (Either Text Text))]

198204 queryPartStrings = map queryPartString (qParams req)

199−

200− queryPartStrings' :: Dynamic t (Either Text [Text])

201− queryPartStrings' = sequence . catMaybes <$> sequence queryPartStrings :: Dynamic t (Either Text [Text])

205+ queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Dynamic t (Either Text [Text])

202206 queryString :: Dynamic t (Either Text Text) =

203207 ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs

204208 xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q)

@@ -212,23 +216,23 @@ reqToReflexRequest reqMeth reqHost req =

212216 xhrHeaders :: Dynamic t (Either Text [(Text, Text)])

213217 xhrHeaders = (fmap sequence . sequence . fmap f . headers) req

214218 where

215− f (headerName, dynam) =

219+ f = \(headerName, dynam) ->

216220 fmap (fmap (\rightVal -> (headerName, rightVal))) dynam

217221

218222 mkConfigBody :: Either Text [(Text,Text)]

219− -> Either Text (BL.ByteString, Text)

223+ -> (Either Text (BL.ByteString, Text))

220224 -> Either Text (XhrRequestConfig XhrPayload)

221225 mkConfigBody ehs rb = case (ehs, rb) of

222226 (_, Left e) -> Left e

223227 (Left e, _) -> Left e

224228 (Right hs, Right (bBytes, bCT)) ->

225− Right XhrRequestConfig

229+ Right $ XhrRequestConfig

226230 { _xhrRequestConfig_sendData = bytesToPayload bBytes

227231 , _xhrRequestConfig_headers =

228− Map.insert "Content-Type" bCT (Map.fromList hs)

232+ Map.insert "Content-Type" bCT (Map.fromList hs)

229233 , _xhrRequestConfig_user = Nothing

230234 , _xhrRequestConfig_password = Nothing

231− , _xhrRequestConfig_responseType = Nothing

235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

232236 , _xhrRequestConfig_withCredentials = False

233237 , _xhrRequestConfig_responseHeaders = def

234238 }

@@ -240,8 +244,8 @@ reqToReflexRequest reqMeth reqHost req =

240244 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs

241245 , _xhrRequestConfig_user = Nothing

242246 , _xhrRequestConfig_password = Nothing

243− , _xhrRequestConfig_responseType = Nothing

244− , _xhrRequestConfig_sendData = ""

247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

248+ , _xhrRequestConfig_sendData = mempty

245249 , _xhrRequestConfig_withCredentials = False

246250 }

247251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

@@ -259,255 +263,84 @@ reqToReflexRequest reqMeth reqHost req =

259263 Nothing -> xhr

260264 Just auth -> liftA2 mkAuth auth xhr

261265

262− xhrReq = (liftA2 . liftA2) (XhrRequest reqMeth) xhrUrl (addAuth xhrOpts)

266+ xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)

263267

264268 in xhrReq

265269

266−reqToReflexRequestIO

267− :: Text

268− -> BaseUrl

269− -> ReqIO

270− -> XhrRequest XhrPayload

271−reqToReflexRequestIO reqMeth reqHost req =

272− let t :: [Text]

273− t = reverse $ reqPathPartsIO req

274−

275− baseUrl :: Text

276− baseUrl = showBaseUrl reqHost

277−

278− urlParts :: [Text]

279− urlParts = t

280−

281− urlPath :: Text

282− urlPath = T.intercalate "/" urlParts

283−

284− queryPartString :: (Text, QueryPartIO) -> Maybe Text

285− queryPartString (pName, qp) = case qp of

286− QueryPartParamIO p -> case p of

287− Just a -> Just (pName <> "=" <> a)

288− _ -> Nothing

289− QueryPartParamsIO ps ->

290− if null ps

291− then Nothing

292− else Just (T.intercalate "&" (fmap (\p -> pName <> "=" <> p) ps))

293− QueryPartFlagIO fl -> if fl

294− then Just pName

295− else Nothing

296−

297−

298− queryPartStrings :: [Maybe Text]

299− queryPartStrings = map queryPartString (qParamsIO req)

300−

301− queryPartStrings' :: [Text]

302− queryPartStrings' = catMaybes queryPartStrings

303−

304− queryString :: Text = T.intercalate "&" queryPartStrings'

305−

306− xhrUrl = (\a p q -> a </> if T.null q then p else p <> "?" <> q)

307− baseUrl urlPath queryString

308− where

309− (</>) :: Text -> Text -> Text

310− x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y

311− | otherwise = x <> "/" <> y

312−

313−

314− xhrHeaders :: [(Text, Text)]

315− xhrHeaders = headersIO req

316−

317− mkConfigBody :: [(Text,Text)]

318− -> (BL.ByteString, Text)

319− -> XhrRequestConfig XhrPayload

320− mkConfigBody hs (bBytes, bCT) =

321− XhrRequestConfig

322− { _xhrRequestConfig_sendData = bytesToPayload bBytes

323− , _xhrRequestConfig_headers =

324− Map.insert "Content-Type" bCT (Map.fromList hs)

325− , _xhrRequestConfig_user = Nothing

326− , _xhrRequestConfig_password = Nothing

327− , _xhrRequestConfig_responseType = Nothing

328− , _xhrRequestConfig_withCredentials = False

329− , _xhrRequestConfig_responseHeaders = def

330− }

331−

332− xhrOpts :: XhrRequestConfig XhrPayload

333− xhrOpts = case reqBodyIO req of

334− Nothing -> def { _xhrRequestConfig_headers = Map.fromList xhrHeaders

335− , _xhrRequestConfig_user = Nothing

336− , _xhrRequestConfig_password = Nothing

337− , _xhrRequestConfig_responseType = Nothing

338− , _xhrRequestConfig_sendData = ""

339− , _xhrRequestConfig_withCredentials = False

340− }

341− Just rBody -> mkConfigBody xhrHeaders rBody

342−

343− mkAuth :: BasicAuthData -> XhrRequestConfig x -> XhrRequestConfig x

344− mkAuth (BasicAuthData u p) config = config

345− { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u

346− , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}

347−

348− addAuth :: XhrRequestConfig x

349− -> XhrRequestConfig x

350− addAuth xhr = case authDataIO req of

351− Nothing -> xhr

352− Just auth -> mkAuth auth xhr

353−

354− xhrReq = (XhrRequest reqMeth) xhrUrl (addAuth xhrOpts)

355−

356− in xhrReq

357−

358−

359270-- * performing requests

360271

361272displayHttpRequest :: Text -> Text

362273displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

363274

364−-- | This function actually performs the request.

275+-- | This function performs the request

365276performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)

366277 => Text

367278 -> Dynamic t (f (Req t))

368279 -> Dynamic t BaseUrl

280+ -> ClientOptions

369281 -> Event t tag

370282 -> m (Event t (tag, f (Either Text XhrResponse)))

371−performRequests reqMeth rs reqHost trigger = do

372− -- let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))

373− let xhrReqs = join $ (\(fxhr :: f (Req t)) -> sequence $ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs

374− let reqs = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger

375− resps <- performSomeRequestsAsync reqs

376− return $ getCompose <$> resps

283+performRequests reqMeth rs reqHost opts trigger = do

284+ let xhrReqs =

285+ join $ (\(fxhr :: f (Req t)) -> sequence $

286+ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs

377287

288+ -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

289+ reqs = attachPromptlyDynWith

290+ (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger

378291

379−performRequestsIO :: forall t m f tag.(SupportsServantReflex t m, Traversable f)

380− => Text

381− -> Event t (f ReqIO)

382− -> BaseUrl

383− -> m (Event t (f XhrResponse))

384−performRequestsIO reqMeth rs reqHost = do

385− -- let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))

386− -- let xhrReqs = join $ (\(fxhr :: f (Req t)) -> sequence $ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs

387− let xhrReqs :: (Event t (f (XhrRequest XhrPayload))) = fmap (reqToReflexRequestIO reqMeth reqHost) <$> rs

388− -- let reqs = attachPromptlyDynWith (\fxhr t -> fxhr) xhrReqs trigger

389− resps <- performRequestsAsync xhrReqs

390− return $ resps

391−

392−

393−-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.

292+ resps <- performSomeRequestsAsync opts reqs

293+ return $ getCompose <$> resps

294+

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.

394298performSomeRequestsAsync

395− :: (MonadJSM (Performable m),

299+ :: (MonadIO (Performable m),

396300 MonadJSM (Performable m),

301+#if !MIN_VERSION_reflex_dom_core(0,7,0)

397302 HasWebView (Performable m),

303+#endif

398304 PerformEvent t m,

399305 TriggerEvent t m,

400306 Traversable f,

401− IsXhrPayload a)

402− => Event t (f (Either Text (XhrRequest a)))

307+ IsXhrPayload a,

308+ Show a

309+ )

310+ => ClientOptions

311+ -> Event t (f (Either Text (XhrRequest a)))

403312 -> m (Event t (f (Either Text XhrResponse)))

404−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return

313+performSomeRequestsAsync opts =

314+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

405315

406316

407317------------------------------------------------------------------------------

408318-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync

409−-- that accepts 'f (Either e (XhrRequest))' events

319+-- that accepts 'f (Either e (XhrRequestb))' events

410320performSomeRequestsAsync'

411− :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)

412− => (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)

321+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)

322+ => ClientOptions

323+ -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)

413324 -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))

414−performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do

325+performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do

415326 rs <- hrs

416327 resps <- forM rs $ \r -> case r of

417− Left e -> liftIO $ newMVar (Left e)

418−

328+ Left e -> do

329+ resp <- liftIO $ newMVar (Left e)

330+ return resp

419331 Right r' -> do

420332 resp <- liftIO newEmptyMVar

421− _ <- newXhr r' $ liftIO . putMVar resp . Right

333+ r'' <- liftJSM $ (optsRequestFixup opts) r'

334+ _ <- newXhr r'' $ liftIO . putMVar resp . Right

422335 return resp

423336 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar

424337 return ()

425338

426339

427340

428−-- | This function actually performs the request.

429−performRequest :: forall t m tag .(SupportsServantReflex t m)

430− => Text

431− -> Req t

432− -> Dynamic t BaseUrl

433− -> Event t tag

434− -> m (Event t (tag, XhrResponse), Event t (tag, Text))

435−performRequest reqMeth req reqHost trigger = do

436−

437− let xhrReq = reqToReflexRequest reqMeth reqHost req

438− let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger

439− okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) e) reqs

440− badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) e) reqs

441−

442− resps <- performRequestsAsync okReqs

443−

444− return (resps, badReqs)

445−

446−

447−-- -- | This function actually performs the request.

448−-- performRequestIO :: forall t m tag. (SupportsServantReflex t m)

449−-- => Text

450−-- -> ReqIO

451−-- -> BaseUrl

452−-- -> tag

453−-- -> m (Either (tag, XhrResponse) (tag, Text))

454−-- performRequestIO reqMeth req reqHost trigger = do

455−

456−-- let xhrReq = reqToReflexRequestIO reqMeth reqHost req

457−-- let reqs = (trigger ,xhrReq )

458−

459−-- -- resps <- performRequestsAsync okReqs

460−

461−-- -- let x :: _ = newXMLHttpRequestWithError

462−

463−-- -- return (resps, badReqs)

464−-- undefined

465−

466−-- doThing :: (IsXhrPayload a, MonadJSM m, HasJSContext m) => XhrRequest a -> m XhrResponse

467−-- doThing req = do

468−-- v <- liftIO newEmptyMVar

469−-- r <- newXMLHttpRequest req (liftIO . putMVar v)

470−-- liftIO $ takeMVar v

471−

472−

473−type XhrPayload = T.Text

341+type XhrPayload = ByteString

474342bytesToPayload :: BL.ByteString -> XhrPayload

475−bytesToPayload = TE.decodeUtf8 . BL.toStrict

476−

477−

478−-- performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)

479−-- => Text

480−-- -> Req t

481−-- -> Dynamic t BaseUrl

482−-- -> Event t tag -> m (Event t (ReqResult tag NoContent))

483−-- performRequestNoBody reqMeth req reqHost trigger = do

484−-- (resp, badReq) <- performRequest reqMeth req reqHost trigger

485−-- let decodeResp = const $ Right NoContent

486−-- return $ leftmost [ fmap (evalResponse decodeResp) resp

487−-- , fmap (uncurry RequestFailure) badReq

488−-- ]

489−

490−

491−-- performRequestCT

492−-- :: (SupportsServantReflex t m,

493−-- MimeUnrender ct a)

494−-- => Proxy ct

495−-- -> Text

496−-- -> Req t

497−-- -> Dynamic t BaseUrl

498−-- -> Event t tag

499−-- -> m (Event t (ReqResult tag a))

500−-- performRequestCT ct reqMeth req reqHost trigger = do

501−-- (resp, badReq) <- performRequest reqMeth req reqHost trigger

502−-- let decodeResp x = first T.pack .

503−-- mimeUnrender ct .

504−-- BL.fromStrict .

505−-- TE.encodeUtf8 =<< note "No body text"

506−-- (_xhrResponse_responseText x)

507−

508−-- return $ leftmost [fmap (evalResponse decodeResp) resp

509−-- , fmap (uncurry RequestFailure) badReq

510−-- ]

343+bytesToPayload = BL.toStrict

511344

512345

513346performRequestsCT

@@ -517,57 +350,35 @@ performRequestsCT

517350 -> Text

518351 -> Dynamic t (f (Req t))

519352 -> Dynamic t BaseUrl

353+ -> ClientOptions

520354 -> Event t tag

521355 -> m (Event t (f (ReqResult tag a)))

522−performRequestsCT ct reqMeth reqs reqHost trigger = do

523− resps <- performRequests reqMeth reqs reqHost trigger

524− let decodeResp x = first T.pack .

525− mimeUnrender ct .

526− BL.fromStrict .

527− TE.encodeUtf8 =<< note "No body text"

528− (_xhrResponse_responseText x)

356+performRequestsCT ct reqMeth reqs reqHost opts trigger = do

357+ resps <- performRequests reqMeth reqs reqHost opts trigger

358+ let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =

359+ first T.pack .

360+ mimeUnrender ct $

361+ BL.fromStrict x

362+ decodeResp _ = Left "No body"

529363 return $ fmap

530364 (\(t,rs) -> ffor rs $ \r -> case r of

531365 Left e -> RequestFailure t e

532− Right g -> evalResponse decodeResp (t,g)

366+ Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)

533367 )

534368 resps

535369

536370

537−performRequestsCTIO

538− :: (SupportsServantReflex t m,

539− MimeUnrender ct a, Traversable f)

540− => Proxy ct

541− -> Text

542− -> Event t (f ReqIO)

543− -> BaseUrl

544− -> m (Event t (f (Either Text a)))

545−performRequestsCTIO ct reqMeth reqs reqHost = do

546− resps <- performRequestsIO reqMeth reqs reqHost

547− let decodeResp x = first T.pack .

548− mimeUnrender ct .

549− BL.fromStrict .

550− TE.encodeUtf8 =<< note "No body text"

551− (_xhrResponse_responseText x)

552− return $ fmap (fmap decodeResp) resps

553− -- return $ fmap

554− -- (\(t,rs) -> ffor rs $ \r -> case r of

555− -- Left e -> RequestFailure t e

556− -- Right g -> evalResponse decodeResp (t,g)

557− -- )

558− -- resps

559−

560−

561371performRequestsNoBody

562372 :: (SupportsServantReflex t m,

563373 Traversable f)

564374 => Text

565375 -> Dynamic t (f (Req t))

566376 -> Dynamic t BaseUrl

377+ -> ClientOptions

567378 -> Event t tag

568379 -> m (Event t (f (ReqResult tag NoContent)))

569−performRequestsNoBody reqMeth reqs reqHost trigger = do

570− resps <- performRequests reqMeth reqs reqHost trigger

380+performRequestsNoBody reqMeth reqs reqHost opts trigger = do

381+ resps <- performRequests reqMeth reqs reqHost opts trigger

571382 let decodeResp = const $ Right NoContent

572383 return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of

573384 Left e -> RequestFailure tag e

@@ -580,7 +391,8 @@ evalResponse

580391 -> (tag, XhrResponse)

581392 -> ReqResult tag a

582393evalResponse decode (tag, xhr) =

583− let okStatus = _xhrResponse_status xhr < 400

394+ let status = _xhrResponse_status xhr

395+ okStatus = status >= 200 && status < 400

584396 errMsg = fromMaybe

585397 ("Empty response with error code " <>

586398 T.pack (show $ _xhrResponse_status xhr))

@@ -593,26 +405,17 @@ evalResponse decode (tag, xhr) =

593405 else ResponseFailure tag errMsg xhr

594406 in respPayld

595407

596−-- ------------------------------------------------------------------------------

597−-- evalResponseIO

598−-- :: (XhrResponse -> Either Text a)

599−-- -> (XhrResponse)

600−-- -> ReqResult tag a

601−-- evalResponseIO decode (tag, xhr) =

602−-- let okStatus = _xhrResponse_status xhr < 400

603−-- errMsg = fromMaybe

604−-- ("Empty response with error code " <>

605−-- T.pack (show $ _xhrResponse_status xhr))

606−-- (_xhrResponse_responseText xhr)

607−-- respPayld = if okStatus

608−-- then either

609−-- (\e -> ResponseFailure tag e xhr)

610−-- (\v -> ResponseSuccess tag v xhr)

611−-- (decode xhr)

612−-- else ResponseFailure tag errMsg xhr

613−-- in respPayld

614−

408+------------------------------------------------------------------------------

409+-- | Utility for simultaneously accessing/filtering Success and Failure

410+-- response 'Event's,

411+fanReqResult :: Reflex t => Event t (ReqResult tag a) -> (Event t Text, Event t a)

412+fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess

615413

414+------------------------------------------------------------------------------

415+-- | Utility for simultaneously accessing/filtering Success and Failure

416+-- response 'Event's, but keeping the request tag

417+fanReqResult' :: Reflex t => Event t (ReqResult tag a) -> (Event t (tag, Text), Event t (tag, a))

418+fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'

616419

617420

618421note :: e -> Maybe a -> Either e a

@@ -621,3 +424,9 @@ note e = maybe (Left e) Right

621424fmapL :: (e -> e') -> Either e a -> Either e' a

622425fmapL _ (Right a) = Right a

623426fmapL f (Left e) = Left (f e)

427+

428+builderToText :: Builder.Builder -> T.Text

429+builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString

430+

431+escape :: T.Text -> T.Text

432+escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece

src/Servant/Reflex.hs+213−182

@@ -1,19 +1,23 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE FunctionalDependencies #-}

7−{-# LANGUAGE GADTs #-}

8−{-# LANGUAGE InstanceSigs #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE OverloadedStrings #-}

11−{-# LANGUAGE PolyKinds #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE TupleSections #-}

14−{-# LANGUAGE TypeFamilies #-}

15−{-# LANGUAGE TypeOperators #-}

16−{-# LANGUAGE UndecidableInstances #-}

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

1721

1822-- #include "overlapping-compat.h"

1923-- | This module provides 'client' which can automatically generate

@@ -21,56 +25,70 @@

2125-- API.

2226module Servant.Reflex

2327 ( client

28+ , clientWithOpts

29+ , clientWithOptsAndResultHandler

30+ , clientWithRoute

31+ , clientWithRouteAndResultHandler

2432 , BuildHeaderKeysTo(..)

2533 , toHeaders

26− , HasClient(..)

34+ , HasClient

35+ , Client

2736 , module Servant.Common.Req

2837 , module Servant.Common.BaseUrl

2938 ) where

3039

3140------------------------------------------------------------------------------

3241import Control.Applicative

33−import Data.CaseInsensitive (mk)

42+import qualified Data.CaseInsensitive as CI

3443import Data.Functor.Identity

35−import qualified Data.Map as Map

36−import Data.Monoid ((<>))

37−import Data.Proxy (Proxy (..))

38−import qualified Data.Set as Set

39−import Data.Text (Text)

40−import qualified Data.Text as T

41−import qualified Data.Text.Encoding as E

42−import GHC.TypeLits

43−import Servant.API ((:<|>) (..), (:>), BasicAuth,

44− BasicAuthData, BuildHeadersTo (..),

45− Capture, Header, Headers (..),

46− HttpVersion, IsSecure, MimeRender (..),

47− MimeUnrender, NoContent, QueryFlag,

48− QueryParam, QueryParams, Raw,

49− ReflectMethod (..), RemoteHost,

50− ReqBody, ToHttpApiData (..), Vault,

51− Verb, contentType)

52−

53−import Reflex.Dom (Dynamic, Event, Reflex,

54− XhrRequest (..), XhrResponse (..),

55− XhrResponseHeaders (..),

56− attachPromptlyDynWith, constDyn, ffor,

57− fmapMaybe, leftmost,

58− performRequestsAsync)

44+import qualified Data.Map as Map

45+import Data.Monoid ((<>))

46+import Data.Proxy (Proxy (..))

47+import qualified Data.Set as Set

48+import Data.Text (Text)

49+import qualified Data.Text as T

50+import qualified Data.Text.Encoding as E

51+import GHC.Exts (Constraint)

52+import GHC.TypeLits (KnownSymbol, symbolVal)

53+import Servant.API ((:<|>) (..), (:>), BasicAuth,

54+ BasicAuthData, BuildHeadersTo (..),

55+ Capture, Header, Headers (..),

56+ HttpVersion, IsSecure,

57+ MimeRender (..), MimeUnrender,

58+ NoContent, QueryFlag, QueryParam',

59+ QueryParams, Raw, ReflectMethod (..),

60+ RemoteHost, ReqBody,

61+ ToHttpApiData (..), Vault, Verb,

62+ contentType)

63+import Servant.API.Description (Summary)

64+import qualified Servant.Auth as Auth

65+

66+import Reflex.Dom.Core (Dynamic, Event, Reflex,

67+ XhrRequest (..), XhrResponse (..),

68+ XhrResponseHeaders (..),

69+ attachPromptlyDynWith, constDyn, ffor,

70+ fmapMaybe, leftmost,

71+ performRequestsAsync)

5972------------------------------------------------------------------------------

60−import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),

61− SupportsServantReflex, baseUrlWidget,

62− showBaseUrl)

63−import Servant.Common.Req (QParam (..), QueryPart (..), Req,

64− ReqIO(..), ReqResult (..), addHeader, addHeaderIO,

65− authData, defReq, evalResponse,

66− performRequestsCT,

67− performRequestsCTIO,

68− performRequestsNoBody,

69− performSomeRequestsAsync,

70− prependToPathParts, prependToPathPartsIO, qParamToQueryPart,

71− qParams, reqBody, reqFailure,

72− reqMethod, reqSuccess, reqTag,

73− respHeaders, response)

73+import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,

74+ showBaseUrl,

75+ SupportsServantReflex)

76+import Servant.Common.Req (ClientOptions(..),

77+ defaultClientOptions,

78+ Req, ReqResult(..), QParam(..),

79+ QueryPart(..), addHeader, authData,

80+ defReq, evalResponse, prependToPathParts,

81+ -- performRequestCT,

82+ performRequestsCT,

83+ -- performRequestNoBody,

84+ performRequestsNoBody,

85+ performSomeRequestsAsync,

86+ qParamToQueryPart, reqBody,

87+ reqSuccess, reqFailure,

88+ reqMethod, respHeaders,

89+ response,

90+ reqTag,

91+ qParams, withCredentials)

7492

7593

7694-- * Accessing APIs as a Client

@@ -85,71 +103,75 @@ import Servant.Common.Req (QParam (..), QueryPart (..), Req,

85103-- >

86104-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))

87105-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l

88−-- -> m (Event t (l, ReqResult Book)))

106+-- > -> m (Event t (l, ReqResult Book)))

89107-- > (getAllBooks :<|> postNewBook) = client myApi host

90108-- > where host = constDyn $ BaseUrl Http "localhost" 8080

91−client :: (HasClient t m layout tag)

92− => Proxy layout -> Proxy m -> Proxy tag -> Dynamic t BaseUrl -> Client t m layout tag

93−client p q t = clientWithRoute p q t defReq

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

94141

95142

96143-- | This class lets us define how each API combinator

97144-- influences the creation of an HTTP request. It's mostly

98145-- an internal class, you can just use 'client'.

99−class HasClient t m layout (tag :: *) | m -> t where

146+class Monad m => HasClient t m layout (tag :: *) where

100147 type Client t m layout tag :: *

101− type ClientIO m layout tag :: *

102− type Inp m layout tag :: k

103148 clientWithRoute

104149 :: Proxy layout

105150 -> Proxy m

106151 -> Proxy tag

107152 -> Req t

108153 -> Dynamic t BaseUrl

154+ -> ClientOptions

109155 -> Client t m layout tag

110− clientWithRouteIO

156+ clientWithRoute l m t r b o = clientWithRouteAndResultHandler l m t r b o return

157+

158+ clientWithRouteAndResultHandler

111159 :: Proxy layout

112160 -> Proxy m

113161 -> Proxy tag

114− -> ReqIO

115− -> BaseUrl

116− -> ClientIO m layout tag

117−

118−data HList :: [*] -> * where

119− HNil :: HList '[]

120− HCons :: a -> HList xs -> HList (a ': xs)

121−

122−

123−type family ToTuple xs :: *

124−

125−type instance ToTuple (HList '[]) = ()

126−type instance ToTuple (HList (a ': '[])) = a

127−type instance ToTuple (HList (a ': b ': '[])) = (a,b)

128−type instance ToTuple (HList (a ': b ': c ': '[])) = (a,b,c)

129−type instance ToTuple (HList (a ': b ': c ': d ': '[])) = (a,b,c,d)

130−type instance ToTuple (HList (a ': b ': c ': d ': e ': '[])) = (a,b,c,d,e)

131−type instance ToTuple (HList (a ': b ': c ': d ': e ': f ': '[])) = (a,b,c,d,e,f)

132−

133−type instance ToTuple (a :> ()) = a

134−type instance ToTuple (a :> b :> ()) = (a,b)

135−type instance ToTuple (a :> b :> c :> ()) = (a,b,c)

136−type instance ToTuple (a :> b :> c :> d :> ()) = (a,b,c,d)

137−type instance ToTuple (a :> b :> c :> d :> e :> ()) = (a,b,c,d,e)

138−type instance ToTuple (a :> b :> c :> d :> e :> f :> ()) = (a,b,c,d,e,f)

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

139167

140168

141169instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where

142170 type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag

143− type Inp m (a :<|> b) tag = Inp m a tag :<|> Inp m b tag

144− type ClientIO m (a :<|> b) tag = ClientIO m a tag :<|> ClientIO m b tag

145171

146− clientWithRoute Proxy q pTag req baseurl =

147− clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>

148− clientWithRoute (Proxy :: Proxy b) q pTag req baseurl

149−

150− clientWithRouteIO Proxy q pTag req baseurl =

151− clientWithRouteIO (Proxy :: Proxy a) q pTag req baseurl :<|>

152− clientWithRouteIO (Proxy :: Proxy b) q pTag req baseurl

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

153175

154176

155177-- Capture. Example:

@@ -170,26 +192,10 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta

170192 type Client t m (Capture capture a :> sublayout) tag =

171193 Dynamic t (Either Text a) -> Client t m sublayout tag

172194

173− -- type ClientIO m (Capture capture a :> sublayout) tag =

174− -- ToTuple (Inp m (Capture capture a :> sublayout) -> ClientIO m sublayout tag

175−

176− -- type Inp m (Capture capture a :> sublayout) tag =

177− -- a :> Inp m sublayout tag

178−

179− clientWithRoute Proxy q t req baseurl val =

180− clientWithRoute (Proxy :: Proxy sublayout)

181− q t

182− (prependToPathParts p req)

183− baseurl

184− where p = (fmap . fmap) toUrlPiece val

185−

186− -- clientWithRouteIO Proxy q t req baseurl val =

187− -- clientWithRouteIO (Proxy :: Proxy sublayout)

188− -- q t

189− -- req

190− -- -- (prependToPathPartsIO p req)

191− -- baseurl

192− -- where p = toUrlPiece val

195+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =

196+ clientWithRouteAndResultHandler

197+ (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap

198+ where p = (fmap . fmap) (toUrlPiece) val

193199

194200

195201-- VERB (Returning content) --

@@ -197,26 +203,15 @@ instance {-# OVERLAPPABLE #-}

197203 -- Note [Non-Empty Content Types]

198204 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m

199205 ) => HasClient t m (Verb method status cts' a) tag where

200−

201206 type Client t m (Verb method status cts' a) tag =

202207 Event t tag -> m (Event t (ReqResult tag a))

203−

204− type ClientIO m (Verb method status cts' a) tag =

205− tag -> m (ReqResult tag a)

206−

207208 -- TODO how to access input types here?

208209 -- ExceptT ServantError IO a

209− clientWithRoute Proxy _ _ req baseurl trigs =

210− -- performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs

211− fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl trigs

210+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =

211+ wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs

212212 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

213213 req' = req { reqMethod = method }

214214

215− -- clientWithRouteIO Proxy _ _ req baseurl tag =

216− -- performRequestsCTIO (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl tag

217− -- where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

218− -- req' = req { reqMethodIO = method }

219−

220215

221216-- -- VERB (No content) --

222217instance {-# OVERLAPPING #-}

@@ -226,29 +221,33 @@ instance {-# OVERLAPPING #-}

226221 Event t tag -> m (Event t (ReqResult tag NoContent))

227222 -- TODO: how to access input types here?

228223 -- ExceptT ServantError IO NoContent

229− clientWithRoute Proxy _ _ req baseurl =

230− (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl

224+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =

225+ wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs

231226 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

232227

233228

234229toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)

235230toHeaders r =

236− let toBS = E.encodeUtf8

237− hdrs = maybe []

238− (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))

231+ let hdrs = maybe []

232+ (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))

239233 (Map.toList $ _xhrResponse_headers xhr))

240234 (response r)

241235 in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}

242236

237+

243238class BuildHeaderKeysTo hs where

244− buildHeaderKeysTo :: Proxy hs -> [T.Text]

239+ buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]

245240

246241instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]

247242 where buildHeaderKeysTo _ = []

248243

249244instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)

250245 => BuildHeaderKeysTo ((Header h v) ': xs) where

251− buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)

246+ buildHeaderKeysTo _ =

247+ let

248+ thisKey = CI.mk $ T.pack (symbolVal (Proxy :: Proxy h))

249+ in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)

250+

252251

253252-- HEADERS Verb (Content) --

254253-- Headers combinator not treated in fully general case,

@@ -263,10 +262,10 @@ instance {-# OVERLAPPABLE #-}

263262 ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where

264263 type Client t m (Verb method status cts' (Headers ls a)) tag =

265264 Event t tag -> m (Event t (ReqResult tag (Headers ls a)))

266− clientWithRoute Proxy _ _ req baseurl trigs = do

265+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do

267266 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

268− resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl trigs

269− return $ toHeaders <$> resp

267+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs

268+ wrap $ toHeaders <$> resp

270269 where req' = req { respHeaders =

271270 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))

272271 }

@@ -279,10 +278,10 @@ instance {-# OVERLAPPABLE #-}

279278 ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where

280279 type Client t m (Verb method status cts (Headers ls NoContent)) tag

281280 = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))

282− clientWithRoute Proxy _ _ req baseurl trigs = do

281+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do

283282 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

284− resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl trigs

285− return $ toHeaders <$> resp

283+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs

284+ wrap $ toHeaders <$> resp

286285 where req' = req {respHeaders =

287286 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))

288287 }

@@ -309,20 +308,13 @@ instance (KnownSymbol sym, ToHttpApiData a,

309308 type Client t m (Header sym a :> sublayout) tag =

310309 Dynamic t (Either Text a) -> Client t m sublayout tag

311310

312− clientWithRoute Proxy q t req baseurl eVal =

313− clientWithRoute (Proxy :: Proxy sublayout)

314− q t

315− (Servant.Common.Req.addHeader hname eVal req)

316− baseurl

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

317316 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)

318317

319− -- clientWithRouteIO Proxy q t req baseurl eVal =

320− -- clientWithRouteIO (Proxy :: Proxy sublayout)

321− -- q t

322− -- (Servant.Common.Req.addHeaderIO hname eVal req)

323− -- baseurl

324− -- where hname = T.pack $ symbolVal (Proxy :: Proxy sym)

325−

326318

327319

328320

@@ -334,8 +326,21 @@ instance HasClient t m sublayout tag

334326 type Client t m (HttpVersion :> sublayout) tag =

335327 Client t m sublayout tag

336328

337− clientWithRoute Proxy =

338− clientWithRoute (Proxy :: Proxy sublayout)

329+ clientWithRouteAndResultHandler Proxy =

330+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

331+

332+-- | Using a 'Summary' combinator in your API doesn't affect the client

333+-- functions.

334+instance (HasClient t m sublayout tag, KnownSymbol sym)

335+ => HasClient t m (Summary sym :> sublayout) tag where

336+

337+ type Client t m (Summary sym :> sublayout) tag =

338+ Client t m sublayout tag

339+

340+ clientWithRouteAndResultHandler Proxy =

341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

342+

343+

339344

340345

341346-- | If you use a 'QueryParam' in one of your endpoints in your API,

@@ -365,15 +370,15 @@ instance HasClient t m sublayout tag

365370-- > -- 'getBooksBy Nothing' for all books

366371-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov

367372instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)

368− => HasClient t m (QueryParam sym a :> sublayout) tag where

373+ => HasClient t m (QueryParam' mods sym a :> sublayout) tag where

369374

370− type Client t m (QueryParam sym a :> sublayout) tag =

375+ type Client t m (QueryParam' mods sym a :> sublayout) tag =

371376 Dynamic t (QParam a) -> Client t m sublayout tag

372377

373378 -- if mparam = Nothing, we don't add it to the query string

374− clientWithRoute Proxy q t req baseurl mparam =

375− clientWithRoute (Proxy :: Proxy sublayout) q t

376− (req {qParams = paramPair : qParams req}) baseurl

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

377382

378383 where pname = symbolVal (Proxy :: Proxy sym)

379384 --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm

@@ -417,8 +422,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex

417422 type Client t m (QueryParams sym a :> sublayout) tag =

418423 Dynamic t [a] -> Client t m sublayout tag

419424

420− clientWithRoute Proxy q t req baseurl paramlist =

421− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl

425+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =

426+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap

422427

423428 where req' = req { qParams = (T.pack pname, params') : qParams req }

424429 pname = symbolVal (Proxy :: Proxy sym)

@@ -457,8 +462,8 @@ instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)

457462 type Client t m (QueryFlag sym :> sublayout) tag =

458463 Dynamic t Bool -> Client t m sublayout tag

459464

460− clientWithRoute Proxy q t req baseurl flag =

461− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl

465+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =

466+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap

462467

463468 where req' = req { qParams = thisPair : qParams req }

464469 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)

@@ -472,7 +477,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where

472477 -> Event t tag

473478 -> m (Event t (ReqResult tag ()))

474479

475− clientWithRoute _ _ _ _ baseurl xhrs triggers = do

480+ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do

476481

477482 let xhrs' = liftA2 (\x path -> case x of

478483 Left e -> Left e

@@ -483,7 +488,7 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where

483488 okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())

484489

485490 resps <- performRequestsAsync okReq

486− return $ leftmost [ uncurry RequestFailure <$> badReq

491+ wrap $ leftmost [ uncurry RequestFailure <$> badReq

487492 , evalResponse (const $ Right ()) <$> resps

488493 ]

489494

@@ -514,8 +519,8 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)

514519 type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =

515520 Dynamic t (Either Text a) -> Client t m sublayout tag

516521

517− clientWithRoute Proxy q t req baseurl body =

518− clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl

522+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =

523+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap

519524 where req' = req { reqBody = bodyBytesCT }

520525 ctProxy = Proxy :: Proxy ct

521526 ctString = T.pack $ show $ contentType ctProxy

@@ -529,9 +534,9 @@ instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)

529534instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where

530535 type Client t m (path :> sublayout) tag = Client t m sublayout tag

531536

532− clientWithRoute Proxy q t req =

533− clientWithRoute (Proxy :: Proxy sublayout) q t

534− (prependToPathParts (pure (Right $ T.pack p)) req)

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

535540

536541 where p = symbolVal (Proxy :: Proxy path)

537542

@@ -539,23 +544,23 @@ instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient

539544instance HasClient t m api tag => HasClient t m (Vault :> api) tag where

540545 type Client t m (Vault :> api) tag = Client t m api tag

541546

542− clientWithRoute Proxy =

543− clientWithRoute (Proxy :: Proxy api)

547+ clientWithRouteAndResultHandler Proxy =

548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

544549

545550

546551instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where

547552 type Client t m (RemoteHost :> api) tag = Client t m api tag

548553

549− clientWithRoute Proxy =

550− clientWithRoute (Proxy :: Proxy api)

554+ clientWithRouteAndResultHandler Proxy =

555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

551556

552557

553558

554559instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where

555560 type Client t m (IsSecure :> api) tag = Client t m api tag

556561

557− clientWithRoute Proxy =

558− clientWithRoute (Proxy :: Proxy api)

562+ clientWithRouteAndResultHandler Proxy =

563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

559564

560565

561566instance (HasClient t m api tag, Reflex t)

@@ -564,8 +569,8 @@ instance (HasClient t m api tag, Reflex t)

564569 type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)

565570 -> Client t m api tag

566571

567− clientWithRoute Proxy q t req baseurl authdata =

568− clientWithRoute (Proxy :: Proxy api) q t req' baseurl

572+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =

573+ clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap

569574 where

570575 req' = req { authData = Just authdata }

571576

@@ -591,3 +596,29 @@ non-empty lists, but is otherwise more specific, no instance will be overall

591596more specific. This in turn generally means adding yet another instance (one

592597for empty and one for non-empty lists).

593598-}

599+

600+

601+-- SUPPORT FOR servant-auth --

602+

603+-- For JavaScript clients we should be sending/storing JSON web tokens in a

604+-- way that is inaccessible to JavaScript.

605+--

606+-- For @servant-auth@ this is done with HTTP-only cookies. In a Reflex-DOM

607+-- app this means the @servant-auth@ client should only verify that the API

608+-- supports Cookie-based authentication but do nothing with the token

609+-- directly.

610+

611+-- @HasCookieAuth auths@ is nominally a redundant constraint, but ensures

612+-- we're not trying to rely on cookies when the API does not use them.

613+instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where

614+

615+ type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag

616+ clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)

617+

618+

619+type family HasCookieAuth xs :: Constraint where

620+ HasCookieAuth (Auth.Cookie ': xs) = ()

621+ HasCookieAuth (x ': xs) = HasCookieAuth xs

622+ HasCookieAuth '[] = CookieAuthNotEnabled

623+

624+class CookieAuthNotEnabled

src/Servant/Reflex/Multi.hs+82−53

@@ -16,12 +16,15 @@

1616module Servant.Reflex.Multi (

1717 -- * Compute servant client functions

1818 clientA

19+ , clientWithOptsA

1920 , BaseUrl(..)

2021 , Scheme(..)

2122

2223 -- * Build QueryParam arguments

2324 , QParam(..)

2425

26+ -- * Access response data

27+ , withCredentials

2528

2629 -- * Access response data

2730 , ReqResult(..)

@@ -34,40 +37,45 @@ module Servant.Reflex.Multi (

3437 ) where

3538

3639------------------------------------------------------------------------------

37−import Control.Applicative (liftA2)

38−import Data.Functor.Compose (Compose (..), getCompose)

39−import Data.Proxy (Proxy (..))

40−import qualified Data.Set as Set

41−import Data.Text (Text)

42−import qualified Data.Text as T

43−import qualified Data.Text.Encoding as E

44−import GHC.TypeLits (KnownSymbol, symbolVal)

45−import Servant.API ((:<|>) (..), (:>), BasicAuth,

46− BasicAuthData, BuildHeadersTo (..),

47− Capture, Header, Headers (..),

48− HttpVersion, IsSecure, MimeRender (..),

49− MimeUnrender, NoContent, QueryFlag,

50− QueryParam, QueryParams, Raw,

51− ReflectMethod (..), RemoteHost,

52− ReqBody, ToHttpApiData (..), Vault,

53− Verb, contentType)

54−

55−import Reflex.Dom (Dynamic, Event, Reflex,

56− XhrRequest (..),

57− XhrResponseHeaders (..),

58− attachPromptlyDynWith, constDyn)

40+import Control.Applicative (liftA2)

41+import Data.Functor.Compose (Compose (..), getCompose)

42+import Data.Proxy (Proxy (..))

43+import qualified Data.Set as Set

44+import Data.Text (Text)

45+import qualified Data.Text as T

46+import qualified Data.Text.Encoding as E

47+import GHC.TypeLits (KnownSymbol, symbolVal)

48+import Servant.API ((:<|>) (..), (:>), BasicAuth,

49+ BasicAuthData, BuildHeadersTo (..),

50+ Capture, Header, Headers (..),

51+ HttpVersion, IsSecure,

52+ MimeRender (..), MimeUnrender,

53+ NoContent, QueryFlag, QueryParam,

54+ QueryParams, Raw, ReflectMethod (..),

55+ RemoteHost, ReqBody,

56+ ToHttpApiData (..), Vault, Verb,

57+ contentType)

58+import Servant.API.Description (Summary)

59+

60+import Reflex.Dom.Core (Dynamic, Event, Reflex,

61+ XhrRequest (..),

62+ XhrResponseHeaders (..),

63+ attachPromptlyDynWith, constDyn)

5964------------------------------------------------------------------------------

6065import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),

6166 SupportsServantReflex)

62−import Servant.Common.Req (QParam (..), QueryPart (..), Req,

67+import Servant.Common.Req (ClientOptions,

68+ QParam (..), QueryPart (..), Req,

6369 ReqResult (..), addHeader, authData,

64− defReq, performRequestsCT,

70+ defReq,

71+ defaultClientOptions,

72+ performRequestsCT,

6573 performRequestsNoBody,

6674 performSomeRequestsAsync,

6775 prependToPathParts, qParamToQueryPart,

6876 qParams, reqBody, reqFailure,

6977 reqMethod, reqSuccess, reqSuccess',

70− respHeaders, response)

78+ respHeaders, response, withCredentials)

7179import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)

7280

7381

@@ -77,14 +85,24 @@ clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)

7785 -> Dynamic t BaseUrl -> ClientMulti t m layout f tag

7886clientA p q f tag baseurl =

7987 clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl

88+ defaultClientOptions

89+

8090

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

8199

82100------------------------------------------------------------------------------

83101class HasClientMulti t m layout f (tag :: *) where

84102 type ClientMulti t m layout f tag :: *

85103 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag

86104 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl

87− -> ClientMulti t m layout f tag

105+ -> ClientOptions -> ClientMulti t m layout f tag

88106

89107

90108------------------------------------------------------------------------------

@@ -92,9 +110,9 @@ instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>

92110 HasClientMulti t m (a :<|> b) f tag where

93111 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>

94112 ClientMulti t m b f tag

95− clientWithRouteMulti Proxy q f tag reqs baseurl =

96− clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl :<|>

97− clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl

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

98116

99117

100118------------------------------------------------------------------------------

@@ -107,8 +125,8 @@ instance (SupportsServantReflex t m,

107125 type ClientMulti t m (Capture capture a :> sublayout) f tag =

108126 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag

109127

110− clientWithRouteMulti _ q f tag reqs baseurl vals =

111− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

128+ clientWithRouteMulti _ q f tag reqs baseurl opts vals =

129+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts

112130 where

113131 reqs' = (prependToPathParts <$> ps <*>) <$> reqs

114132 ps = (fmap . fmap . fmap) toUrlPiece vals

@@ -128,8 +146,8 @@ instance {-# OVERLAPPABLE #-}

128146 type ClientMulti t m (Verb method status cts' a) f tag =

129147 Event t tag -> m (Event t (f (ReqResult tag a)))

130148

131− clientWithRouteMulti _ _ _ _ reqs baseurl =

132− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl

149+ clientWithRouteMulti _ _ _ _ reqs baseurl opts =

150+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts

133151 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

134152 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs

135153

@@ -143,8 +161,8 @@ instance {-# OVERLAPPING #-}

143161 Event t tag -> m (Event t (f (ReqResult tag NoContent)))

144162 -- TODO: how to access input types here?

145163 -- ExceptT ServantError IO NoContent

146− clientWithRouteMulti Proxy _ _ _ req baseurl =

147− performRequestsNoBody method req baseurl

164+ clientWithRouteMulti Proxy _ _ _ req baseurl opts =

165+ performRequestsNoBody method req baseurl opts

148166 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

149167

150168

@@ -158,9 +176,9 @@ instance {-# OVERLAPPABLE #-}

158176 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where

159177 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =

160178 Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))

161− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do

179+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do

162180 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

163− resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl triggers :: m (Event t (f (ReqResult tag a)))

181+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))

164182 return $ fmap toHeaders <$> resp

165183 where

166184 reqs' = fmap (\r ->

@@ -181,9 +199,9 @@ instance {-# OVERLAPPABLE #-}

181199 cts (Headers ls NoContent)) f tag where

182200 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag

183201 = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))

184− clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do

202+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do

185203 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)

186− resp <- performRequestsNoBody method reqs' baseurl triggers

204+ resp <- performRequestsNoBody method reqs' baseurl opts triggers

187205 return $ fmap toHeaders <$> resp

188206 where reqs' = fmap (\req ->

189207 req {respHeaders = OnlyHeaders (Set.fromList

@@ -203,11 +221,11 @@ instance (KnownSymbol sym,

203221 type ClientMulti t m (Header sym a :> sublayout) f tag =

204222 f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag

205223

206− clientWithRouteMulti Proxy f q tag reqs baseurl eVals =

224+ clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =

207225 clientWithRouteMulti (Proxy :: Proxy sublayout) f

208226 q tag

209227 reqs'

210− baseurl

228+ baseurl opts

211229 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)

212230 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)

213231 <$> eVals <*>) <$> reqs

@@ -224,6 +242,17 @@ instance HasClientMulti t m sublayout f tag

224242 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

225243

226244

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+

227256------------------------------------------------------------------------------

228257instance (KnownSymbol sym,

229258 ToHttpApiData a,

@@ -237,9 +266,9 @@ instance (KnownSymbol sym,

237266

238267 -- if mparam = Nothing, we don't add it to the query string

239268 -- TODO: Check the above comment

240− clientWithRouteMulti Proxy q f tag reqs baseurl mparams =

269+ clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =

241270 clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

242− reqs' baseurl

271+ reqs' baseurl opts

243272

244273 where pname = symbolVal (Proxy :: Proxy sym)

245274 p prm = QueryPartParam $ fmap qParamToQueryPart prm

@@ -260,8 +289,8 @@ instance (KnownSymbol sym,

260289 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =

261290 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag

262291

263− clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =

264− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

292+ clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =

293+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts

265294

266295 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }

267296 pname = symbolVal (Proxy :: Proxy sym)

@@ -279,8 +308,8 @@ instance (KnownSymbol sym,

279308 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =

280309 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag

281310

282− clientWithRouteMulti Proxy q f' tag reqs baseurl flags =

283− clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl

311+ clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =

312+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts

284313

285314 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }

286315 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)

@@ -294,10 +323,10 @@ instance (SupportsServantReflex t m,

294323 -> Event t tag

295324 -> m (Event t (f (ReqResult tag ())))

296325

297− clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do

326+ clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do

298327 let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))

299328 rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers

300− resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync rawReqs''

329+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''

301330 return resps

302331 where

303332 aux (tag, Right r) = ResponseSuccess tag () r

@@ -313,8 +342,8 @@ instance (MimeRender ct a,

313342 type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =

314343 Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag

315344

316− clientWithRouteMulti Proxy q f tag reqs baseurl bodies =

317− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

345+ clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

346+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts

318347 where req' b r = r { reqBody = bodyBytesCT (constDyn b) }

319348 ctProxy = Proxy :: Proxy ct

320349 ctString = T.pack $ show $ contentType ctProxy

@@ -365,8 +394,8 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)

365394 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))

366395 -> ClientMulti t m api f tag

367396

368− clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =

369− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl

397+ clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =

398+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts

370399 where

371400 req' a r = r { authData = Just (constDyn a) }

372401 reqs' = liftA2 req' <$> authdatas <*> reqs

src/Servant/Reflex/Tuple.hsdeleted−245

@@ -1,245 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE FunctionalDependencies #-}

7−{-# LANGUAGE GADTs #-}

8−{-# LANGUAGE InstanceSigs #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE OverloadedStrings #-}

11−{-# LANGUAGE PolyKinds #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE TupleSections #-}

14−{-# LANGUAGE TypeFamilies #-}

15−{-# LANGUAGE TypeOperators #-}

16−{-# LANGUAGE UndecidableInstances #-}

17−

18−-- #include "overlapping-compat.h"

19−-- | This module provides 'client' which can automatically generate

20−-- querying functions for each endpoint just from the type representing your

21−-- API.

22−module Servant.Reflex.Tuple

23− ( client

24− , BuildHeaderKeysTo(..)

25− , toHeaders

26− , HasClient(..)

27− , module Servant.Common.Req

28− , module Servant.Common.BaseUrl

29− ) where

30−

31−------------------------------------------------------------------------------

32−import Control.Applicative

33−import Data.CaseInsensitive (mk)

34−import Data.Functor.Identity

35−import qualified Data.Map as Map

36−import Data.Monoid ((<>))

37−import Data.Proxy (Proxy (..))

38−import qualified Data.Set as Set

39−import Data.Text (Text)

40−import qualified Data.Text as T

41−import qualified Data.Text.Encoding as E

42−import GHC.TypeLits (KnownSymbol, symbolVal)

43−import Servant.API ((:<|>) (..), (:>), BasicAuth,

44− BasicAuthData, BuildHeadersTo (..),

45− Capture, Header, Headers (..),

46− HttpVersion, IsSecure, MimeRender (..),

47− MimeUnrender, NoContent, QueryFlag,

48− QueryParam, QueryParams, Raw,

49− ReflectMethod (..), RemoteHost,

50− ReqBody, ToHttpApiData (..), Vault,

51− Verb, contentType)

52−

53−import Reflex.Dom (Dynamic, Event, Reflex,

54− XhrRequest (..), XhrResponse (..),

55− XhrResponseHeaders (..),

56− attachPromptlyDynWith, constDyn, ffor,

57− fmapMaybe, leftmost,

58− performRequestsAsync)

59−------------------------------------------------------------------------------

60−import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),

61− SupportsServantReflex, baseUrlWidget,

62− showBaseUrl)

63−import Servant.Common.Req (QParam (..), QueryPart (..), Req,

64− ReqIO, ReqResult (..), addHeaderIO,

65− authData, defReqIO, evalResponse,

66− performRequestsCT,

67− performRequestsNoBody,

68− performSomeRequestsAsync,

69− prependToPathPartsIO, qParamToQueryPart,

70− qParams, reqBody, reqFailure,

71− reqMethodIO, reqSuccess, reqTag,

72− respHeadersIO, response)

73−

74−type family ToTuple a :: *

75−

76−type instance ToTuple () = ()

77−type instance ToTuple (a,()) = a

78−type instance ToTuple (a,(b,())) = (a,b)

79−type instance ToTuple (a,(b,(c,()))) = (a,b,c)

80−type instance ToTuple (a,(b,(c,(d,())))) = (a,b,c)

81−type instance ToTuple (a,(b,(c,(d,(e,()))))) = (a,b,c,d,e)

82−

83−client :: (HasClient layout t m, HasInp layout) => Proxy layout -> Proxy m -> BaseUrl -> Client layout t m

84−client = undefined

85−

86−class HasInp layout where

87− type Inp layout :: *

88− type Out layout :: *

89− inpToReq :: Proxy layout -> Inp layout -> ReqIO

90−

91−class HasClient layout (t :: *) (m :: * -> *) where

92− type Client layout t m :: *

93−

94−instance (HasClient a t m,

95− HasClient b t m,

96− HasInp a,

97− HasInp b

98− ) => HasClient (a :<|> b) t m where

99− type Client (a :<|> b) t m = Client a t m :<|> Client b t m

100−

101−instance (ToHttpApiData a, HasInp sublayout) => HasInp (Capture capture a :> sublayout) where

102− type Inp (Capture capture a :> sublayout) = (a, Inp sublayout)

103− type Out (Capture capture a :> sublayout) = Out sublayout

104− inpToReq _ (a, otherInp) = prependToPathPartsIO (toUrlPiece a) $ inpToReq (Proxy :: Proxy sublayout) otherInp

105−

106−instance (HasInp (Capture capture a :> sublayout)) => HasClient (Capture capture a :> sublayout) t m where

107− type Client (Capture capture a :> sublayout) t m =

108− Event t (ToTuple (Inp (Capture capture a :> sublayout))) ->

109− m (Event t (Out (Capture capture a :> sublayout)))

110−

111−

112−

113−instance {-# OVERLAPPABLE #-}

114− (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

115− ) => HasInp (Verb method status cts' a) where

116− type Inp (Verb method status cts' a) = ()

117− type Out (Verb method status cts' a) = Either Text a

118− inpToReq _ _ = defReqIO

119−

120−instance {-# OVERLAPPABLE #-}

121− (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)

122− ) => HasClient (Verb method status cts' a) t m where

123− type Client (Verb method status cts' a) t m = Event t (ToTuple (Inp (Verb method status cts' a))) ->

124− m (Event t (Out (Verb method status cts' a)))

125−

126−

127−instance {-# OVERLAPPING #-}

128− (ReflectMethod method) => HasInp (Verb method status cts NoContent) where

129− type Inp (Verb method status cts NoContent) = ()

130− type Out (Verb method status cts NoContent) = Either Text NoContent

131−

132−

133−instance {-# OVERLAPPING #-}

134− (ReflectMethod method, SupportsServantReflex t m)

135− => HasClient (Verb method status cts NoContent) t m where

136− type Client (Verb method status cts NoContent) t m =

137− Event t (ToTuple (Inp (Verb method status cts NoContent))) ->

138− m (Event t (Out (Verb method status cts NoContent)))

139−

140−

141−instance {-# OVERLAPPABLE #-}

142− (MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

143− ReflectMethod method, cts' ~ (ct ': cts)

144− ) => HasInp (Verb method status cts' (Headers ls a)) where

145− type Inp (Verb method status cts' (Headers ls a)) = ()

146− type Out (Verb method status cts' (Headers ls a)) = Either Text (Headers ls a)

147− inpToReq _ _ = defReqIO { respHeadersIO =

148− OnlyHeaders (Set.fromList

149− (buildHeaderKeysTo

150− (Proxy :: Proxy ls)))

151− }

152−

153−

154−------------------------------------------------------------------------------

155−instance {-# OVERLAPPABLE #-}

156− HasInp (Verb method status cts' (Headers ls a))

157− => HasClient (Verb method status cts' (Headers ls a)) t m where

158− type Client (Verb method status cts' (Headers ls a)) t m =

159− Event t (ToTuple (Inp (Verb method status cts' (Headers ls a)))) ->

160− m (Event t (Out (Verb method status cts' (Headers ls a))))

161−

162−

163−------------------------------------------------------------------------------

164−instance {-# OVERLAPPING #-}

165− (BuildHeadersTo ls,

166− BuildHeaderKeysTo ls

167− ) => HasInp (Verb method status cts' (Headers ls NoContent)) where

168− type Inp (Verb method status cts' (Headers ls NoContent)) = ()

169− type Out (Verb method status cts' (Headers ls NoContent)) =

170− Either Text (Headers ls NoContent)

171− inpToReq _ _ = defReqIO { respHeadersIO =

172− OnlyHeaders (Set.fromList

173− (buildHeaderKeysTo

174− (Proxy :: Proxy ls)))

175− }

176−

177−

178−------------------------------------------------------------------------------

179−instance {-# OVERLAPPING #-}

180− (BuildHeadersTo ls,

181− BuildHeaderKeysTo ls,

182− SupportsServantReflex t m

183− ) => HasClient (Verb method status cts' (Headers ls NoContent)) t m where

184− type Client (Verb method status cts' (Headers ls NoContent)) t m =

185− Event t (ToTuple (Inp (Verb method status cts' (Headers ls NoContent)))) ->

186− m (Event t (Out (Verb method status cts' (Headers ls NoContent))))

187−

188−

189−------------------------------------------------------------------------------

190−toHeaders

191− :: BuildHeadersTo ls

192− => ReqResult tag a

193− -> ReqResult tag (Headers ls a)

194−toHeaders r =

195− let toBS = E.encodeUtf8

196− hdrs = maybe []

197− (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))

198− (Map.toList $ _xhrResponse_headers xhr))

199− (response r)

200− in ffor r $ \a -> Headers {getResponse = a

201− ,getHeadersHList = buildHeadersTo hdrs

202− }

203−

204−

205−------------------------------------------------------------------------------

206−class BuildHeaderKeysTo hs where

207− buildHeaderKeysTo :: Proxy hs -> [T.Text]

208−

209−

210−------------------------------------------------------------------------------

211−instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]

212− where buildHeaderKeysTo _ = []

213−

214−

215−------------------------------------------------------------------------------

216−instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)

217− => BuildHeaderKeysTo ((Header h v) ': xs) where

218− buildHeaderKeysTo _ =

219− T.pack (symbolVal (Proxy :: Proxy h)) :

220− buildHeaderKeysTo (Proxy :: Proxy xs)

221−

222−

223−------------------------------------------------------------------------------

224−instance (KnownSymbol sym,

225− ToHttpApiData a,

226− HasInp sublayout

227− ) => HasInp (Header sym a :> sublayout) where

228− type Inp (Header sym a :> sublayout) = (Maybe a, Inp sublayout)

229− type Out (Header sym a :> sublayout) = Out sublayout

230− inpToReq _ (h, vs) =

231− (addHeaderIO hname h) (inpToReq (Proxy :: Proxy sublayout) vs)

232− where hname = T.pack $ symbolVal (Proxy :: Proxy sym)

233−

234−

235−------------------------------------------------------------------------------

236−instance (KnownSymbol sym,

237− ToHttpApiData a,

238− HasClient sublayout t m

239− ) => HasClient (Header sym a :> sublayout) t m where

240− type Client (Header sym a :> sublayout) t m =

241− Event t (ToTuple (Inp (Header sym a :> sublayout)))

242− -> m (Event t (Out (Header sym a :> sublayout)))

243−

244−

245−------------------------------------------------------------------------------

testdriver/test/Servant/ReflexSpec.hs+2−1

@@ -9,6 +9,7 @@ import qualified Data.Text as T

99import Data.Foldable

1010import Test.WebDriver.Commands.Wait

1111import Test.Hspec.WebDriver

12+import Test.Hspec.WebDriver (chromeCaps)

1213

1314

1415clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()

@@ -28,7 +29,7 @@ spec :: Spec

2829spec = do

2930 describe "servant-reflex tests" $ do

3031

31− session "test page" $ using Chrome $ do

32+ session "test page" $ using [chromeCaps] $ do

3233

3334 it "opens the page" $ runWD $

3435 openPage "http://localhost:8000"

testserver/API.hsmode 120000 → 100644+69−1

@@ -1 +0,0 @@

1−../exec/API.hs

@@ -0,0 +1,69 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeOperators #-}

5+module API where

7+import Data.Aeson

8+import Data.Aeson.Types (typeMismatch)

9+import Data.Text (Text)

10+import Servant.API

11+

12+newtype Question = Question { unQuestion :: Text } deriving (Show)

13+

14+instance ToJSON Question where

15+ toJSON (Question txt) = object ["question" .= txt]

16+

17+instance FromJSON Question where

18+ parseJSON (Object v) = Question <$> v .: "question"

19+ parseJSON x = typeMismatch "Couldn't find key 'question'" x

20+

21+newtype Answer = Answer { unAnswer :: Text } deriving (Show)

22+

23+instance ToJSON Answer where

24+ toJSON (Answer txt) = object ["answer" .= txt]

25+

26+instance FromJSON Answer where

27+ parseJSON (Object v) = Answer <$> v .: "answer"

28+ parseJSON x = typeMismatch "Couldn't find key 'answer'" x

29+

30+

31+-- | API spec for server, client, and docs

32+type API = "getunit" :> Get '[JSON] ()

33+ :<|> "getint" :> Get '[JSON] Int

34+ :<|> "sayhi" :> QueryParam "username" Text

35+ :> QueryParams "greetings" Text

36+ :> QueryFlag "gusto"

37+ :> Get '[JSON] Text

38+ :<|> "double" :> ReqBody '[JSON] Double

39+ :> Post '[JSON] Double

40+ :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text

41+ :<|> "qna" :> ReqBody '[JSON] Question

42+ :> Post '[JSON] Answer

43+ :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int

44+ :<|> Raw

45+

46+type GET = Get '[JSON] ()

47+

48+-- Imported the comprehensive API example for testing.

49+-- https://github.com/haskell-servant/servant/blob/master/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs

50+type ComprehensiveAPI =

51+ GET :<|>

52+ Get '[JSON] Int :<|>

53+ Capture "foo" Int :> GET :<|>

54+ Header "foo" Int :> GET :<|>

55+ HttpVersion :> GET :<|>

56+ IsSecure :> GET :<|>

57+ QueryParam "foo" Int :> GET :<|>

58+ QueryParams "foo" Int :> GET :<|>

59+ QueryFlag "foo" :> GET :<|>

60+-- Raw :<|>

61+ RemoteHost :> GET :<|>

62+ ReqBody '[JSON] Int :> GET :<|>

63+ Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>

64+ "foo" :> GET :<|>

65+ Vault :> GET :<|>

66+ Verb 'POST 204 '[JSON] () :<|>

67+ Verb 'POST 204 '[JSON] Int

68+-- This one isn't in scope

69+-- :<|> WithNamedContext "foo" '[] GET

testserver/Main.hs+20−5

@@ -2,14 +2,17 @@

22{-# LANGUAGE DeriveGeneric #-}

33{-# LANGUAGE OverloadedStrings #-}

44{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE TypeApplications #-}

56{-# LANGUAGE TypeFamilies #-}

67{-# LANGUAGE TypeOperators #-}

89import Control.Monad.IO.Class (liftIO)

10+import Control.Monad.Reader (reader)

911import Data.Aeson

1012import Data.Bool

1113import Data.Char (toUpper)

1214import qualified Data.List as L

15+import Data.Maybe (fromMaybe)

1316import Data.Monoid

1417import Data.Proxy

1518import Data.Text hiding (head, length, map,

@@ -24,6 +27,7 @@ import Snap.Http.Server

2427import Servant

2528import Servant.Server

2629-- import Snap.Util.FileServe

30+import System.Environment (lookupEnv)

2731import API

2832import Snap

2933

@@ -39,7 +43,7 @@ instance ToJSON Greet

3943testApi :: Proxy API

4044testApi = Proxy

4145

42−data App = App

46+data App = App { appStaticDir :: String }

4347

4448-- Server-side handlers.

4549--

@@ -47,8 +51,10 @@ data App = App

4751-- that represents the API, are glued together using :<|>.

4852--

4953-- Each handler runs in the 'ExceptT ServantErr IO' monad.

50−server :: Server API (Handler App App)

54+server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)

55+server = return () :<|> return 100 :<|> sayhi :<|> dbl

56+ :<|> multi :<|> qna :<|> serveSecret

57+ :<|> statics

5258 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text

5359 sayhi nm greetings withGusto = case nm of

5460 Nothing -> return ("Sorry, who are you?" :: Text)

@@ -69,18 +75,27 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|>

6975 putStrLn $ "qna got: " ++ show q

7076 T.putStrLn $ unQuestion q

7177 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

7285

7386-- Turn the server into a WAI app. 'serve' is provided by servant,

7487-- more precisely by the Servant.Server module.

7588test :: Handler App App ()

76−test = serveSnap testApi server

89+test = serveSnapWithContext testApi

90+ (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server

7791

7892initApp :: SnapletInit App App

7993initApp = makeSnaplet "myapp" "example" Nothing $ do

94+ staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")

8095 addRoutes [("", test)

8196 ,("", serveDirectory "static")

8297 ]

83− return App

98+ return (App staticDir)

8499

85100-- Put this all to work!

86101main :: IO ()

testserver/run-wd-tests.shdeleted−5

@@ -1,5 +0,0 @@

1−#!/usr/bin/env bash

2−

3−dist/build/back/back -p 8000 &

4−phantomjs --webdriver=127.0.0.1:4444 &

5−dist/build/spec/spec

testserver/testserver.cabal+8−7

@@ -19,13 +19,14 @@ executable back

1919 main-is: Main.hs

2020 -- other-modules:

2121 -- 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

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

2627 , snap-core >= 1.0 && < 1.1

27− , servant >= 0.8 && < 0.11

28− , servant-snap >= 0.7.2 && < 0.8

29− , text >= 1.2 && < 1.3

28+ , servant >= 0.16 && < 0.18

29+ , servant-snap >= 0.8 && < 0.9

30+ , text >= 1.0 && < 1.3

3031 -- hs-source-dirs:

3132 default-language: Haskell2010

testserver/tr.nixdeleted−32

@@ -1,32 +0,0 @@

1−{ reflex-platform, ... }:

2−let

3−

4− dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;

5− cabal2nixResult = reflex-platform.cabal2nixResult;

6− nixpkgs = (import <nixpkgs> {});

7−in

8−reflex-platform.ghc.override {

9− overrides = self: super: {

10− servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});

11− snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap) {});

12− io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});

13− io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});

14− heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});

15− xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});

16− snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});

17− snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});

18− snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});

19− snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});

20− hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});

21−

22− # servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});

23− # servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});

24− # servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});

25− # servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});

26− # servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});

27− # servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});

28− # servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});

29− # servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});

30−

31− };

32−}

travis.nixnew file+70

@@ -0,0 +1,70 @@

1+{

2+ nativeCompiler ? "ghc",

3+ # ^ Choose a GHC for compiling backend components (web server, selenium)

4+ # (ghc, ghc8_0, ghc8_2, ghc8_4 or ghcHEAD)

6+ jsCompiler ? "ghcjs"

7+ # ^ Choose a GHCJS for compiling the frontend

8+ # (ghcjs, ghcjs8_0, ghcjs8_2 or ghcjs8_4)

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+ }