e6ffdc5...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 bytestring >= 0.10 && < 0.11,

28 bytestring >= 0.10 && < 0.11,

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

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

32− containers >= 0.5.6 && < 0.6,

30+ containers >= 0.5.6 && < 0.7,

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

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

34− exceptions >= 0.8 && < 0.9,

32+ exceptions >= 0.8 && < 0.11,

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

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

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

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

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

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

38 jsaddle >= 0.8 && < 0.10,

36 jsaddle >= 0.8 && < 0.10,

39 mtl >= 2.2.1 && < 2.3,

37 mtl >= 2.2.1 && < 2.3,

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

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

41− reflex >= 0.5 && < 0.6,

39+ reflex >= 0.5 && < 0.9,

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

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

43 safe >= 0.3.9 && < 0.4,

41 safe >= 0.3.9 && < 0.4,

44− servant >= 0.8 && < 0.12,

42+ servant >= 0.16 && < 0.18,

45− servant-auth >= 0.2.7 && < 0.2.8,

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+105−92

@@ -4,18 +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)

17import Data.Bifunctor (first)

19import Data.Bifunctor (first)

20+import qualified Data.ByteString.Builder as Builder

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

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

22+import Data.ByteString (ByteString)

19import qualified Data.Map as Map

23import qualified Data.Map as Map

20import Data.Maybe (catMaybes, fromMaybe)

24import Data.Maybe (catMaybes, fromMaybe)

21import Data.Functor.Compose

25import Data.Functor.Compose

@@ -25,8 +29,9 @@ import Data.Text (Text)

25import qualified Data.Text as T

29import qualified Data.Text as T

26import qualified Data.Text.Encoding as TE

30import qualified Data.Text.Encoding as TE

27import Data.Traversable (forM)

31import Data.Traversable (forM)

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

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

33+import qualified Network.URI as N

29−import Reflex.Dom hiding (tag)

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

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

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

31 SupportsServantReflex)

36 SupportsServantReflex)

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

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

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

47 -- ^ 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

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

51------------------------------------------------------------------------------

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

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

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

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

71reqFailure (RequestFailure _ s) = Just s

93reqFailure (RequestFailure _ s) = Just s

72reqFailure _ = 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

75------------------------------------------------------------------------------

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

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

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

@@ -138,7 +167,7 @@ reqToReflexRequest

138 => Text

167 => Text

139 -> Dynamic t BaseUrl

168 -> Dynamic t BaseUrl

140 -> Req t

169 -> Req t

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

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

142reqToReflexRequest reqMeth reqHost req =

171reqToReflexRequest reqMeth reqHost req =

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

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

144 t = sequence $ reverse $ reqPathParts req

173 t = sequence $ reverse $ reqPathParts req

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

150 urlParts = fmap sequence t

179 urlParts = fmap sequence t

151

180

152 urlPath :: Dynamic t (Either Text Text)

181 urlPath :: Dynamic t (Either Text Text)

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

182+ urlPath = (fmap.fmap)

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

184+ urlParts

154

185

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

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

156 queryPartString (pName, qp) = case qp of

187 queryPartString (pName, qp) = case qp of

157 QueryPartParam p -> ffor p $ \case

188 QueryPartParam p -> ffor p $ \case

158 Left e -> Just (Left e)

189 Left e -> Just (Left e)

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

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

160 Right Nothing -> Nothing

191 Right Nothing -> Nothing

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

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

162 if null pStrings

193 if null pStrings

163 then Nothing

194 then Nothing

195+ else Just . Right

196+ . T.intercalate "&"

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

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

165 QueryPartFlag fl -> ffor fl $ \case

198 QueryPartFlag fl -> ffor fl $ \case

166 True -> Just $ Right pName

199 True -> Just $ Right pName

167 False -> Nothing

200 False -> Nothing

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

196 Right $ XhrRequestConfig

229 Right $ XhrRequestConfig

197 { _xhrRequestConfig_sendData = bytesToPayload bBytes

230 { _xhrRequestConfig_sendData = bytesToPayload bBytes

198 , _xhrRequestConfig_headers =

231 , _xhrRequestConfig_headers =

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

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

200 , _xhrRequestConfig_user = Nothing

233 , _xhrRequestConfig_user = Nothing

201 , _xhrRequestConfig_password = Nothing

234 , _xhrRequestConfig_password = Nothing

202− , _xhrRequestConfig_responseType = Nothing

235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

203 , _xhrRequestConfig_withCredentials = False

236 , _xhrRequestConfig_withCredentials = False

204 , _xhrRequestConfig_responseHeaders = def

237 , _xhrRequestConfig_responseHeaders = def

205 }

238 }

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

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

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

212 , _xhrRequestConfig_user = Nothing

245 , _xhrRequestConfig_user = Nothing

213 , _xhrRequestConfig_password = Nothing

246 , _xhrRequestConfig_password = Nothing

214− , _xhrRequestConfig_responseType = Nothing

247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

215− , _xhrRequestConfig_sendData = ""

248+ , _xhrRequestConfig_sendData = mempty

216 , _xhrRequestConfig_withCredentials = False

249 , _xhrRequestConfig_withCredentials = False

217 }

250 }

218 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

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

239displayHttpRequest :: Text -> Text

272displayHttpRequest :: Text -> Text

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

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

241

274

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

275+-- | This function performs the request

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

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

244 => Text

277 => Text

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

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

246 -> Dynamic t BaseUrl

279 -> Dynamic t BaseUrl

280+ -> ClientOptions

247 -> Event t tag

281 -> Event t tag

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

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

249−performRequests reqMeth rs reqHost trigger = do

283+performRequests reqMeth rs reqHost opts trigger = do

250− -- 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 $

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

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

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

291+

253− resps <- performSomeRequestsAsync reqs

292+ resps <- performSomeRequestsAsync opts reqs

254 return $ getCompose <$> resps

293 return $ getCompose <$> resps

255

294

256−-- | 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.

257performSomeRequestsAsync

298performSomeRequestsAsync

258 :: (MonadIO (Performable m),

299 :: (MonadIO (Performable m),

259 MonadJSM (Performable m),

300 MonadJSM (Performable m),

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

261 PerformEvent t m,

302 PerformEvent t m,

262 TriggerEvent t m,

303 TriggerEvent t m,

263 Traversable f,

304 Traversable f,

264− IsXhrPayload a)

305+ IsXhrPayload a,

306+ Show a

307+ )

308+ => ClientOptions

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

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

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

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

311+performSomeRequestsAsync opts =

267−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return

312+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

268

313

269

314

270------------------------------------------------------------------------------

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

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

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

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

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

273performSomeRequestsAsync'

318performSomeRequestsAsync'

274− :: (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

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

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

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

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

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

278 rs <- hrs

324 rs <- hrs

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

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

280 Left e -> do

326 Left e -> do

@@ -282,70 +328,17 @@ performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb ->

282 return resp

328 return resp

283 Right r' -> do

329 Right r' -> do

284 resp <- liftIO newEmptyMVar

330 resp <- liftIO newEmptyMVar

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

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

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

286 return resp

333 return resp

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

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

288 return ()

335 return ()

289

336

290

337

291

338

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

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

294− => Text

295− -> (Req t)

296− -> Dynamic t BaseUrl

297− -> Event t tag

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

299−performRequest reqMeth req reqHost trigger = do

300−

301− let xhrReq = reqToReflexRequest reqMeth reqHost req

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

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

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

305−

306− resps <- performRequestsAsync okReqs

307−

308− return (resps, badReqs)

309−

310−

311−type XhrPayload = T.Text

339+type XhrPayload = ByteString

312bytesToPayload :: BL.ByteString -> XhrPayload

340bytesToPayload :: BL.ByteString -> XhrPayload

313−bytesToPayload = TE.decodeUtf8 . BL.toStrict

341+bytesToPayload = BL.toStrict

314−

315−

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

317−-- => Text

318−-- -> Req t

319−-- -> Dynamic t BaseUrl

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

321−-- performRequestNoBody reqMeth req reqHost trigger = do

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

323−-- let decodeResp = const $ Right NoContent

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

325−-- , fmap (uncurry RequestFailure) badReq

326−-- ]

327−

328−

329−-- performRequestCT

330−-- :: (SupportsServantReflex t m,

331−-- MimeUnrender ct a)

332−-- => Proxy ct

333−-- -> Text

334−-- -> Req t

335−-- -> Dynamic t BaseUrl

336−-- -> Event t tag

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

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

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

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

341−-- mimeUnrender ct .

342−-- BL.fromStrict .

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

344−-- (_xhrResponse_responseText x)

345−

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

347−-- , fmap (uncurry RequestFailure) badReq

348−-- ]

349

342

350

343

351performRequestsCT

344performRequestsCT

@@ -355,19 +348,20 @@ performRequestsCT

355 -> Text

348 -> Text

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

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

357 -> Dynamic t BaseUrl

350 -> Dynamic t BaseUrl

351+ -> ClientOptions

358 -> Event t tag

352 -> Event t tag

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

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

360−performRequestsCT ct reqMeth reqs reqHost trigger = do

354+performRequestsCT ct reqMeth reqs reqHost opts trigger = do

361− resps <- performRequests reqMeth reqs reqHost trigger

355+ resps <- performRequests reqMeth reqs reqHost opts trigger

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

362− let decodeResp x = first T.pack .

357+ first T.pack .

363− mimeUnrender ct .

358+ mimeUnrender ct $

364− BL.fromStrict .

359+ BL.fromStrict x

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

360+ decodeResp _ = Left "No body"

366− (_xhrResponse_responseText x)

367 return $ fmap

361 return $ fmap

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

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

369 Left e -> RequestFailure t e

363 Left e -> RequestFailure t e

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

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

371 )

365 )

372 resps

366 resps

373

367

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

378 => Text

372 => Text

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

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

380 -> Dynamic t BaseUrl

374 -> Dynamic t BaseUrl

375+ -> ClientOptions

381 -> Event t tag

376 -> Event t tag

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

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

383−performRequestsNoBody reqMeth reqs reqHost trigger = do

378+performRequestsNoBody reqMeth reqs reqHost opts trigger = do

384− resps <- performRequests reqMeth reqs reqHost trigger

379+ resps <- performRequests reqMeth reqs reqHost opts trigger

385 let decodeResp = const $ Right NoContent

380 let decodeResp = const $ Right NoContent

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

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

387 Left e -> RequestFailure tag e

382 Left e -> RequestFailure tag e

@@ -394,7 +389,8 @@ evalResponse

394 -> (tag, XhrResponse)

389 -> (tag, XhrResponse)

395 -> ReqResult tag a

390 -> ReqResult tag a

396evalResponse decode (tag, xhr) =

391evalResponse decode (tag, xhr) =

397− let okStatus = _xhrResponse_status xhr < 400

392+ let status = _xhrResponse_status xhr

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

398 errMsg = fromMaybe

394 errMsg = fromMaybe

399 ("Empty response with error code " <>

395 ("Empty response with error code " <>

400 T.pack (show $ _xhrResponse_status xhr))

396 T.pack (show $ _xhrResponse_status xhr))

@@ -407,7 +403,17 @@ evalResponse decode (tag, xhr) =

407 else ResponseFailure tag errMsg xhr

403 else ResponseFailure tag errMsg xhr

408 in respPayld

404 in respPayld

409

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

410

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'

411

417

412

418

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

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

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

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

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

417fmapL _ (Right a) = Right a

423fmapL _ (Right a) = Right a

418fmapL 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+154−82

@@ -8,6 +8,7 @@

8{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE Rank2Types #-}

11{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE TupleSections #-}

13{-# LANGUAGE TupleSections #-}

13{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeFamilies #-}

@@ -24,48 +25,57 @@

24-- API.

25-- API.

25module Servant.Reflex

26module Servant.Reflex

26 ( client

27 ( client

28+ , clientWithOpts

29+ , clientWithOptsAndResultHandler

30+ , clientWithRoute

31+ , clientWithRouteAndResultHandler

27 , BuildHeaderKeysTo(..)

32 , BuildHeaderKeysTo(..)

28 , toHeaders

33 , toHeaders

29− , HasClient(..)

34+ , HasClient

35+ , Client

30 , module Servant.Common.Req

36 , module Servant.Common.Req

31 , module Servant.Common.BaseUrl

37 , module Servant.Common.BaseUrl

32 ) where

38 ) where

34------------------------------------------------------------------------------

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

35import Control.Applicative

41import Control.Applicative

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

37−import qualified Data.Set as Set

38−import qualified Data.Text.Encoding as E

39−import Data.CaseInsensitive (mk)

42+import qualified Data.CaseInsensitive as CI

40import Data.Functor.Identity

43import Data.Functor.Identity

41−import Data.Proxy (Proxy (..))

42import 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

43import Data.Text (Text)

48import Data.Text (Text)

44import qualified Data.Text as T

49import qualified Data.Text as T

50+import qualified Data.Text.Encoding as E

45import GHC.Exts (Constraint)

51import GHC.Exts (Constraint)

46import GHC.TypeLits (KnownSymbol, symbolVal)

52import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

48− BasicAuthData, BuildHeadersTo(..),

54+ BasicAuthData, BuildHeadersTo (..),

49− Capture, contentType, Header,

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

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

56+ HttpVersion, IsSecure,

51− MimeRender(..), MimeUnrender,

57+ MimeRender (..), MimeUnrender,

52 NoContent, QueryFlag, QueryParam,

58 NoContent, QueryFlag, QueryParam,

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

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

54 RemoteHost, ReqBody,

60 RemoteHost, ReqBody,

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

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

62+ contentType)

63+import Servant.API.Description (Summary)

56import qualified Servant.Auth as Auth

64import qualified Servant.Auth as Auth

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

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

59− XhrRequest(..),

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

60− XhrResponseHeaders(..),

68+ XhrResponseHeaders (..),

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

69+ attachPromptlyDynWith, constDyn, ffor,

70+ fmapMaybe, leftmost,

62− leftmost, performRequestsAsync,

71+ performRequestsAsync)

63− )

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

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

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

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

66 showBaseUrl,

74 showBaseUrl,

67 SupportsServantReflex)

75 SupportsServantReflex)

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

77+ defaultClientOptions,

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

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

69 QueryPart(..), addHeader, authData,

79 QueryPart(..), addHeader, authData,

70 defReq, evalResponse, prependToPathParts,

80 defReq, evalResponse, prependToPathParts,

71 -- performRequestCT,

81 -- performRequestCT,

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

75 performSomeRequestsAsync,

85 performSomeRequestsAsync,

76 qParamToQueryPart, reqBody,

86 qParamToQueryPart, reqBody,

77 reqSuccess, reqFailure,

87 reqSuccess, reqFailure,

78− reqMethod, respHeaders, response,

88+ reqMethod, respHeaders,

89+ response,

79 reqTag,

90 reqTag,

80− qParams)

91+ qParams, withCredentials)

83-- * Accessing APIs as a Client

94-- * Accessing APIs as a Client

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

92-- >

103-- >

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

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

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

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

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

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

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

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

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

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

109+client

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

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

125+ -> Client t m layout tag

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

101

141

102

142

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

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

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

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

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

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

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

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

107 type Client t m layout tag :: *

147 type Client t m layout tag :: *

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

109

167

110

168

111instance (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

112 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

113

171

114− clientWithRoute Proxy q pTag req baseurl =

172+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =

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

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

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

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

117

175

118

176

119-- Capture. Example:

177-- Capture. Example:

@@ -134,11 +192,9 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout ta

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

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

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

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

136

194

137− clientWithRoute Proxy q t req baseurl val =

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

138− clientWithRoute (Proxy :: Proxy sublayout)

196+ clientWithRouteAndResultHandler

139− q t

140− (prependToPathParts p req)

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

141− baseurl

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

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

143

199

144

200

@@ -151,9 +207,8 @@ instance {-# OVERLAPPABLE #-}

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

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

152 -- TODO how to access input types here?

208 -- TODO how to access input types here?

153 -- ExceptT ServantError IO a

209 -- ExceptT ServantError IO a

154− clientWithRoute Proxy _ _ req baseurl trigs =

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

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

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

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

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

158 req' = req { reqMethod = method }

213 req' = req { reqMethod = method }

159

214

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

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

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

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

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

168 -- ExceptT ServantError IO NoContent

223 -- ExceptT ServantError IO NoContent

169− clientWithRoute Proxy _ _ req baseurl =

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

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

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

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

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

172

227

173

228

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

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

175toHeaders r =

230toHeaders r =

176− let toBS = E.encodeUtf8

177− hdrs = maybe []

231+ let hdrs = maybe []

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

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

179 (Map.toList $ _xhrResponse_headers xhr))

233 (Map.toList $ _xhrResponse_headers xhr))

180 (response r)

234 (response r)

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

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

182

236

237+

183class BuildHeaderKeysTo hs where

238class BuildHeaderKeysTo hs where

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

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

185

240

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

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

187 where buildHeaderKeysTo _ = []

242 where buildHeaderKeysTo _ = []

188

243

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

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

190 => 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))

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

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

250+

192

251

193-- HEADERS Verb (Content) --

252-- HEADERS Verb (Content) --

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

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

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

203 ) => 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

204 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 =

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

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

206− clientWithRoute Proxy _ _ req baseurl trigs = do

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

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

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

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

209− return $ toHeaders <$> resp

268+ wrap $ toHeaders <$> resp

210 where req' = req { respHeaders =

269 where req' = req { respHeaders =

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

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

212 }

271 }

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

219 ) => 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

220 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

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

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

222− clientWithRoute Proxy _ _ req baseurl trigs = do

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

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

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

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

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

225− return $ toHeaders <$> resp

284+ wrap $ toHeaders <$> resp

226 where req' = req {respHeaders =

285 where req' = req {respHeaders =

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

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

228 }

287 }

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

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

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

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

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

251

310

252− clientWithRoute Proxy q t req baseurl eVal =

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

312+ clientWithRouteAndResultHandler

253− clientWithRoute (Proxy :: Proxy sublayout)

313+ (Proxy :: Proxy sublayout) q t

254− q t

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

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

256− baseurl

315+ baseurl opts wrap

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

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

258

317

259

318

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

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

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

268 Client t m sublayout tag

327 Client t m sublayout tag

269

328

270− 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 =

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

341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

342+

343+

272

344

273

345

274-- | 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,

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

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

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

305

377

306 -- 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

307− clientWithRoute Proxy q t req baseurl mparam =

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

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

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

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

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

310

382

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

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

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

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

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

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

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

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

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

352

424

353− clientWithRoute Proxy q t req baseurl paramlist =

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

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

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

355

427

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

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

357 pname = symbolVal (Proxy :: Proxy sym)

429 pname = symbolVal (Proxy :: Proxy sym)

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

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

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

391 Dynamic t Bool -> Client t m sublayout tag

463 Dynamic t Bool -> Client t m sublayout tag

392

464

393− clientWithRoute Proxy q t req baseurl flag =

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

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

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

395

467

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

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

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

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

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

405 -> Event t tag

477 -> Event t tag

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

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

407

479

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

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

409

481

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

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

411 Left e -> Left e

483 Left e -> Left e

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

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

417

489

418 resps <- performRequestsAsync okReq

490 resps <- performRequestsAsync okReq

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

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

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

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

421 ]

493 ]

422

494

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

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

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

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

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

449

521

450− clientWithRoute Proxy q t req baseurl body =

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

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

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

452 where req' = req { reqBody = bodyBytesCT }

524 where req' = req { reqBody = bodyBytesCT }

453 ctProxy = Proxy :: Proxy ct

525 ctProxy = Proxy :: Proxy ct

454 ctString = T.pack $ show $ contentType ctProxy

526 ctString = T.pack $ show $ contentType ctProxy

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

462instance (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

463 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

464

536

465− clientWithRoute Proxy q t req baseurl =

537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =

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

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

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

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

468

540

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

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

470

542

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

472instance 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

473 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

474

546

475− clientWithRoute Proxy q t req baseurl =

547+ clientWithRouteAndResultHandler Proxy =

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

548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

477

549

478

550

479instance 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

480 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

481

553

482− clientWithRoute Proxy q t req baseurl =

554+ clientWithRouteAndResultHandler Proxy =

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

555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

484

556

485

557

486

558

487instance 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

488 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

489

561

490− clientWithRoute Proxy q t req baseurl =

562+ clientWithRouteAndResultHandler Proxy =

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

563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

492

564

493

565

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

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

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

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

498 -> Client t m api tag

570 -> Client t m api tag

499

571

500− clientWithRoute Proxy q t req baseurl authdata =

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

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

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

502 where

574 where

503 req' = req { authData = Just authdata }

575 req' = req { authData = Just authdata }

504

576

@@ -541,7 +613,7 @@ for empty and one for non-empty lists).

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

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

542

614

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

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

544− clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)

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

545

617

546

618

547type family HasCookieAuth xs :: Constraint where

619type family HasCookieAuth xs :: Constraint where

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

@@ -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,40 +37,45 @@ module Servant.Reflex.Multi (

34 ) where

37 ) where

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

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

37−import Control.Applicative (liftA2)

40+import Control.Applicative (liftA2)

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

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

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

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

40−import qualified Data.Set as Set

43+import qualified Data.Set as Set

41−import Data.Text (Text)

44+import Data.Text (Text)

42−import qualified Data.Text as T

45+import qualified Data.Text as T

43−import qualified Data.Text.Encoding as E

46+import qualified Data.Text.Encoding as E

44−import GHC.TypeLits (KnownSymbol, symbolVal)

47+import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

46− BasicAuthData, BuildHeadersTo (..),

49+ BasicAuthData, BuildHeadersTo (..),

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

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

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

51+ HttpVersion, IsSecure,

52+ MimeRender (..), MimeUnrender,

49− MimeUnrender, NoContent, QueryFlag,

53+ NoContent, QueryFlag, QueryParam,

50− QueryParam, QueryParams, Raw,

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

51− ReflectMethod (..), RemoteHost,

55+ RemoteHost, ReqBody,

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

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

53− Verb, contentType)

57+ contentType)

54−

58+import Servant.API.Description (Summary)

59+

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

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

56− XhrRequest (..),

61+ XhrRequest (..),

57− XhrResponseHeaders (..),

62+ XhrResponseHeaders (..),

58− attachPromptlyDynWith, constDyn)

63+ attachPromptlyDynWith, constDyn)

59------------------------------------------------------------------------------

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

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

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

61 SupportsServantReflex)

66 SupportsServantReflex)

67+import Servant.Common.Req (ClientOptions,

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

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

63 ReqResult (..), addHeader, authData,

69 ReqResult (..), addHeader, authData,

70+ defReq,

71+ defaultClientOptions,

64− defReq, performRequestsCT,

72+ performRequestsCT,

65 performRequestsNoBody,

73 performRequestsNoBody,

66 performSomeRequestsAsync,

74 performSomeRequestsAsync,

67 prependToPathParts, qParamToQueryPart,

75 prependToPathParts, qParamToQueryPart,

68 qParams, reqBody, reqFailure,

76 qParams, reqBody, reqFailure,

69 reqMethod, reqSuccess, reqSuccess',

77 reqMethod, reqSuccess, reqSuccess',

70− respHeaders, response)

78+ respHeaders, response, withCredentials)

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

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

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

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

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

78clientA p q f tag baseurl =

86clientA p q f tag baseurl =

79 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

82------------------------------------------------------------------------------

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

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

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

84 type ClientMulti t m layout f tag :: *

102 type ClientMulti t m layout f tag :: *

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

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

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

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

87− -> ClientMulti t m layout f tag

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

106

107

90------------------------------------------------------------------------------

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

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

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

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

93 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 :<|>

94 ClientMulti t m b f tag

112 ClientMulti t m b f tag

95− clientWithRouteMulti Proxy q f tag reqs baseurl =

113+ clientWithRouteMulti Proxy q f tag reqs baseurl opts =

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

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

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

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

116

117

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

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

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

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

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

108 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

109

127

110− clientWithRouteMulti _ q f tag reqs baseurl vals =

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

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

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

112 where

130 where

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

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

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

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

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

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

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

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

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

130

148

131− clientWithRouteMulti _ _ _ _ reqs baseurl =

149+ clientWithRouteMulti _ _ _ _ reqs baseurl opts =

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

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

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

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

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

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

135

153

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

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

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

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

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

145 -- ExceptT ServantError IO NoContent

163 -- ExceptT ServantError IO NoContent

146− clientWithRouteMulti Proxy _ _ _ req baseurl =

164+ clientWithRouteMulti Proxy _ _ _ req baseurl opts =

147− performRequestsNoBody method req baseurl

165+ performRequestsNoBody method req baseurl opts

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

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

149

167

150

168

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

158 ) => 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

159 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 =

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

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

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

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

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

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

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

164 return $ fmap toHeaders <$> resp

182 return $ fmap toHeaders <$> resp

165 where

183 where

166 reqs' = fmap (\r ->

184 reqs' = fmap (\r ->

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

181 cts (Headers ls NoContent)) f tag where

199 cts (Headers ls NoContent)) f tag where

182 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

183 = 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))))

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

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

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

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

186− resp <- performRequestsNoBody method reqs' baseurl triggers

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

187 return $ fmap toHeaders <$> resp

205 return $ fmap toHeaders <$> resp

188 where reqs' = fmap (\req ->

206 where reqs' = fmap (\req ->

189 req {respHeaders = OnlyHeaders (Set.fromList

207 req {respHeaders = OnlyHeaders (Set.fromList

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

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

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

204 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

205

223

206− clientWithRouteMulti Proxy f q tag reqs baseurl eVals =

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

207 clientWithRouteMulti (Proxy :: Proxy sublayout) f

225 clientWithRouteMulti (Proxy :: Proxy sublayout) f

208 q tag

226 q tag

209 reqs'

227 reqs'

210− baseurl

228+ baseurl opts

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

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

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

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

213 <$> eVals <*>) <$> reqs

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

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

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

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

225

243

226

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+

227------------------------------------------------------------------------------

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

228instance (KnownSymbol sym,

257instance (KnownSymbol sym,

229 ToHttpApiData a,

258 ToHttpApiData a,

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

237

266

238 -- 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

239 -- TODO: Check the above comment

268 -- TODO: Check the above comment

240− clientWithRouteMulti Proxy q f tag reqs baseurl mparams =

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

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

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

242− reqs' baseurl

271+ reqs' baseurl opts

243

272

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

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

245 p prm = QueryPartParam $ fmap qParamToQueryPart prm

274 p prm = QueryPartParam $ fmap qParamToQueryPart prm

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

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

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

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

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

262

291

263− clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =

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

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

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

265

294

266 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 }

267 pname = symbolVal (Proxy :: Proxy sym)

296 pname = symbolVal (Proxy :: Proxy sym)

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

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

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

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

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

281

310

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

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

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

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

284

313

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

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

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

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

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

294 -> Event t tag

323 -> Event t tag

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

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

296

325

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

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

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

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

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

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

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

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

301 return resps

330 return resps

302 where

331 where

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

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

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

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

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

314 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

315

344

316− clientWithRouteMulti Proxy q f tag reqs baseurl bodies =

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

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

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

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

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

319 ctProxy = Proxy :: Proxy ct

348 ctProxy = Proxy :: Proxy ct

320 ctString = T.pack $ show $ contentType ctProxy

349 ctString = T.pack $ show $ contentType ctProxy

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

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

366 -> ClientMulti t m api f tag

395 -> ClientMulti t m api f tag

367

396

368− clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =

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

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

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

370 where

399 where

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

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

372 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+ }