c8339e0..master · servant-reflex

git.iko.soy/servant-reflex

on master help sign in

.gitignore+2

since splitsnapshots

unifiedsplit

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

7*.stats

8out

9/.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

1+language: nix

2−

2+nix: 2.3.6

3−before_cache:

3+sudo: require

4− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

5− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar

6−

7−addons:

8− apt:

9− - phantomjs

10−

11−matrix:

12− include:

13− - env: CABALVER=1.24 GHCVER=7.10.3

14− compiler: ": #GHC 7.10.3"

15− addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3], sources: [hvr-ghc]}}

16− - env: CABALVER=1.24 GHCVER=8.0.1

17− compiler: ": #GHC 8.0.1"

18− addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}

19−

20−

22before_install:

5before_install:

23− - unset CC

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

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

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

27−install:

8+before_script:

28− - cabal --version

9+ - sudo systemctl restart nix-daemon.service

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

10+ - git config --global user.email "travis-ci@example.com"

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

11+ - git config --global user.name "Travis-CI"

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

46script:

13script:

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

14+ - nix-build travis.nix -A build

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

15+ - nix-build travis.nix -A buildGhc

49− - ./build.sh

16+ - nix-build travis.nix -A testserver

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

17+ - nix-build travis.nix -A testresults

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"

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+

10.3

290.3

2---

30---

README.md+70−33

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

5## `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.

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.

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.

12+Syncronization between is checked at compile time, and rather than building XHR

9−

13+requests by hand, API endpoints are available behind `reflex`'s FRP semantics.

12## Example

16## Example

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:

16```haskell

21```haskell

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

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

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

24 :<|> Raw

29 :<|> Raw

25```

30```

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`.

29```haskell

35```haskell

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

37 (constDyn (BasePath "/"))

43 (constDyn (BasePath "/"))

38```

44```

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.

42```haskell

57```haskell

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

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

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

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

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

63```

78```

80+`ReqResult tag a` is defined in

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:

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:

67```haskell

88```haskell

68 -- ... continued ...

89 -- ... continued ...

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

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

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

81```

102```

103

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:

106

85```haskell

107```haskell

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

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

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

103 display =<< holdDyn Nothing outputDouble

125 display =<< holdDyn Nothing outputDouble

104```

126```

105

127

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.

107

133

108

134

109## Building the library and test server

135## Building the library and test server

110

136

137+This repository comes with a small example of an API shared between a

138+ghcjs-compiled frontend

139+([exec/](https://github.com/imalsogreg/servant-reflex/tree/master/exec)) and a

140+ghc-compiled backend

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:

141+([testserver/](https://github.com/imalsogreg/servant-reflex/tree/master/testserver).

112−

142+To build these components, we will use the nix packages for the testserver. It

113−

143+manages the frontend build as a dependency.

114−First build the library:

115

144

116```

145```

117−git submodule update --init --recursive

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

118−./build.sh

119```

147```

120

148

121−Then build the test server:

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

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:

131

150

132```

151```

133−cd testserver

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

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

135```

153```

136

154

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.

138

158

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).**

140

161

141

162

142## Tagging requests

163## Tagging requests

143

164

165+The input and the return type of a client function like `getDouble` are both

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.

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.

145

169

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:

147

175

148```haskell

176```haskell

149 ...

177 ...

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

173

201

174## Simultaneous requests

202## Simultaneous requests

175

203

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:

177

208

178```haskell

209```haskell

179sayHi

210sayHi

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

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

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

185```

216```

186

217

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] ()

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

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

42 :> Post '[JSON] Answer

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

43 :<|> Raw

44 :<|> Raw

45type GET = Get '[JSON] ()

46type GET = Get '[JSON] ()

exec/Example.hs+27−6

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

1+{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

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

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

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

15import Data.Text (Text)

16import Data.Text (Text)

16import qualified Data.Text as T

17import qualified Data.Text as T

18+import qualified Data.Text.Encoding as T

17import GHC.TypeLits

19import GHC.TypeLits

18import Servant.API

20import Servant.API

19import API

21import API

20import Data.Proxy

22import Data.Proxy

21import Text.Read (readMaybe)

23import Text.Read (readMaybe)

22−import Reflex.Dom hiding (run)

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

25+import Reflex.Dom (mainWidget)

23------------------------------------------------------------------------------

26------------------------------------------------------------------------------

24import Servant.Reflex

27import Servant.Reflex

25import Servant.Reflex.Multi

28import Servant.Reflex.Multi

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

43runMulti = do

46runMulti = do

44 url <- baseUrlWidget

47 url <- baseUrlWidget

45 el "br" blank

48 el "br" blank

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

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

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

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

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

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

@@ -66,9 +69,12 @@ runMulti = do

66 textInput def

69 textInput def

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

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

68 b <- button "Go"

71 b <- button "Go"

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

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

73 return ()

79 return ()

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

91 el "br" (return ())

97 el "br" (return ())

93 -- Name the computed API client functions

99 -- Name the computed API client functions

100+ let tweakRequest = ClientOptions $ \r -> do

101+ return $ r & withCredentials .~ True

102+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl

103+ :<|> multi :<|> qna :<|> secret :<|> doRaw) =

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

104+ clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest

105

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

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

107

@@ -177,6 +186,18 @@ run = mdo

177 el "p" $

186 el "p" $

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

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

179

188

189+ divClass "demo-group" $ do

190+ un <- fmap value $ text "Username" >> textArea def

191+ pw <- fmap value $ text "Unhidden PW" >> textArea def

192+ let ba :: Dynamic t (BasicAuthData ) = BasicAuthData

193+ <$> fmap T.encodeUtf8 un

194+ <*> fmap T.encodeUtf8 pw

195+ b <- button "Get secret"

196+ r <- secret (Just <$> ba) (0 <$ b)

197+ res <- holdDyn Nothing (reqSuccess <$> r)

198+ display res

199+

200+

180showXhrResponse :: XhrResponse -> Text

201showXhrResponse :: XhrResponse -> Text

181showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

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

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

nix/nix.confnew file+3

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

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

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

3+trusted-users = travis

nix/reflex-platform.nixnew file+7

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

1+let

2+ rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;

3+in import (builtins.fetchTarball

4+ {

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

6+ sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;

7+ }) {}

nix/servant-snap.nixnew file+7

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

1+# Servant-snap is marked broken in nixpkgs

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

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

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

5+ rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";

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

7+}) {}

nix/testresults.nixnew file+17

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

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

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−19

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

1Name: servant-reflex

2−Version: 0.3.1

2+Version: 0.3.6

3−Synopsis: Servant reflex API generator

3+Synopsis: servant API generator for reflex apps

4−Description: Servant reflex API generator

4+Description: Generate reflex-compatible client functions from servant API descriptions

5−License: AllRightsReserved

5+License: BSD3

6License-file: LICENSE.md

7Author: Greg Hale, Doug Beardsley

8Maintainer: imalsogreg@gmail.com

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

18library

19 exposed-modules:

20− Servant.Reflex

21− Servant.Reflex.Multi

22−

23− other-modules:

24 Servant.Common.BaseUrl

20 Servant.Common.BaseUrl

25 Servant.Common.Req

21 Servant.Common.Req

22+ Servant.Reflex

23+ Servant.Reflex.Multi

27 hs-source-dirs: src

25 hs-source-dirs: src

28 build-depends:

26 build-depends:

29− base >= 4.8 && < 4.10,

27+ base >= 4.8 && < 5,

30− aeson >= 0.11 && < 1.3,

31 bytestring >= 0.10 && < 0.11,

28 bytestring >= 0.10 && < 0.11,

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

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

33− containers >= 0.5.6 && < 0.6,

30+ containers >= 0.5.6 && < 0.7,

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

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

35− exceptions >= 0.8 && < 0.9,

32+ exceptions >= 0.8 && < 0.11,

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

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

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

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

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

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

39 jsaddle >= 0.8 && < 0.10,

36 jsaddle >= 0.8 && < 0.10,

40 mtl >= 2.2.1 && < 2.3,

37 mtl >= 2.2.1 && < 2.3,

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

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

42− reflex >= 0.5 && < 0.6,

39+ reflex >= 0.5 && < 0.9,

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

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

44 safe >= 0.3.9 && < 0.4,

41 safe >= 0.3.9 && < 0.4,

45− servant >= 0.8 && < 0.11,

42+ servant >= 0.16 && < 0.18,

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

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

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

47 text >= 1.2 && < 1.3,

45 text >= 1.2 && < 1.3,

48 transformers >= 0.4 && < 0.6

46 transformers >= 0.4 && < 0.6

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

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

52 default-language: Haskell2010

50 default-language: Haskell2010

@@ -56,7 +54,16 @@ executable example

56 buildable: True

54 buildable: True

57 else

55 else

58 buildable: False

56 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

60 default-language: Haskell2010

67 default-language: Haskell2010

61 main-is: Example.hs

68 main-is: Example.hs

62 other-modules: API

69 other-modules: API

shell.nixnew file+1

@@ -0,0 +1 @@

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

src/Servant/Common/BaseUrl.hs+5−6

@@ -28,7 +28,7 @@ import qualified Data.Text as T

28import GHC.Generics

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

30import Reflex

31−import Reflex.Dom

31+import Reflex.Dom.Core

32import Text.Read

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

85 where pathWidget :: m (Dynamic t BaseUrl)

86 pathWidget = do

87 text "Url base path"

88− t <- textInput (def {_textInputConfig_attributes =

88+ t <- inputElement def

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

90 return $ BasePath <$> value t

89 return $ BasePath <$> value t

91 fullUrlWidget :: m (Dynamic t BaseUrl)

90 fullUrlWidget :: m (Dynamic t BaseUrl)

92 fullUrlWidget = do

91 fullUrlWidget = do

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

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

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

93+ srv <- inputElement def

95 text ":"

94 text ":"

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

95+ prt <- inputElement def

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

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

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

97+ path <- inputElement def

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

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

src/Servant/Common/Req.hs+110−106

@@ -4,19 +4,22 @@

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TupleSections #-}

9{-# LANGUAGE TupleSections #-}

10module Servant.Common.Req where

11module Servant.Common.Req where

12-------------------------------------------------------------------------------

13-------------------------------------------------------------------------------

13−import Control.Concurrent

14import Control.Applicative (liftA2, liftA3)

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

16+import Control.Concurrent

15import Control.Monad (join)

17import Control.Monad (join)

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

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

17−import Data.Aeson

18import Data.Bifunctor (first)

19import Data.Bifunctor (first)

20+import qualified Data.ByteString.Builder as Builder

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

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

22+import Data.ByteString (ByteString)

20import qualified Data.Map as Map

23import qualified Data.Map as Map

21import Data.Maybe (catMaybes, fromMaybe)

24import Data.Maybe (catMaybes, fromMaybe)

22import Data.Functor.Compose

25import Data.Functor.Compose

@@ -26,10 +29,9 @@ import Data.Text (Text)

26import qualified Data.Text as T

29import qualified Data.Text as T

27import qualified Data.Text.Encoding as TE

30import qualified Data.Text.Encoding as TE

28import Data.Traversable (forM)

31import Data.Traversable (forM)

29−import Language.Javascript.JSaddle.Monad (JSM, MonadJSM)

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

30−import qualified Language.Javascript.JSaddle as JS

33+import qualified Network.URI as N

31−import Language.Javascript.JSaddle.Types (JSVal)

32−import Reflex.Dom hiding (tag)

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

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

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

34 SupportsServantReflex)

36 SupportsServantReflex)

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

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

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

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

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

51 deriving (Functor)

53 deriving (Functor)

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'

54------------------------------------------------------------------------------

73------------------------------------------------------------------------------

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

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

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

74reqFailure (RequestFailure _ s) = Just s

93reqFailure (RequestFailure _ s) = Just s

75reqFailure _ = Nothing

94reqFailure _ = Nothing

96+------------------------------------------------------------------------------

97+-- | Simple filter/accessor like 'reqFailure', but keeping the request tag

98+reqFailure' :: ReqResult tag a -> Maybe (tag,Text)

99+reqFailure' (ResponseFailure tag s _) = Just (tag,s)

100+reqFailure' (RequestFailure tag s) = Just (tag,s)

101+reqFailure' _ = Nothing

102+

103

78------------------------------------------------------------------------------

104------------------------------------------------------------------------------

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

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

@@ -141,7 +167,7 @@ reqToReflexRequest

141 => Text

167 => Text

142 -> Dynamic t BaseUrl

168 -> Dynamic t BaseUrl

143 -> Req t

169 -> Req t

144− -> (Dynamic t (Either Text (XhrRequest XhrPayload)))

170+ -> Dynamic t (Either Text (XhrRequest XhrPayload))

145reqToReflexRequest reqMeth reqHost req =

171reqToReflexRequest reqMeth reqHost req =

146 let t :: Dynamic t [Either Text Text]

172 let t :: Dynamic t [Either Text Text]

147 t = sequence $ reverse $ reqPathParts req

173 t = sequence $ reverse $ reqPathParts req

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

153 urlParts = fmap sequence t

179 urlParts = fmap sequence t

154

180

155 urlPath :: Dynamic t (Either Text Text)

181 urlPath :: Dynamic t (Either Text Text)

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

182+ urlPath = (fmap.fmap)

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

184+ urlParts

157

185

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

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

159 queryPartString (pName, qp) = case qp of

187 queryPartString (pName, qp) = case qp of

160 QueryPartParam p -> ffor p $ \case

188 QueryPartParam p -> ffor p $ \case

161 Left e -> Just (Left e)

189 Left e -> Just (Left e)

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

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

163 Right Nothing -> Nothing

191 Right Nothing -> Nothing

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

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

165 if null pStrings

193 if null pStrings

166 then Nothing

194 then Nothing

195+ else Just . Right

196+ . T.intercalate "&"

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

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

168 QueryPartFlag fl -> ffor fl $ \case

198 QueryPartFlag fl -> ffor fl $ \case

169 True -> Just $ Right pName

199 True -> Just $ Right pName

170 False -> Nothing

200 False -> Nothing

@@ -199,10 +229,10 @@ reqToReflexRequest reqMeth reqHost req =

199 Right $ XhrRequestConfig

229 Right $ XhrRequestConfig

200 { _xhrRequestConfig_sendData = bytesToPayload bBytes

230 { _xhrRequestConfig_sendData = bytesToPayload bBytes

201 , _xhrRequestConfig_headers =

231 , _xhrRequestConfig_headers =

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

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

203 , _xhrRequestConfig_user = Nothing

233 , _xhrRequestConfig_user = Nothing

204 , _xhrRequestConfig_password = Nothing

234 , _xhrRequestConfig_password = Nothing

205− , _xhrRequestConfig_responseType = Nothing

235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

206 , _xhrRequestConfig_withCredentials = False

236 , _xhrRequestConfig_withCredentials = False

207 , _xhrRequestConfig_responseHeaders = def

237 , _xhrRequestConfig_responseHeaders = def

208 }

238 }

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

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

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

215 , _xhrRequestConfig_user = Nothing

245 , _xhrRequestConfig_user = Nothing

216 , _xhrRequestConfig_password = Nothing

246 , _xhrRequestConfig_password = Nothing

217− , _xhrRequestConfig_responseType = Nothing

247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

218− , _xhrRequestConfig_sendData = ""

248+ , _xhrRequestConfig_sendData = mempty

219 , _xhrRequestConfig_withCredentials = False

249 , _xhrRequestConfig_withCredentials = False

220 }

250 }

221 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

@@ -242,21 +272,29 @@ reqToReflexRequest reqMeth reqHost req =

242displayHttpRequest :: Text -> Text

272displayHttpRequest :: Text -> Text

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

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

244

274

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

275+-- | This function performs the request

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

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

247 => Text

277 => Text

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

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

249 -> Dynamic t BaseUrl

279 -> Dynamic t BaseUrl

280+ -> ClientOptions

250 -> Event t tag

281 -> Event t tag

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

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

252−performRequests reqMeth rs reqHost trigger = do

283+performRequests reqMeth rs reqHost opts trigger = do

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

284+ let xhrReqs =

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

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

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

287+

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

289+ reqs = attachPromptlyDynWith

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

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

291+

256− resps <- performSomeRequestsAsync reqs

292+ resps <- performSomeRequestsAsync opts reqs

257 return $ getCompose <$> resps

293 return $ getCompose <$> resps

258

294

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

295+-- | Issues a collection of requests when the supplied Event fires.

296+-- When ALL requests from a given firing complete, the results are

297+-- collected and returned via the return Event.

260performSomeRequestsAsync

298performSomeRequestsAsync

261 :: (MonadIO (Performable m),

299 :: (MonadIO (Performable m),

262 MonadJSM (Performable m),

300 MonadJSM (Performable m),

@@ -264,20 +302,25 @@ performSomeRequestsAsync

264 PerformEvent t m,

302 PerformEvent t m,

265 TriggerEvent t m,

303 TriggerEvent t m,

266 Traversable f,

304 Traversable f,

267− IsXhrPayload a)

305+ IsXhrPayload a,

306+ Show a

307+ )

308+ => ClientOptions

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

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

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

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

311+performSomeRequestsAsync opts =

270−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return

312+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

271

313

272

314

273------------------------------------------------------------------------------

315------------------------------------------------------------------------------

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

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

275-- that accepts 'f (Either e (XhrRequestb))' events

317-- that accepts 'f (Either e (XhrRequestb))' events

276performSomeRequestsAsync'

318performSomeRequestsAsync'

277− :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)

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

320+ => ClientOptions

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

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

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

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

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

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

281 rs <- hrs

324 rs <- hrs

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

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

283 Left e -> do

326 Left e -> do

@@ -285,98 +328,40 @@ performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb ->

285 return resp

328 return resp

286 Right r' -> do

329 Right r' -> do

287 resp <- liftIO newEmptyMVar

330 resp <- liftIO newEmptyMVar

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

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

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

289 return resp

333 return resp

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

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

291 return ()

335 return ()

292

336

293

337

294

338

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

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

297− => Text

298− -> (Req t)

299− -> Dynamic t BaseUrl

300− -> Event t tag

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

302−performRequest reqMeth req reqHost trigger = do

303−

304− let xhrReq = reqToReflexRequest reqMeth reqHost req

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

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

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

308−

309− resps <- performRequestsAsync okReqs

310−

311− return (resps, badReqs)

312−

313−

314−type XhrPayload = T.Text

339+type XhrPayload = ByteString

315bytesToPayload :: BL.ByteString -> XhrPayload

340bytesToPayload :: BL.ByteString -> XhrPayload

316−bytesToPayload = TE.decodeUtf8 . BL.toStrict

341+bytesToPayload = BL.toStrict

317−

342+

318−

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

320−-- => Text

321−-- -> Req t

322−-- -> Dynamic t BaseUrl

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

324−-- performRequestNoBody reqMeth req reqHost trigger = do

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

326−-- let decodeResp = const $ Right NoContent

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

328−-- , fmap (uncurry RequestFailure) badReq

329−-- ]

330−

331−

332−-- performRequestCT

333−-- :: (SupportsServantReflex t m,

334−-- MimeUnrender ct a)

335−-- => Proxy ct

336−-- -> Text

337−-- -> Req t

338−-- -> Dynamic t BaseUrl

339−-- -> Event t tag

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

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

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

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

344−-- mimeUnrender ct .

345−-- BL.fromStrict .

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

347−-- (_xhrResponse_responseText x)

348−

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

350−-- , fmap (uncurry RequestFailure) badReq

351−-- ]

352

343

353performRequestsCT

344performRequestsCT

354− :: ( SupportsServantReflex t m

345+ :: (SupportsServantReflex t m,

355− -- , MimeUnrender ct a

346+ MimeUnrender ct a, Traversable f)

356− , FromJSON a

357− , Traversable f

358− )

359 => Proxy ct

347 => Proxy ct

360 -> Text

348 -> Text

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

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

362 -> Dynamic t BaseUrl

350 -> Dynamic t BaseUrl

351+ -> ClientOptions

363 -> Event t tag

352 -> Event t tag

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

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

365−performRequestsCT _ reqMeth reqs reqHost trigger = do

354+performRequestsCT ct reqMeth reqs reqHost opts trigger = do

366− resps <- performRequests reqMeth reqs reqHost trigger

355+ resps <- performRequests reqMeth reqs reqHost opts trigger

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

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

357+ first T.pack .

368− -- mimeUnrender ct .

358+ mimeUnrender ct $

369− -- BL.fromStrict .

359+ BL.fromStrict x

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

371− let decodeResp x = first T.pack

360+ decodeResp _ = Left "No body"

372− . note "Failed to decode"

373− . jsonDecode

374− . JS.textToJSString

375− =<< note "No body text" (_xhrResponse_responseText x)

376 return $ fmap

361 return $ fmap

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

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

378 Left e -> RequestFailure t e

363 Left e -> RequestFailure t e

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

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

380 )

365 )

381 resps

366 resps

382

367

@@ -387,10 +372,11 @@ performRequestsNoBody

387 => Text

372 => Text

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

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

389 -> Dynamic t BaseUrl

374 -> Dynamic t BaseUrl

375+ -> ClientOptions

390 -> Event t tag

376 -> Event t tag

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

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

392−performRequestsNoBody reqMeth reqs reqHost trigger = do

378+performRequestsNoBody reqMeth reqs reqHost opts trigger = do

393− resps <- performRequests reqMeth reqs reqHost trigger

379+ resps <- performRequests reqMeth reqs reqHost opts trigger

394 let decodeResp = const $ Right NoContent

380 let decodeResp = const $ Right NoContent

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

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

396 Left e -> RequestFailure tag e

382 Left e -> RequestFailure tag e

@@ -402,8 +388,9 @@ evalResponse

402 :: (XhrResponse -> Either Text a)

388 :: (XhrResponse -> Either Text a)

403 -> (tag, XhrResponse)

389 -> (tag, XhrResponse)

404 -> ReqResult tag a

390 -> ReqResult tag a

405−evalResponse decodeRes (tag, xhr) =

391+evalResponse decode (tag, xhr) =

406− let okStatus = _xhrResponse_status xhr < 400

392+ let status = _xhrResponse_status xhr

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

407 errMsg = fromMaybe

394 errMsg = fromMaybe

408 ("Empty response with error code " <>

395 ("Empty response with error code " <>

409 T.pack (show $ _xhrResponse_status xhr))

396 T.pack (show $ _xhrResponse_status xhr))

@@ -412,11 +399,21 @@ evalResponse decodeRes (tag, xhr) =

412 then either

399 then either

413 (\e -> ResponseFailure tag e xhr)

400 (\e -> ResponseFailure tag e xhr)

414 (\v -> ResponseSuccess tag v xhr)

401 (\v -> ResponseSuccess tag v xhr)

415− (decodeRes xhr)

402+ (decode xhr)

416 else ResponseFailure tag errMsg xhr

403 else ResponseFailure tag errMsg xhr

417 in respPayld

404 in respPayld

418

405

406+------------------------------------------------------------------------------

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

408+-- response 'Event's,

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

410+fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess

419

411

412+------------------------------------------------------------------------------

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

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

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

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

420

417

421

418

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

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

@@ -425,3 +422,10 @@ note e = maybe (Left e) Right

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

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

426fmapL _ (Right a) = Right a

423fmapL _ (Right a) = Right a

427fmapL f (Left e) = Left (f e)

424fmapL f (Left e) = Left (f e)

425+

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

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

428+

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

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

431+

src/Servant/Reflex.hs+204−107

@@ -1,24 +1,23 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

2+{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE InstanceSigs #-}

7+{-# LANGUAGE InstanceSigs #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TupleSections #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

15−{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE OverloadedStrings #-}

16−{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE Rank2Types #-}

17−{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

18−{-# LANGUAGE TupleSections #-}

13+{-# LANGUAGE TupleSections #-}

19−{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE TypeFamilies #-}

20−{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE TypeOperators #-}

21−{-# LANGUAGE UndecidableInstances #-}

16+{-# LANGUAGE UndecidableInstances #-}

17+

18+#if MIN_VERSION_base(4,9,0)

19+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

20+#endif

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

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

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

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

@@ -26,47 +25,57 @@

26-- API.

25-- API.

27module Servant.Reflex

26module Servant.Reflex

28 ( client

27 ( client

28+ , clientWithOpts

29+ , clientWithOptsAndResultHandler

30+ , clientWithRoute

31+ , clientWithRouteAndResultHandler

29 , BuildHeaderKeysTo(..)

32 , BuildHeaderKeysTo(..)

30 , toHeaders

33 , toHeaders

31− , HasClient(..)

34+ , HasClient

35+ , Client

32 , module Servant.Common.Req

36 , module Servant.Common.Req

33 , module Servant.Common.BaseUrl

37 , module Servant.Common.BaseUrl

34 ) where

38 ) where

36------------------------------------------------------------------------------

40------------------------------------------------------------------------------

37−import Data.Aeson

38import Control.Applicative

41import Control.Applicative

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

40−import qualified Data.Set as Set

41−import qualified Data.Text.Encoding as E

42−import Data.CaseInsensitive (mk)

42+import qualified Data.CaseInsensitive as CI

43import Data.Functor.Identity

44−import Data.Proxy (Proxy (..))

45import qualified Data.Map as Map

44import qualified Data.Map as Map

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

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

47+import qualified Data.Set as Set

46import Data.Text (Text)

48import Data.Text (Text)

47import qualified Data.Text as T

49import qualified Data.Text as T

50+import qualified Data.Text.Encoding as E

51+import GHC.Exts (Constraint)

48import GHC.TypeLits (KnownSymbol, symbolVal)

52import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

50− BasicAuthData, BuildHeadersTo(..),

54+ BasicAuthData, BuildHeadersTo (..),

51− Capture, contentType, Header,

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

52− Headers(..), HttpVersion, IsSecure,

56+ HttpVersion, IsSecure,

53− MimeRender(..), MimeUnrender,

57+ MimeRender (..), MimeUnrender,

54 NoContent, QueryFlag, QueryParam,

58 NoContent, QueryFlag, QueryParam,

55− QueryParams, Raw, ReflectMethod(..),

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

56 RemoteHost, ReqBody,

60 RemoteHost, ReqBody,

57− ToHttpApiData(..), Vault, Verb)

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

58−

62+ contentType)

63+import Servant.API.Description (Summary)

64+import qualified Servant.Auth as Auth

65+

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

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

60− XhrRequest(..),

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

61− XhrResponseHeaders(..),

68+ XhrResponseHeaders (..),

62− XhrResponse(..), attachPromptlyDynWith, constDyn, ffor, fmapMaybe,

69+ attachPromptlyDynWith, constDyn, ffor,

70+ fmapMaybe, leftmost,

63− leftmost, performRequestsAsync,

71+ performRequestsAsync)

64− )

65------------------------------------------------------------------------------

72------------------------------------------------------------------------------

66import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,

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

67 showBaseUrl,

74 showBaseUrl,

68 SupportsServantReflex)

75 SupportsServantReflex)

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

77+ defaultClientOptions,

69−import Servant.Common.Req (Req, ReqResult(..), QParam(..),

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

70 QueryPart(..), addHeader, authData,

79 QueryPart(..), addHeader, authData,

71 defReq, evalResponse, prependToPathParts,

80 defReq, evalResponse, prependToPathParts,

72 -- performRequestCT,

81 -- performRequestCT,

@@ -76,9 +85,10 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),

76 performSomeRequestsAsync,

85 performSomeRequestsAsync,

77 qParamToQueryPart, reqBody,

86 qParamToQueryPart, reqBody,

78 reqSuccess, reqFailure,

87 reqSuccess, reqFailure,

79− reqMethod, respHeaders, response,

88+ reqMethod, respHeaders,

89+ response,

80 reqTag,

90 reqTag,

81− qParams)

91+ qParams, withCredentials)

84-- * Accessing APIs as a Client

94-- * Accessing APIs as a Client

@@ -93,28 +103,75 @@ import Servant.Common.Req (Req, ReqResult(..), QParam(..),

93-- >

103-- >

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

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

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

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

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

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

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

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

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

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

109+client

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

110+ :: (HasClient t m layout tag)

111+ => Proxy layout

112+ -> Proxy m

113+ -> Proxy tag

114+ -> Dynamic t BaseUrl

115+ -> Client t m layout tag

116+client p q t baseurl = clientWithRoute p q t defReq baseurl defaultClientOptions

117+

118+clientWithOpts

119+ :: (HasClient t m layout tag)

120+ => Proxy layout

121+ -> Proxy m

122+ -> Proxy tag

123+ -> Dynamic t BaseUrl

124+ -> ClientOptions

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

125+ -> Client t m layout tag

101−client p q t baseurl = clientWithRoute p q t defReq baseurl

126+clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl

127+

128+-- | Like 'clientWithOpts' but allows passing a function which will process the

129+-- result event in some way. This can be used to handle errors in a uniform way

130+-- across call sites.

131+clientWithOptsAndResultHandler

132+ :: (HasClient t m layout tag)

133+ => Proxy layout

134+ -> Proxy m

135+ -> Proxy tag

136+ -> Dynamic t BaseUrl

137+ -> ClientOptions

138+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))

139+ -> Client t m layout tag

140+clientWithOptsAndResultHandler p q t = clientWithRouteAndResultHandler p q t defReq

102

141

103

142

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

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

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

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

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

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

107−class HasClient t m layout (tag :: *) where

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

108 type Client t m layout tag :: *

147 type Client t m layout tag :: *

109− clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> Client t m layout tag

148+ clientWithRoute

149+ :: Proxy layout

150+ -> Proxy m

151+ -> Proxy tag

152+ -> Req t

153+ -> Dynamic t BaseUrl

154+ -> ClientOptions

155+ -> Client t m layout tag

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

157+

158+ clientWithRouteAndResultHandler

159+ :: Proxy layout

160+ -> Proxy m

161+ -> Proxy tag

162+ -> Req t

163+ -> Dynamic t BaseUrl

164+ -> ClientOptions

165+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))

166+ -> Client t m layout tag

110

167

111

168

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

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

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

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

114

171

115− clientWithRoute Proxy q pTag req baseurl =

172+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =

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

173+ clientWithRouteAndResultHandler (Proxy :: Proxy a) q pTag req baseurl opts wrap :<|>

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

174+ clientWithRouteAndResultHandler (Proxy :: Proxy b) q pTag req baseurl opts wrap

118

175

119

176

120-- Capture. Example:

177-- Capture. Example:

@@ -129,32 +186,29 @@ instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b)

129-- -> m (Event t (l, ReqResult Book))

186-- -> m (Event t (l, ReqResult Book))

130-- > getBook = client myApi (constDyn host)

187-- > getBook = client myApi (constDyn host)

131

188

132−instance (SupportsServantReflex t m, FromJSON a, ToHttpApiData a, HasClient t m sublayout tag)

189+instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout tag)

133 => HasClient t m (Capture capture a :> sublayout) tag where

190 => HasClient t m (Capture capture a :> sublayout) tag where

134

191

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

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

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

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

137

194

138− clientWithRoute Proxy q t req baseurl val =

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

139− clientWithRoute (Proxy :: Proxy sublayout)

196+ clientWithRouteAndResultHandler

140− q t

141− (prependToPathParts p req)

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

142− baseurl

143 where p = (fmap . fmap) (toUrlPiece) val

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

144

199

145

200

146-- VERB (Returning content) --

201-- VERB (Returning content) --

147instance {-# OVERLAPPABLE #-}

202instance {-# OVERLAPPABLE #-}

148 -- Note [Non-Empty Content Types]

203 -- Note [Non-Empty Content Types]

149− (FromJSON a, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m

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

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

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

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

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

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

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

153 -- TODO how to access input types here?

208 -- TODO how to access input types here?

154 -- ExceptT ServantError IO a

209 -- ExceptT ServantError IO a

155− clientWithRoute Proxy _ _ req baseurl trigs =

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

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

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

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

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

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

159 req' = req { reqMethod = method }

213 req' = req { reqMethod = method }

160

214

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

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

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

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

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

169 -- ExceptT ServantError IO NoContent

223 -- ExceptT ServantError IO NoContent

170− clientWithRoute Proxy _ _ req baseurl =

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

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

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

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

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

173

227

174

228

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

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

176toHeaders r =

230toHeaders r =

177− let toBS = E.encodeUtf8

178− hdrs = maybe []

231+ let hdrs = maybe []

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

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

180 (Map.toList $ _xhrResponse_headers xhr))

233 (Map.toList $ _xhrResponse_headers xhr))

181 (response r)

234 (response r)

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

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

183

236

237+

184class BuildHeaderKeysTo hs where

238class BuildHeaderKeysTo hs where

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

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

186

240

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

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

188 where buildHeaderKeysTo _ = []

242 where buildHeaderKeysTo _ = []

189

243

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

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

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

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

246+ buildHeaderKeysTo _ =

247+ let

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

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

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

250+

193

251

194-- HEADERS Verb (Content) --

252-- HEADERS Verb (Content) --

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

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

@@ -199,16 +257,15 @@ instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)

199instance {-# OVERLAPPABLE #-}

257instance {-# OVERLAPPABLE #-}

200 -- Note [Non-Empty Content Types]

258 -- Note [Non-Empty Content Types]

201 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

259 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

202− FromJSON a,

203 ReflectMethod method, cts' ~ (ct ': cts),

260 ReflectMethod method, cts' ~ (ct ': cts),

204 SupportsServantReflex t m

261 SupportsServantReflex t m

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

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

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

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

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

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

208− clientWithRoute Proxy _ _ req baseurl trigs = do

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

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

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

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

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

211− return $ toHeaders <$> resp

268+ wrap $ toHeaders <$> resp

212 where req' = req { respHeaders =

269 where req' = req { respHeaders =

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

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

214 }

271 }

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

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

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

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

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

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

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

224− clientWithRoute Proxy _ _ req baseurl trigs = do

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

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

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

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

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

227− return $ toHeaders <$> resp

284+ wrap $ toHeaders <$> resp

228 where req' = req {respHeaders =

285 where req' = req {respHeaders =

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

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

230 }

287 }

@@ -251,11 +308,11 @@ instance (KnownSymbol sym, ToHttpApiData a,

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

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

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

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

253

310

254− clientWithRoute Proxy q t req baseurl eVal =

311+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =

312+ clientWithRouteAndResultHandler

255− clientWithRoute (Proxy :: Proxy sublayout)

313+ (Proxy :: Proxy sublayout) q t

256− q t

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

314+ (Servant.Common.Req.addHeader hname eVal req)

258− baseurl

315+ baseurl opts wrap

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

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

260

317

261

318

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

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

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

270 Client t m sublayout tag

327 Client t m sublayout tag

271

328

272− clientWithRoute Proxy q t =

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 =

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

341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

342+

343+

274

344

275

345

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

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

@@ -306,9 +376,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex

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

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

307

377

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

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

309− clientWithRoute Proxy q t req baseurl mparam =

379+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =

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

380+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t

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

381+ (req {qParams = paramPair : qParams req}) baseurl opts wrap

312

382

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

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

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

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

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

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

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

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

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

354

424

355− clientWithRoute Proxy q t req baseurl paramlist =

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

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

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

357

427

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

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

359 pname = symbolVal (Proxy :: Proxy sym)

429 pname = symbolVal (Proxy :: Proxy sym)

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

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

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

393 Dynamic t Bool -> Client t m sublayout tag

463 Dynamic t Bool -> Client t m sublayout tag

394

464

395− clientWithRoute Proxy q t req baseurl flag =

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

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

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

397

467

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

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

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

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

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

407 -> Event t tag

477 -> Event t tag

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

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

409

479

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

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

411

481

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

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

413 Left e -> Left e

483 Left e -> Left e

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

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

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

419

489

420 resps <- performRequestsAsync okReq

490 resps <- performRequestsAsync okReq

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

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

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

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

423 ]

493 ]

424

494

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

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

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

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

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

451

521

452− clientWithRoute Proxy q t req baseurl body =

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

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

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

454 where req' = req { reqBody = bodyBytesCT }

524 where req' = req { reqBody = bodyBytesCT }

455 ctProxy = Proxy :: Proxy ct

525 ctProxy = Proxy :: Proxy ct

456 ctString = T.pack $ show $ contentType ctProxy

526 ctString = T.pack $ show $ contentType ctProxy

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

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

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

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

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

466

536

467− clientWithRoute Proxy q t req baseurl =

537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =

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

538+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t

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

539+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap

470

540

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

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

472

542

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

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

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

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

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

476

546

477− clientWithRoute Proxy q t req baseurl =

547+ clientWithRouteAndResultHandler Proxy =

478− clientWithRoute (Proxy :: Proxy api) q t req baseurl

548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

479

549

480

550

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

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

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

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

483

553

484− clientWithRoute Proxy q t req baseurl =

554+ clientWithRouteAndResultHandler Proxy =

485− clientWithRoute (Proxy :: Proxy api) q t req baseurl

555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

486

556

487

557

488

558

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

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

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

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

491

561

492− clientWithRoute Proxy q t req baseurl =

562+ clientWithRouteAndResultHandler Proxy =

493− clientWithRoute (Proxy :: Proxy api) q t req baseurl

563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

494

564

495

565

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

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

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

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

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

500 -> Client t m api tag

570 -> Client t m api tag

501

571

502− clientWithRoute Proxy q t req baseurl authdata =

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

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

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

504 where

574 where

505 req' = req { authData = Just authdata }

575 req' = req { authData = Just authdata }

506

576

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

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

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

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

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

528-}

598-}

599+

600+

601+-- SUPPORT FOR servant-auth --

602+

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

604+-- way that is inaccessible to JavaScript.

605+--

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

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

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

609+-- directly.

610+

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

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

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

614+

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

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

617+

618+

619+type family HasCookieAuth xs :: Constraint where

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

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

622+ HasCookieAuth '[] = CookieAuthNotEnabled

623+

624+class CookieAuthNotEnabled

625+

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

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

16module Servant.Reflex.Multi (

17 -- * Compute servant client functions

18 clientA

19+ , clientWithOptsA

19 , BaseUrl(..)

20 , BaseUrl(..)

20 , Scheme(..)

21 , Scheme(..)

22 -- * Build QueryParam arguments

23 -- * Build QueryParam arguments

23 , QParam(..)

24 , QParam(..)

26+ -- * Access response data

27+ , withCredentials

26 -- * Access response data

29 -- * Access response data

27 , ReqResult(..)

30 , ReqResult(..)

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

34 ) where

37 ) where

36------------------------------------------------------------------------------

39------------------------------------------------------------------------------

37−import Data.Aeson

38−import Control.Applicative (liftA2)

40+import Control.Applicative (liftA2)

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

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

40−import Data.Proxy (Proxy (..))

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

41−import qualified Data.Set as Set

43+import qualified Data.Set as Set

42−import Data.Text (Text)

44+import Data.Text (Text)

43−import qualified Data.Text as T

45+import qualified Data.Text as T

44−import qualified Data.Text.Encoding as E

46+import qualified Data.Text.Encoding as E

45−import GHC.TypeLits (KnownSymbol, symbolVal)

47+import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

47− BasicAuthData, BuildHeadersTo (..),

49+ BasicAuthData, BuildHeadersTo (..),

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

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

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

51+ HttpVersion, IsSecure,

52+ MimeRender (..), MimeUnrender,

50− MimeUnrender, NoContent, QueryFlag,

53+ NoContent, QueryFlag, QueryParam,

51− QueryParam, QueryParams, Raw,

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

52− ReflectMethod (..), RemoteHost,

55+ RemoteHost, ReqBody,

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

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

54− Verb, contentType)

57+ contentType)

55−

58+import Servant.API.Description (Summary)

59+

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

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

57− XhrRequest (..),

61+ XhrRequest (..),

58− XhrResponseHeaders (..),

62+ XhrResponseHeaders (..),

59− attachPromptlyDynWith, constDyn)

63+ attachPromptlyDynWith, constDyn)

60------------------------------------------------------------------------------

64------------------------------------------------------------------------------

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

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

62 SupportsServantReflex)

66 SupportsServantReflex)

67+import Servant.Common.Req (ClientOptions,

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

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

64 ReqResult (..), addHeader, authData,

69 ReqResult (..), addHeader, authData,

70+ defReq,

71+ defaultClientOptions,

65− defReq, performRequestsCT,

72+ performRequestsCT,

66 performRequestsNoBody,

73 performRequestsNoBody,

67 performSomeRequestsAsync,

74 performSomeRequestsAsync,

68 prependToPathParts, qParamToQueryPart,

75 prependToPathParts, qParamToQueryPart,

69 qParams, reqBody, reqFailure,

76 qParams, reqBody, reqFailure,

70 reqMethod, reqSuccess, reqSuccess',

77 reqMethod, reqSuccess, reqSuccess',

71− respHeaders, response)

78+ respHeaders, response, withCredentials)

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

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

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

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

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

79clientA p q f tag baseurl =

86clientA p q f tag baseurl =

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

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

88+ defaultClientOptions

89+

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

83------------------------------------------------------------------------------

100------------------------------------------------------------------------------

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

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

85 type ClientMulti t m layout f tag :: *

102 type ClientMulti t m layout f tag :: *

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

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

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

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

88− -> ClientMulti t m layout f tag

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

106

107

91------------------------------------------------------------------------------

108------------------------------------------------------------------------------

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

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

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

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

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

95 ClientMulti t m b f tag

112 ClientMulti t m b f tag

96− clientWithRouteMulti Proxy q f tag reqs baseurl =

113+ clientWithRouteMulti Proxy q f tag reqs baseurl opts =

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

114+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>

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

115+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts

116

100

117

101------------------------------------------------------------------------------

118------------------------------------------------------------------------------

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

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

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

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

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

110

127

111− clientWithRouteMulti _ q f tag reqs baseurl vals =

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

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

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

113 where

130 where

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

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

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

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

@@ -120,7 +137,6 @@ instance (SupportsServantReflex t m,

120instance {-# OVERLAPPABLE #-}

137instance {-# OVERLAPPABLE #-}

121 -- Note [Non-Empty Content Types]

138 -- Note [Non-Empty Content Types]

122 (MimeUnrender ct a,

139 (MimeUnrender ct a,

123− FromJSON a,

124 ReflectMethod method, cts' ~ (ct ': cts),

140 ReflectMethod method, cts' ~ (ct ': cts),

125 SupportsServantReflex t m,

141 SupportsServantReflex t m,

126 Applicative f,

142 Applicative f,

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

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

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

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

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

132

148

133− clientWithRouteMulti _ _ _ _ reqs baseurl =

149+ clientWithRouteMulti _ _ _ _ reqs baseurl opts =

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

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

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

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

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

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

137

153

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

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

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

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

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

147 -- ExceptT ServantError IO NoContent

163 -- ExceptT ServantError IO NoContent

148− clientWithRouteMulti Proxy _ _ _ req baseurl =

164+ clientWithRouteMulti Proxy _ _ _ req baseurl opts =

149− performRequestsNoBody method req baseurl

165+ performRequestsNoBody method req baseurl opts

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

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

151

167

152

168

@@ -154,16 +170,15 @@ instance {-# OVERLAPPING #-}

154instance {-# OVERLAPPABLE #-}

170instance {-# OVERLAPPABLE #-}

155 -- Note [Non-Empty Content Types]

171 -- Note [Non-Empty Content Types]

156 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

172 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

157− FromJSON a,

158 ReflectMethod method, cts' ~ (ct ': cts),

173 ReflectMethod method, cts' ~ (ct ': cts),

159 SupportsServantReflex t m,

174 SupportsServantReflex t m,

160 Traversable f

175 Traversable f

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

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

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

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

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

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

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

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

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

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

166− 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)))

167 return $ fmap toHeaders <$> resp

182 return $ fmap toHeaders <$> resp

168 where

183 where

169 reqs' = fmap (\r ->

184 reqs' = fmap (\r ->

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

184 cts (Headers ls NoContent)) f tag where

199 cts (Headers ls NoContent)) f tag where

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

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

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

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

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

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

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

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

189− resp <- performRequestsNoBody method reqs' baseurl triggers

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

190 return $ fmap toHeaders <$> resp

205 return $ fmap toHeaders <$> resp

191 where reqs' = fmap (\req ->

206 where reqs' = fmap (\req ->

192 req {respHeaders = OnlyHeaders (Set.fromList

207 req {respHeaders = OnlyHeaders (Set.fromList

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

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

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

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

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

208

223

209− clientWithRouteMulti Proxy f q tag reqs baseurl eVals =

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

210 clientWithRouteMulti (Proxy :: Proxy sublayout) f

225 clientWithRouteMulti (Proxy :: Proxy sublayout) f

211 q tag

226 q tag

212 reqs'

227 reqs'

213− baseurl

228+ baseurl opts

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

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

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

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

216 <$> eVals <*>) <$> reqs

231 <$> eVals <*>) <$> reqs

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

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

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

228

243

229

244

245+------------------------------------------------------------------------------

246+instance (HasClientMulti t m sublayout f tag, KnownSymbol sym)

247+ => HasClientMulti t m (Summary sym :> sublayout) f tag where

248+

249+ type ClientMulti t m (Summary sym :> sublayout) f tag =

250+ ClientMulti t m sublayout f tag

251+

252+ clientWithRouteMulti Proxy q f tag =

253+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

254+

255+

230------------------------------------------------------------------------------

256------------------------------------------------------------------------------

231instance (KnownSymbol sym,

257instance (KnownSymbol sym,

232 ToHttpApiData a,

258 ToHttpApiData a,

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

240

266

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

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

242 -- TODO: Check the above comment

268 -- TODO: Check the above comment

243− clientWithRouteMulti Proxy q f tag reqs baseurl mparams =

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

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

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

245− reqs' baseurl

271+ reqs' baseurl opts

246

272

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

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

248 p prm = QueryPartParam $ fmap qParamToQueryPart prm

274 p prm = QueryPartParam $ fmap qParamToQueryPart prm

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

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

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

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

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

265

291

266− clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =

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

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

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

268

294

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

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

270 pname = symbolVal (Proxy :: Proxy sym)

296 pname = symbolVal (Proxy :: Proxy sym)

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

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

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

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

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

284

310

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

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

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

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

287

313

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

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

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

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

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

297 -> Event t tag

323 -> Event t tag

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

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

299

325

300− clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do

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

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

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

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

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

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

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

304 return resps

330 return resps

305 where

331 where

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

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

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

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

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

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

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

318

344

319− clientWithRouteMulti Proxy q f tag reqs baseurl bodies =

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

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

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

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

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

322 ctProxy = Proxy :: Proxy ct

348 ctProxy = Proxy :: Proxy ct

323 ctString = T.pack $ show $ contentType ctProxy

349 ctString = T.pack $ show $ contentType ctProxy

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

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

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

369 -> ClientMulti t m api f tag

395 -> ClientMulti t m api f tag

370

396

371− clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =

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

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

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

373 where

399 where

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

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

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

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

testdriver/test/Servant/ReflexSpec.hs+2−1

@@ -9,6 +9,7 @@ import qualified Data.Text as T

9import Data.Foldable

10import Test.WebDriver.Commands.Wait

11import Test.Hspec.WebDriver

12+import Test.Hspec.WebDriver (chromeCaps)

14clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()

15clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()

@@ -28,7 +29,7 @@ spec :: Spec

28spec = do

29spec = do

29 describe "servant-reflex tests" $ do

30 describe "servant-reflex tests" $ do

31− session "test page" $ using Chrome $ do

32+ session "test page" $ using [chromeCaps] $ do

33 it "opens the page" $ runWD $

34 it "opens the page" $ runWD $

34 openPage "http://localhost:8000"

35 openPage "http://localhost:8000"

testserver/API.hsmode 120000 → 100644+69−1

@@ -1 +0,0 @@

1−../exec/API.hs

@@ -0,0 +1,69 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeOperators #-}

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 @@

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE TypeApplications #-}

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeOperators #-}

8import Control.Monad.IO.Class (liftIO)

9import Control.Monad.IO.Class (liftIO)

10+import Control.Monad.Reader (reader)

9import Data.Aeson

11import Data.Aeson

10import Data.Bool

12import Data.Bool

11import Data.Char (toUpper)

13import Data.Char (toUpper)

12import qualified Data.List as L

14import qualified Data.List as L

15+import Data.Maybe (fromMaybe)

13import Data.Monoid

16import Data.Monoid

14import Data.Proxy

17import Data.Proxy

15import Data.Text hiding (head, length, map,

18import Data.Text hiding (head, length, map,

@@ -24,6 +27,7 @@ import Snap.Http.Server

24import Servant

27import Servant

25import Servant.Server

28import Servant.Server

26-- import Snap.Util.FileServe

29-- import Snap.Util.FileServe

30+import System.Environment (lookupEnv)

27import API

31import API

28import Snap

32import Snap

@@ -39,7 +43,7 @@ instance ToJSON Greet

39testApi :: Proxy API

43testApi :: Proxy API

40testApi = Proxy

44testApi = Proxy

42−data App = App

46+data App = App { appStaticDir :: String }

44-- Server-side handlers.

48-- Server-side handlers.

45--

49--

@@ -47,8 +51,10 @@ data App = App

47-- that represents the API, are glued together using :<|>.

51-- that represents the API, are glued together using :<|>.

48--

52--

49-- Each handler runs in the 'ExceptT ServantErr IO' monad.

53-- 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

52 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text

58 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text

53 sayhi nm greetings withGusto = case nm of

59 sayhi nm greetings withGusto = case nm of

54 Nothing -> return ("Sorry, who are you?" :: Text)

60 Nothing -> return ("Sorry, who are you?" :: Text)

@@ -69,18 +75,27 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|>

69 putStrLn $ "qna got: " ++ show q

75 putStrLn $ "qna got: " ++ show q

70 T.putStrLn $ unQuestion q

76 T.putStrLn $ unQuestion q

71 return $ Answer $ unQuestion q

77 return $ Answer $ unQuestion q

78+ serveSecret _ = do

79+ req <- getRequest

80+ liftIO $ putStrLn (show req)

81+ return 101

82+ statics = do

83+ staticDir <- reader appStaticDir

84+ serveDirectory staticDir

73-- Turn the server into a WAI app. 'serve' is provided by servant,

86-- Turn the server into a WAI app. 'serve' is provided by servant,

74-- more precisely by the Servant.Server module.

87-- more precisely by the Servant.Server module.

75test :: Handler App App ()

88test :: Handler App App ()

76−test = serveSnap testApi server

89+test = serveSnapWithContext testApi

90+ (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server

78initApp :: SnapletInit App App

92initApp :: SnapletInit App App

79initApp = makeSnaplet "myapp" "example" Nothing $ do

93initApp = makeSnaplet "myapp" "example" Nothing $ do

94+ staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")

80 addRoutes [("", test)

95 addRoutes [("", test)

81 ,("", serveDirectory "static")

96 ,("", serveDirectory "static")

82 ]

97 ]

83− return App

98+ return (App staticDir)

85-- Put this all to work!

100-- Put this all to work!

86main :: IO ()

101main :: IO ()

testserver/run-wd-tests.shdeleted−5

@@ -1,5 +0,0 @@

1−#!/usr/bin/env bash

2−

3−dist/build/back/back -p 8000 &

4−phantomjs --webdriver=127.0.0.1:4444 &

5−dist/build/spec/spec

testserver/testserver.cabal+8−7

@@ -19,13 +19,14 @@ executable back

19 main-is: Main.hs

20 -- other-modules:

21 -- other-extensions:

22− build-depends: aeson >= 0.9 && < 1.1

22+ build-depends: aeson >= 0.9 && < 1.5

23− , base >=4.8 && <4.10

23+ , base >=4.8 && < 5

24+ , mtl

24− , snap >= 1.0 && < 1.1

25+ , snap >= 1.0 && < 1.2

25− , snap-server >= 1.0 && < 1.1

26+ , snap-server >= 1.0 && < 1.2

26 , snap-core >= 1.0 && < 1.1

27 , snap-core >= 1.0 && < 1.1

27− , servant >= 0.8 && < 0.11

28+ , servant >= 0.16 && < 0.18

28− , servant-snap >= 0.7.2 && < 0.8

29+ , servant-snap >= 0.8 && < 0.9

29− , text >= 1.2 && < 1.3

30+ , text >= 1.0 && < 1.3

30 -- hs-source-dirs:

31 -- hs-source-dirs:

31 default-language: Haskell2010

32 default-language: Haskell2010

testserver/tr.nixdeleted−32

@@ -1,32 +0,0 @@

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

2−let

3−

4− dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;

5− cabal2nixResult = reflex-platform.cabal2nixResult;

6− nixpkgs = (import <nixpkgs> {});

7−in

8−reflex-platform.ghc.override {

9− overrides = self: super: {

10− servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});

11− snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap) {});

12− io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});

13− io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});

14− heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});

15− xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});

16− snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});

17− snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});

18− snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});

19− snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});

20− hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});

21−

22− # servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});

23− # servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});

24− # servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});

25− # servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});

26− # servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});

27− # servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});

28− # servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});

29− # servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});

30−

31− };

32−}

travis.nixnew file+70

@@ -0,0 +1,70 @@

1+{

2+ nativeCompiler ? "ghc",

3+ # ^ Choose a GHC for compiling backend components (web server, selenium)

4+ # (ghc, ghc8_0, ghc8_2, ghc8_4 or ghcHEAD)

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+ }