0c74012...master · typeable/servant-reflex

git.iko.soy/typeable/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+14−1

@@ -1,7 +1,20 @@

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+

10.3.3

140.3.3

2-----

15-----

4−Explicitly escape reserved characters from path pieces and query parameters

17+- Fix encoding issue: Explicitly escape reserved characters from path pieces and query parameters

70.3.2

200.3.2

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 -f Example && 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/Example.hs+2−2

@@ -21,7 +21,8 @@ import Servant.API

21import API

22import Data.Proxy

23import Text.Read (readMaybe)

24−import Reflex.Dom hiding (run)

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

25+import Reflex.Dom (mainWidget)

25------------------------------------------------------------------------------

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

26import Servant.Reflex

27import Servant.Reflex

27import Servant.Reflex.Multi

28import Servant.Reflex.Multi

@@ -97,7 +98,6 @@ run = mdo

98 -- Name the computed API client functions

99 -- Name the computed API client functions

99 let tweakRequest = ClientOptions $ \r -> do

100 let tweakRequest = ClientOptions $ \r -> do

100− putStrLn ("Got req: " ++ show r)

101 return $ r & withCredentials .~ True

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

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

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+25−18

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

1Name: servant-reflex

2−Version: 0.3.3

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

5License: BSD3

6License-file: LICENSE.md

7Author: Greg Hale, Doug Beardsley

@@ -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.3.6 && < 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-core == 0.4 && < 0.5,

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

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.19,

45− servant-auth >= 0.2.1 && < 0.3,

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+9−6

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

1{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

@@ -31,8 +32,11 @@ import Reflex

31import Reflex.Dom.Core

32import Reflex.Dom.Core

32import Text.Read

33import Text.Read

34−

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

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

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

37+#else

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

39+#endif

37-- | URI scheme to use

41-- | URI scheme to use

38data Scheme =

42data Scheme =

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

85 where pathWidget :: m (Dynamic t BaseUrl)

89 where pathWidget :: m (Dynamic t BaseUrl)

86 pathWidget = do

90 pathWidget = do

87 text "Url base path"

91 text "Url base path"

88− t <- textInput (def {_textInputConfig_attributes =

92+ t <- inputElement def

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

90 return $ BasePath <$> value t

93 return $ BasePath <$> value t

91 fullUrlWidget :: m (Dynamic t BaseUrl)

94 fullUrlWidget :: m (Dynamic t BaseUrl)

92 fullUrlWidget = do

95 fullUrlWidget = do

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

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

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

97+ srv <- inputElement def

95 text ":"

98 text ":"

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

99+ prt <- inputElement def

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

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

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

101+ path <- inputElement def

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

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

src/Servant/Common/Req.hs+34−11

@@ -12,12 +12,14 @@ module Servant.Common.Req where

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

14import Control.Applicative (liftA2, liftA3)

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

15import Control.Concurrent

16import Control.Concurrent

16import Control.Monad (join)

17import Control.Monad (join)

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

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

18import Data.Bifunctor (first)

19import Data.Bifunctor (first)

19import qualified Data.ByteString.Builder as Builder

20import qualified Data.ByteString.Builder as Builder

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

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

22+import Data.ByteString (ByteString)

21import qualified Data.Map as Map

23import qualified Data.Map as Map

22import Data.Maybe (catMaybes, fromMaybe)

24import Data.Maybe (catMaybes, fromMaybe)

23import Data.Functor.Compose

25import Data.Functor.Compose

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

91reqFailure (RequestFailure _ s) = Just s

93reqFailure (RequestFailure _ s) = Just s

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

95------------------------------------------------------------------------------

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

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

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

@@ -223,7 +232,7 @@ reqToReflexRequest reqMeth reqHost req =

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

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

224 , _xhrRequestConfig_user = Nothing

233 , _xhrRequestConfig_user = Nothing

225 , _xhrRequestConfig_password = Nothing

234 , _xhrRequestConfig_password = Nothing

226− , _xhrRequestConfig_responseType = Nothing

235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

227 , _xhrRequestConfig_withCredentials = False

236 , _xhrRequestConfig_withCredentials = False

228 , _xhrRequestConfig_responseHeaders = def

237 , _xhrRequestConfig_responseHeaders = def

229 }

238 }

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

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

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

236 , _xhrRequestConfig_user = Nothing

245 , _xhrRequestConfig_user = Nothing

237 , _xhrRequestConfig_password = Nothing

246 , _xhrRequestConfig_password = Nothing

238− , _xhrRequestConfig_responseType = Nothing

247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

239− , _xhrRequestConfig_sendData = ""

248+ , _xhrRequestConfig_sendData = mempty

240 , _xhrRequestConfig_withCredentials = False

249 , _xhrRequestConfig_withCredentials = False

241 }

250 }

242 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

@@ -289,7 +298,9 @@ performRequests reqMeth rs reqHost opts trigger = do

289performSomeRequestsAsync

298performSomeRequestsAsync

290 :: (MonadIO (Performable m),

299 :: (MonadIO (Performable m),

291 MonadJSM (Performable m),

300 MonadJSM (Performable m),

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

292 HasWebView (Performable m),

302 HasWebView (Performable m),

303+#endif

293 PerformEvent t m,

304 PerformEvent t m,

294 TriggerEvent t m,

305 TriggerEvent t m,

295 Traversable f,

306 Traversable f,

@@ -327,9 +338,9 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs

327

338

328

339

329

340

330−type XhrPayload = T.Text

341+type XhrPayload = ByteString

331bytesToPayload :: BL.ByteString -> XhrPayload

342bytesToPayload :: BL.ByteString -> XhrPayload

332−bytesToPayload = TE.decodeUtf8 . BL.toStrict

343+bytesToPayload = BL.toStrict

333

344

334

345

335performRequestsCT

346performRequestsCT

@@ -344,15 +355,15 @@ performRequestsCT

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

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

345performRequestsCT ct reqMeth reqs reqHost opts trigger = do

356performRequestsCT ct reqMeth reqs reqHost opts trigger = do

346 resps <- performRequests reqMeth reqs reqHost opts trigger

357 resps <- performRequests reqMeth reqs reqHost opts trigger

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

347− let decodeResp x = first T.pack .

359+ first T.pack .

348− mimeUnrender ct .

360+ mimeUnrender ct $

349− BL.fromStrict .

361+ BL.fromStrict x

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

362+ decodeResp _ = Left "No body"

351− (_xhrResponse_responseText x)

352 return $ fmap

363 return $ fmap

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

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

354 Left e -> RequestFailure t e

365 Left e -> RequestFailure t e

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

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

356 )

367 )

357 resps

368 resps

358

369

@@ -394,6 +405,18 @@ evalResponse decode (tag, xhr) =

394 else ResponseFailure tag errMsg xhr

405 else ResponseFailure tag errMsg xhr

395 in respPayld

406 in respPayld

396

407

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

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

410+-- response 'Event's,

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

412+fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess

413+

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

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

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

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

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

419+

397

420

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

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

399note e = maybe (Left e) Right

422note e = maybe (Left e) Right

src/Servant/Reflex.hs+126−75

@@ -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 #-}

@@ -25,7 +26,9 @@

25module Servant.Reflex

26module Servant.Reflex

26 ( client

27 ( client

27 , clientWithOpts

28 , clientWithOpts

29+ , clientWithOptsAndResultHandler

28 , clientWithRoute

30 , clientWithRoute

31+ , clientWithRouteAndResultHandler

29 , BuildHeaderKeysTo(..)

32 , BuildHeaderKeysTo(..)

30 , toHeaders

33 , toHeaders

31 , HasClient

34 , HasClient

@@ -36,34 +39,36 @@ module Servant.Reflex

37------------------------------------------------------------------------------

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

38import Control.Applicative

41import Control.Applicative

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

40−import qualified Data.Set as Set

41−import qualified Data.Text.Encoding as E

42−import Data.CaseInsensitive (mk)

42+import qualified Data.CaseInsensitive as CI

43import Data.Functor.Identity

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

45import qualified Data.Map as Map

44import qualified Data.Map as Map

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

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

47+import qualified Data.Set as Set

46import Data.Text (Text)

48import Data.Text (Text)

47import qualified Data.Text as T

49import qualified Data.Text as T

50+import qualified Data.Text.Encoding as E

48import GHC.Exts (Constraint)

51import GHC.Exts (Constraint)

49import GHC.TypeLits (KnownSymbol, symbolVal)

52import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

51− BasicAuthData, BuildHeadersTo(..),

54+ BasicAuthData, BuildHeadersTo (..),

52− Capture, contentType, Header,

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

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

56+ HttpVersion, IsSecure,

54− MimeRender(..), MimeUnrender,

57+ MimeRender (..), MimeUnrender,

55− NoContent, QueryFlag, QueryParam,

58+ NoContent, QueryFlag, QueryParam',

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

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

57 RemoteHost, ReqBody,

60 RemoteHost, ReqBody,

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

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

62+ contentType)

63+import Servant.API.Description (Summary)

59import qualified Servant.Auth as Auth

64import qualified Servant.Auth as Auth

61import Reflex.Dom.Core (Dynamic, Event, Reflex,

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

62− XhrRequest(..),

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

63− XhrResponseHeaders(..),

68+ XhrResponseHeaders (..),

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

69+ attachPromptlyDynWith, constDyn, ffor,

70+ fmapMaybe, leftmost,

65− leftmost, performRequestsAsync,

71+ performRequestsAsync)

66− )

67------------------------------------------------------------------------------

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

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

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

69 showBaseUrl,

74 showBaseUrl,

@@ -98,7 +103,7 @@ import Servant.Common.Req (ClientOptions(..),

98-- >

103-- >

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

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

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

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

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

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

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

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

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

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

104client

109client

@@ -120,21 +125,53 @@ clientWithOpts

120 -> Client t m layout tag

125 -> Client t m layout tag

121clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl

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

122

127

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

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

130+-- across call sites.

131+clientWithOptsAndResultHandler

132+ :: (HasClient t m layout tag)

133+ => Proxy layout

134+ -> Proxy m

135+ -> Proxy tag

136+ -> Dynamic t BaseUrl

137+ -> ClientOptions

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

139+ -> Client t m layout tag

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

141+

123

142

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

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

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

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

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

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

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

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

128 type Client t m layout tag :: *

147 type Client t m layout tag :: *

129− clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> ClientOptions -> 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

130

167

131

168

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

133 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

134

171

135− clientWithRoute Proxy q pTag req baseurl opts =

172+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =

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

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

137− clientWithRoute (Proxy :: Proxy b) q pTag req baseurl opts

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

138

175

139

176

140-- Capture. Example:

177-- Capture. Example:

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

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

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

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

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

157

194

158− clientWithRoute Proxy q t req baseurl opts val =

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

159− clientWithRoute (Proxy :: Proxy sublayout)

196+ clientWithRouteAndResultHandler

160− q t

161− (prependToPathParts p req)

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

162− baseurl opts

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

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

164

199

165

200

@@ -172,8 +207,8 @@ instance {-# OVERLAPPABLE #-}

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

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

173 -- TODO how to access input types here?

208 -- TODO how to access input types here?

174 -- ExceptT ServantError IO a

209 -- ExceptT ServantError IO a

175− clientWithRoute Proxy _ _ req baseurl opts trigs =

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

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

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

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

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

178 req' = req { reqMethod = method }

213 req' = req { reqMethod = method }

179

214

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

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

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

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

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

188 -- ExceptT ServantError IO NoContent

223 -- ExceptT ServantError IO NoContent

189− clientWithRoute Proxy _ _ req baseurl opts =

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

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

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

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

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

192

227

193

228

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

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

195toHeaders r =

230toHeaders r =

196− let toBS = E.encodeUtf8

197− hdrs = maybe []

231+ let hdrs = maybe []

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

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

199 (Map.toList $ _xhrResponse_headers xhr))

233 (Map.toList $ _xhrResponse_headers xhr))

200 (response r)

234 (response r)

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

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

202

236

237+

203class BuildHeaderKeysTo hs where

238class BuildHeaderKeysTo hs where

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

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

205

240

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

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

207 where buildHeaderKeysTo _ = []

242 where buildHeaderKeysTo _ = []

208

243

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

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

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

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

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

250+

212

251

213-- HEADERS Verb (Content) --

252-- HEADERS Verb (Content) --

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

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

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

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

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

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

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

226− clientWithRoute Proxy _ _ req baseurl opts trigs = do

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

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

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

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

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

229− return $ toHeaders <$> resp

268+ wrap $ toHeaders <$> resp

230 where req' = req { respHeaders =

269 where req' = req { respHeaders =

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

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

232 }

271 }

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

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

240 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

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

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

242− clientWithRoute Proxy _ _ req baseurl opts trigs = do

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

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

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

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

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

245− return $ toHeaders <$> resp

284+ wrap $ toHeaders <$> resp

246 where req' = req {respHeaders =

285 where req' = req {respHeaders =

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

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

248 }

287 }

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

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

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

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

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

271

310

272− clientWithRoute Proxy q t req baseurl opts eVal =

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

312+ clientWithRouteAndResultHandler

273− clientWithRoute (Proxy :: Proxy sublayout)

313+ (Proxy :: Proxy sublayout) q t

274− q t

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

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

276− baseurl opts

315+ baseurl opts wrap

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

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

278

317

279

318

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

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

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

288 Client t m sublayout tag

327 Client t m sublayout tag

289

328

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

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

341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

342+

343+

292

344

293

345

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

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

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

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

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

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

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

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

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

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

322

374

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

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

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

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

325

377

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

327− clientWithRoute Proxy q t req baseurl opts mparam =

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

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

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

329− (req {qParams = paramPair : qParams req}) baseurl opts

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

330

382

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

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

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

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

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

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

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

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

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

372

424

373− clientWithRoute Proxy q t req baseurl opts paramlist =

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

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

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

375

427

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

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

377 pname = symbolVal (Proxy :: Proxy sym)

429 pname = symbolVal (Proxy :: Proxy sym)

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

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

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

411 Dynamic t Bool -> Client t m sublayout tag

463 Dynamic t Bool -> Client t m sublayout tag

412

464

413− clientWithRoute Proxy q t req baseurl opts flag =

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

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

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

415

467

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

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

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

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

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

425 -> Event t tag

477 -> Event t tag

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

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

427

479

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

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

429

481

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

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

431 Left e -> Left e

483 Left e -> Left e

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

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

437

489

438 resps <- performRequestsAsync okReq

490 resps <- performRequestsAsync okReq

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

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

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

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

441 ]

493 ]

442

494

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

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

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

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

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

469

521

470− clientWithRoute Proxy q t req baseurl opts body =

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

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

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

472 where req' = req { reqBody = bodyBytesCT }

524 where req' = req { reqBody = bodyBytesCT }

473 ctProxy = Proxy :: Proxy ct

525 ctProxy = Proxy :: Proxy ct

474 ctString = T.pack $ show $ contentType ctProxy

526 ctString = T.pack $ show $ contentType ctProxy

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

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

483 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

484

536

485− clientWithRoute Proxy q t req baseurl opts =

537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =

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

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

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

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

488

540

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

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

490

542

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

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

493 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

494

546

495− clientWithRoute Proxy q t req baseurl =

547+ clientWithRouteAndResultHandler Proxy =

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

548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

497

549

498

550

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

500 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

501

553

502− clientWithRoute Proxy q t req baseurl =

554+ clientWithRouteAndResultHandler Proxy =

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

555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

504

556

505

557

506

558

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

508 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

509

561

510− clientWithRoute Proxy q t req baseurl =

562+ clientWithRouteAndResultHandler Proxy =

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

563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

512

564

513

565

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

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

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

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

518 -> Client t m api tag

570 -> Client t m api tag

519

571

520− clientWithRoute Proxy q t req baseurl opts authdata =

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

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

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

522 where

574 where

523 req' = req { authData = Just authdata }

575 req' = req { authData = Just authdata }

524

576

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

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

562

614

563 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

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

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

565

617

566

618

567type family HasCookieAuth xs :: Constraint where

619type family HasCookieAuth xs :: Constraint where

@@ -570,4 +622,3 @@ type family HasCookieAuth xs :: Constraint where

570 HasCookieAuth '[] = CookieAuthNotEnabled

622 HasCookieAuth '[] = CookieAuthNotEnabled

571

623

572class CookieAuthNotEnabled

624class CookieAuthNotEnabled

573−

src/Servant/Reflex/Multi.hs+35−22

@@ -37,28 +37,30 @@ module Servant.Reflex.Multi (

37 ) where

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

40−import Control.Applicative (liftA2)

40+import Control.Applicative (liftA2)

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

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

42−import Data.Proxy (Proxy (..))

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

43−import qualified Data.Set as Set

43+import qualified Data.Set as Set

44−import Data.Text (Text)

44+import Data.Text (Text)

45−import qualified Data.Text as T

45+import qualified Data.Text as T

46−import qualified Data.Text.Encoding as E

46+import qualified Data.Text.Encoding as E

47−import GHC.TypeLits (KnownSymbol, symbolVal)

47+import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

49− BasicAuthData, BuildHeadersTo (..),

49+ BasicAuthData, BuildHeadersTo (..),

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

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

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

51+ HttpVersion, IsSecure,

52+ MimeRender (..), MimeUnrender,

52− MimeUnrender, NoContent, QueryFlag,

53+ NoContent, QueryFlag, QueryParam,

53− QueryParam, QueryParams, Raw,

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

54− ReflectMethod (..), RemoteHost,

55+ RemoteHost, ReqBody,

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

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

56− Verb, contentType)

57+ contentType)

57−

58+import Servant.API.Description (Summary)

59+

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

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

59− XhrRequest (..),

61+ XhrRequest (..),

60− XhrResponseHeaders (..),

62+ XhrResponseHeaders (..),

61− attachPromptlyDynWith, constDyn)

63+ attachPromptlyDynWith, constDyn)

62------------------------------------------------------------------------------

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

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

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

64 SupportsServantReflex)

66 SupportsServantReflex)

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

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

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

241

243

242

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+

243------------------------------------------------------------------------------

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

244instance (KnownSymbol sym,

257instance (KnownSymbol sym,

245 ToHttpApiData a,

258 ToHttpApiData a,

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+10−3

@@ -7,10 +7,12 @@

7{-# LANGUAGE TypeOperators #-}

9import Control.Monad.IO.Class (liftIO)

10+import Control.Monad.Reader (reader)

10import Data.Aeson

11import Data.Aeson

11import Data.Bool

12import Data.Bool

12import Data.Char (toUpper)

13import Data.Char (toUpper)

13import qualified Data.List as L

14import qualified Data.List as L

15+import Data.Maybe (fromMaybe)

14import Data.Monoid

16import Data.Monoid

15import Data.Proxy

17import Data.Proxy

16import Data.Text hiding (head, length, map,

18import Data.Text hiding (head, length, map,

@@ -25,6 +27,7 @@ import Snap.Http.Server

25import Servant

27import Servant

26import Servant.Server

28import Servant.Server

27-- import Snap.Util.FileServe

29-- import Snap.Util.FileServe

30+import System.Environment (lookupEnv)

28import API

31import API

29import Snap

32import Snap

@@ -40,7 +43,7 @@ instance ToJSON Greet

40testApi :: Proxy API

43testApi :: Proxy API

41testApi = Proxy

44testApi = Proxy

43−data App = App

46+data App = App { appStaticDir :: String }

45-- Server-side handlers.

48-- Server-side handlers.

46--

49--

@@ -51,7 +54,7 @@ data App = App

51server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)

54server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)

52server = return () :<|> return 100 :<|> sayhi :<|> dbl

55server = return () :<|> return 100 :<|> sayhi :<|> dbl

53 :<|> multi :<|> qna :<|> serveSecret

56 :<|> multi :<|> qna :<|> serveSecret

54− :<|> serveDirectory "static"

57+ :<|> statics

55 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text

58 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text

56 sayhi nm greetings withGusto = case nm of

59 sayhi nm greetings withGusto = case nm of

57 Nothing -> return ("Sorry, who are you?" :: Text)

60 Nothing -> return ("Sorry, who are you?" :: Text)

@@ -76,6 +79,9 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl

76 req <- getRequest

79 req <- getRequest

77 liftIO $ putStrLn (show req)

80 liftIO $ putStrLn (show req)

78 return 101

81 return 101

82+ statics = do

83+ staticDir <- reader appStaticDir

84+ serveDirectory staticDir

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

81-- more precisely by the Servant.Server module.

87-- more precisely by the Servant.Server module.

@@ -85,10 +91,11 @@ test = serveSnapWithContext testApi

86initApp :: SnapletInit App App

92initApp :: SnapletInit App App

87initApp = makeSnaplet "myapp" "example" Nothing $ do

93initApp = makeSnaplet "myapp" "example" Nothing $ do

94+ staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")

88 addRoutes [("", test)

95 addRoutes [("", test)

89 ,("", serveDirectory "static")

96 ,("", serveDirectory "static")

90 ]

97 ]

91− return App

98+ return (App staticDir)

93-- Put this all to work!

100-- Put this all to work!

94main :: 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+5−4

@@ -19,12 +19,13 @@ executable back

19 main-is: Main.hs

20 -- other-modules:

21 -- other-extensions:

22− build-depends: aeson >= 0.9 && < 1.4

22+ build-depends: aeson >= 0.9 && < 1.5

23− , base >=4.8 && <4.11

23+ , base >=4.8 && < 5

24+ , mtl

24 , snap >= 1.0 && < 1.2

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

28+ , servant >= 0.16 && < 0.18

28 , servant-snap >= 0.8 && < 0.9

29 , servant-snap >= 0.8 && < 0.9

29 , text >= 1.0 && < 1.3

30 , text >= 1.0 && < 1.3

30 -- hs-source-dirs:

31 -- hs-source-dirs:

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