69d855f..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+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+24−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,38 +17,35 @@ Flag Example

18library

19 exposed-modules:

20− Servant.Reflex

21− Servant.Reflex.Multi

22−

23− other-modules:

24 Servant.Common.BaseUrl

20 Servant.Common.BaseUrl

25 Servant.Common.Req

21 Servant.Common.Req

22+ Servant.Reflex

23+ Servant.Reflex.Multi

27 hs-source-dirs: src

25 hs-source-dirs: src

28 build-depends:

26 build-depends:

29− base >= 4.8 && < 4.10,

27+ base >= 4.8 && < 5,

30− aeson >= 0.11 && < 1.3,

31 bytestring >= 0.10 && < 0.11,

28 bytestring >= 0.10 && < 0.11,

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

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

33− containers >= 0.5.6 && < 0.6,

30+ containers >= 0.5.6 && < 0.7,

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

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

35− exceptions >= 0.8 && < 0.9,

32+ exceptions >= 0.8 && < 0.11,

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

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

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

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

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

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

39 jsaddle >= 0.8 && < 0.10,

36 jsaddle >= 0.8 && < 0.10,

40 mtl >= 2.2.1 && < 2.3,

37 mtl >= 2.2.1 && < 2.3,

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

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

42− reflex >= 0.5 && < 0.6,

39+ reflex >= 0.5 && < 0.9,

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

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

44 safe >= 0.3.9 && < 0.4,

41 safe >= 0.3.9 && < 0.4,

45− servant >= 0.8 && < 0.12,

42+ servant >= 0.16 && < 0.18,

46 servant-auth >= 0.2.1 && < 0.4,

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

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

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

48 text >= 1.2 && < 1.3,

45 text >= 1.2 && < 1.3,

49 transformers >= 0.4 && < 0.6

46 transformers >= 0.4 && < 0.6

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

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

53 default-language: Haskell2010

50 default-language: Haskell2010

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

57 buildable: True

54 buildable: True

58 else

55 else

59 buildable: False

56 buildable: False

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

61 default-language: Haskell2010

67 default-language: Haskell2010

62 main-is: Example.hs

68 main-is: Example.hs

63 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+4−5

@@ -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+104−138

@@ -1,65 +1,46 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE ExistentialQuantification #-}

4−{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE FunctionalDependencies #-}

7−{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE LambdaCase #-}

6+{-# LANGUAGE LambdaCase #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE NamedFieldPuns #-}

11−{-# LANGUAGE OverloadedStrings #-}

12−{-# LANGUAGE RankNTypes #-}

7+{-# LANGUAGE RankNTypes #-}

13−{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

14−{-# LANGUAGE TupleSections #-}

9+{-# LANGUAGE TupleSections #-}

15−{-# OPTIONS_GHC -fno-warn-orphans #-}

17module Servant.Common.Req where

11module Servant.Common.Req where

19-------------------------------------------------------------------------------

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

20−import Control.Applicative (liftA2, liftA3)

14+import Control.Applicative (liftA2, liftA3)

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

21import Control.Concurrent

16import Control.Concurrent

22−import Control.Monad (join)

17+import Control.Monad (join)

23−import Control.Monad.IO.Class (MonadIO, liftIO)

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

24−import Data.Aeson

25−import Data.Bifunctor (first)

19+import Data.Bifunctor (first)

26−import qualified Data.ByteString as BS

20+import qualified Data.ByteString.Builder as Builder

27−import qualified Data.ByteString.Builder as BB

28−import Data.ByteString.Lazy (ByteString)

29−import qualified Data.ByteString.Lazy.Char8 as BL

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

22+import Data.ByteString (ByteString)

23+import qualified Data.Map as Map

24+import Data.Maybe (catMaybes, fromMaybe)

30import Data.Functor.Compose

25import Data.Functor.Compose

31−import qualified Data.JSString.Text as JS (lazyTextFromJSString)

32−import qualified Data.Map as Map

33−import Data.Maybe (catMaybes, fromMaybe)

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

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

35−import Data.Proxy (Proxy (..))

27+import Data.Proxy (Proxy(..))

36−import Data.Text (Text)

28+import Data.Text (Text)

37−import qualified Data.Text as T

29+import qualified Data.Text as T

38−import qualified Data.Text.Encoding as T

30+import qualified Data.Text.Encoding as TE

39−import qualified Data.Text.Lazy as TL

40−import Data.Traversable (forM)

31+import Data.Traversable (forM)

41−import qualified Language.Javascript.JSaddle as JS

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

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

43−import qualified Network.URI as N

33+import qualified Network.URI as N

44−import Reflex.Dom.Core hiding (tag)

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

45−import Servant.API.ContentTypes (Accept, FormUrlEncoded,

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

46− JSON, NoContent (..),

36+ SupportsServantReflex)

47− OctetStream, PlainText)

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

48−import Servant.Common.BaseUrl (BaseUrl,

38+import Web.HttpApiData (ToHttpApiData(..))

49− SupportsServantReflex,

50− showBaseUrl)

51−import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)

52−import Web.HttpApiData (ToHttpApiData (..))

53-------------------------------------------------------------------------------

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

54import Servant.API.BasicAuth

40import Servant.API.BasicAuth

55−-------------------------------------------------------------------------------

57−-- #ifndef __GHCJS__

58−-- jsonDecode :: JS.JSString -> Maybe a

59−-- jsonDecode = error "jsonDecode is only available in GHCJS"

60−-- #endif

62−-----------------------------------------------------------------------------

43+------------------------------------------------------------------------------

63-- | The result of a request event

44-- | The result of a request event

64data ReqResult tag a

45data ReqResult tag a

65 = ResponseSuccess tag a XhrResponse

46 = ResponseSuccess tag a XhrResponse

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

112reqFailure (RequestFailure _ s) = Just s

93reqFailure (RequestFailure _ s) = Just s

113reqFailure _ = Nothing

94reqFailure _ = Nothing

114

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+

115

103

116------------------------------------------------------------------------------

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

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

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

@@ -153,35 +141,34 @@ data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))

153-------------------------------------------------------------------------------

141-------------------------------------------------------------------------------

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

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

155-- the shape of a servant API

143-- the shape of a servant API

156−data Req t = forall o. (IsXhrPayload o, Show o) => Req

144+data Req t = Req

157 { reqMethod :: Text

145 { reqMethod :: Text

158 , reqPathParts :: [Dynamic t (Either Text Text)]

146 , reqPathParts :: [Dynamic t (Either Text Text)]

159 , qParams :: [(Text, QueryPart t)]

147 , qParams :: [(Text, QueryPart t)]

160− , reqBody :: Maybe (Dynamic t (Either Text (o, Text)))

148+ , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))

161 , headers :: [(Text, Dynamic t (Either Text Text))]

149 , headers :: [(Text, Dynamic t (Either Text Text))]

162 , respHeaders :: XhrResponseHeaders

150 , respHeaders :: XhrResponseHeaders

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

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

164 }

152 }

165

153

166−data SomeXhrRequest = forall o. (IsXhrPayload o, Show o) => SomeXhrRequest (XhrRequest (Maybe o))

167−

168defReq :: Req t

154defReq :: Req t

169−defReq = Req "GET" [] [] (Nothing :: Maybe (Dynamic t (Either Text ((), Text)))) [] def Nothing

155+defReq = Req "GET" [] [] Nothing [] def Nothing

170

156

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

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

172prependToPathParts p req =

158prependToPathParts p req =

173 req { reqPathParts = p : reqPathParts req }

159 req { reqPathParts = p : reqPathParts req }

174

160

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

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

176−addHeader name val req = req { headers = (name, (fmap . fmap) (T.decodeUtf8 . toHeader) val) : headers req }

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

163+

177

164

178reqToReflexRequest

165reqToReflexRequest

179− :: forall t. Reflex t

166+ :: forall t. Reflex t

180− => Text

167+ => Text

181− -> Dynamic t BaseUrl

168+ -> Dynamic t BaseUrl

182− -> Req t

169+ -> Req t

183− -> Dynamic t (Either Text SomeXhrRequest)

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

184−reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (Either Text (o, Text)))) _ _ _) =

171+reqToReflexRequest reqMeth reqHost req =

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

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

186 t = sequence $ reverse $ reqPathParts req

173 t = sequence $ reverse $ reqPathParts req

187

174

@@ -233,33 +220,33 @@ reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (

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

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

234

221

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

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

236− -> (Either Text (o, Text))

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

237− -> Either Text (XhrRequestConfig (Maybe o))

224+ -> Either Text (XhrRequestConfig XhrPayload)

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

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

239 (_, Left e) -> Left e

226 (_, Left e) -> Left e

240 (Left e, _) -> Left e

227 (Left e, _) -> Left e

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

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

242 Right $ XhrRequestConfig

229 Right $ XhrRequestConfig

243− { _xhrRequestConfig_sendData = Just bBytes

230+ { _xhrRequestConfig_sendData = bytesToPayload bBytes

244 , _xhrRequestConfig_headers =

231 , _xhrRequestConfig_headers =

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

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

246 , _xhrRequestConfig_user = Nothing

233 , _xhrRequestConfig_user = Nothing

247 , _xhrRequestConfig_password = Nothing

234 , _xhrRequestConfig_password = Nothing

248− , _xhrRequestConfig_responseType = Nothing

235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

249 , _xhrRequestConfig_withCredentials = False

236 , _xhrRequestConfig_withCredentials = False

250 , _xhrRequestConfig_responseHeaders = def

237 , _xhrRequestConfig_responseHeaders = def

251 }

238 }

252

239

253− xhrOpts :: Dynamic t (Either Text (XhrRequestConfig (Maybe o)))

240+ xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))

254− xhrOpts = case reqBody of

241+ xhrOpts = case reqBody req of

255 Nothing -> ffor xhrHeaders $ \case

242 Nothing -> ffor xhrHeaders $ \case

256 Left e -> Left e

243 Left e -> Left e

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

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

258 , _xhrRequestConfig_user = Nothing

245 , _xhrRequestConfig_user = Nothing

259 , _xhrRequestConfig_password = Nothing

246 , _xhrRequestConfig_password = Nothing

260− , _xhrRequestConfig_responseType = Nothing

247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

248+ , _xhrRequestConfig_sendData = mempty

261 , _xhrRequestConfig_withCredentials = False

249 , _xhrRequestConfig_withCredentials = False

262− , _xhrRequestConfig_sendData = Nothing

263 }

250 }

264 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

265

252

@@ -267,16 +254,16 @@ reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (

267 mkAuth _ (Left e) = Left e

254 mkAuth _ (Left e) = Left e

268 mkAuth Nothing r = r

255 mkAuth Nothing r = r

269 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config

256 mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config

270− { _xhrRequestConfig_user = Just $ T.decodeUtf8 u

257+ { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u

271− , _xhrRequestConfig_password = Just $ T.decodeUtf8 p}

258+ , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}

272

259

273 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))

260 addAuth :: Dynamic t (Either Text (XhrRequestConfig x))

274 -> Dynamic t (Either Text (XhrRequestConfig x))

261 -> Dynamic t (Either Text (XhrRequestConfig x))

275 addAuth xhr = case authData req of

262 addAuth xhr = case authData req of

276− Nothing -> xhr

263+ Nothing -> xhr

277 Just auth -> liftA2 mkAuth auth xhr

264 Just auth -> liftA2 mkAuth auth xhr

278

265

279− xhrReq = (liftA2 . liftA2) (\p opt -> SomeXhrRequest $ XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)

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

280

267

281 in xhrReq

268 in xhrReq

282

269

@@ -285,14 +272,8 @@ reqToReflexRequest reqMeth reqHost req@(Req _ _ _ (reqBody :: Maybe (Dynamic t (

285displayHttpRequest :: Text -> Text

272displayHttpRequest :: Text -> Text

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

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

287

274

288−instance IsXhrPayload o => IsXhrPayload (Maybe o) where

289− sendXhrPayload xhr = maybe (sendXhrPayload xhr ()) (sendXhrPayload xhr)

290−

291−instance (IsXhrPayload o, IsXhrPayload o') => IsXhrPayload (Either o o') where

292− sendXhrPayload xhr = either (sendXhrPayload xhr) (sendXhrPayload xhr)

293−

294-- | This function performs the request

275-- | This function performs the request

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

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

296 => Text

277 => Text

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

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

298 -> Dynamic t BaseUrl

279 -> Dynamic t BaseUrl

@@ -305,7 +286,6 @@ performRequests reqMeth rs reqHost opts trigger = do

305 reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs

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

306

287

307 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

288 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

308− reqs :: Event t (Compose ((,) tag) f (Either Text SomeXhrRequest))

309 reqs = attachPromptlyDynWith

289 reqs = attachPromptlyDynWith

310 (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger

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

311

291

@@ -321,31 +301,32 @@ performSomeRequestsAsync

321 HasWebView (Performable m),

301 HasWebView (Performable m),

322 PerformEvent t m,

302 PerformEvent t m,

323 TriggerEvent t m,

303 TriggerEvent t m,

324− Traversable f

304+ Traversable f,

305+ IsXhrPayload a,

306+ Show a

325 )

307 )

326 => ClientOptions

308 => ClientOptions

327− -> Event t (f (Either Text SomeXhrRequest))

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

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

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

329−performSomeRequestsAsync opts sxhr =

311+performSomeRequestsAsync opts =

330− performSomeRequestsAsync' opts newXMLHttpRequest $ return <$> sxhr

312+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

331

313

332

314

333------------------------------------------------------------------------------

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

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

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

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

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

336performSomeRequestsAsync'

318performSomeRequestsAsync'

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

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

338 => ClientOptions

320 => ClientOptions

339− -> (forall b. IsXhrPayload b => XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)

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

340− -> Event t (Performable m (f (Either Text SomeXhrRequest)))

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

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

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

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

343 rs <- hrs

324 rs <- hrs

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

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

345 Left e -> do

326 Left e -> do

346 resp <- liftIO $ newMVar (Left e)

327 resp <- liftIO $ newMVar (Left e)

347 return resp

328 return resp

348− Right (SomeXhrRequest r') -> do

329+ Right r' -> do

349 resp <- liftIO newEmptyMVar

330 resp <- liftIO newEmptyMVar

350 r'' <- liftJSM $ (optsRequestFixup opts) r'

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

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

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

@@ -354,6 +335,12 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs

354 return ()

335 return ()

355

336

356

337

338+

339+type XhrPayload = ByteString

340+bytesToPayload :: BL.ByteString -> XhrPayload

341+bytesToPayload = BL.toStrict

342+

343+

357performRequestsCT

344performRequestsCT

358 :: (SupportsServantReflex t m,

345 :: (SupportsServantReflex t m,

359 MimeUnrender ct a, Traversable f)

346 MimeUnrender ct a, Traversable f)

@@ -366,14 +353,15 @@ performRequestsCT

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

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

367performRequestsCT ct reqMeth reqs reqHost opts trigger = do

354performRequestsCT ct reqMeth reqs reqHost opts trigger = do

368 resps <- performRequests reqMeth reqs reqHost opts trigger

355 resps <- performRequests reqMeth reqs reqHost opts trigger

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

369− let decodeResp x = first T.pack

357+ first T.pack .

370− . mimeUnrender ct

358+ mimeUnrender ct $

371− . JS.textToJSString

359+ BL.fromStrict x

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

360+ decodeResp _ = Left "No body"

373 return $ fmap

361 return $ fmap

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

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

375 Left e -> RequestFailure t e

363 Left e -> RequestFailure t e

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

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

377 )

365 )

378 resps

366 resps

379

367

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

400 :: (XhrResponse -> Either Text a)

388 :: (XhrResponse -> Either Text a)

401 -> (tag, XhrResponse)

389 -> (tag, XhrResponse)

402 -> ReqResult tag a

390 -> ReqResult tag a

403−evalResponse decodeRes (tag, xhr) =

391+evalResponse decode (tag, xhr) =

404− let okStatus = _xhrResponse_status xhr < 400

392+ let status = _xhrResponse_status xhr

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

405 errMsg = fromMaybe

394 errMsg = fromMaybe

406 ("Empty response with error code " <>

395 ("Empty response with error code " <>

407 T.pack (show $ _xhrResponse_status xhr))

396 T.pack (show $ _xhrResponse_status xhr))

@@ -410,56 +399,33 @@ evalResponse decodeRes (tag, xhr) =

410 then either

399 then either

411 (\e -> ResponseFailure tag e xhr)

400 (\e -> ResponseFailure tag e xhr)

412 (\v -> ResponseSuccess tag v xhr)

401 (\v -> ResponseSuccess tag v xhr)

413− (decodeRes xhr)

402+ (decode xhr)

414 else ResponseFailure tag errMsg xhr

403 else ResponseFailure tag errMsg xhr

415 in respPayld

404 in respPayld

416

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

417

411

418−-- | Similar to 'Servant.API.ContentType.MimeUnrender' but with the differnce that

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

419−-- the second argument expects a JSString instead of ByteString.

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

420−-- This can lead to better performance ghcjs.

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

421−class Accept contentType => MimeUnrender contentType a where

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

422− mimeUnrender :: Proxy contentType -> JS.JSString -> Either String a

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

423−

424−instance FromJSON a => MimeUnrender JSON a where

425− mimeUnrender _ = note "Failed to decode response" . jsonDecode

426−

427−-- | @urlDecodeAsForm@

428−-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only

429−-- holds if every element of x is non-null (i.e., not @("", "")@)

430−instance FromForm a => MimeUnrender FormUrlEncoded a where

431− mimeUnrender _ = first T.unpack . urlDecodeAsForm . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString

432−

433−-- | @left show . TextL.decodeUtf8'@

434−instance MimeUnrender PlainText TL.Text where

435− mimeUnrender _ = pure . JS.lazyTextFromJSString

436−

437−-- | @left show . TextS.decodeUtf8' . toStrict@

438−instance MimeUnrender PlainText T.Text where

439− mimeUnrender _ = pure . JS.textFromJSString

440−

441−-- | @Right . BC.unpack@

442−instance MimeUnrender PlainText String where

443− mimeUnrender _ = Right . T.unpack . JS.textFromJSString

444−

445−-- | @Right . id@

446−instance MimeUnrender OctetStream ByteString where

447− mimeUnrender _ = pure . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString

448

417

449−-- | @Right . toStrict@

450−instance MimeUnrender OctetStream BS.ByteString where

451− mimeUnrender _ = pure . T.encodeUtf8 . JS.textFromJSString

452

418

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

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

454−note e Nothing = Left e

420+note e = maybe (Left e) Right

455−note _ (Just a) = Right a

456

421

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

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

458fmapL _ (Right a) = Right a

423fmapL _ (Right a) = Right a

459fmapL f (Left e) = Left (f e)

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

460

425

461−builderToText :: BB.Builder -> T.Text

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

462−builderToText = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString

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

463

428

464escape :: T.Text -> T.Text

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

465−escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . T.decodeUtf8 . BL.toStrict . BB.toLazyByteString . toEncodedUrlPiece

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

431+

src/Servant/Reflex.hs+161−159

@@ -1,18 +1,14 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE DefaultSignatures #-}

5−{-# LANGUAGE ExtendedDefaultRules #-}

6{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

8−{-# LANGUAGE FunctionalDependencies #-}

9{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

10{-# LANGUAGE InstanceSigs #-}

7{-# LANGUAGE InstanceSigs #-}

11−{-# LANGUAGE LambdaCase #-}

12{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

13{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE OverloadedStrings #-}

14{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE PolyKinds #-}

15−{-# LANGUAGE RecordWildCards #-}

11+{-# LANGUAGE Rank2Types #-}

16{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE TupleSections #-}

13{-# LANGUAGE TupleSections #-}

18{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeFamilies #-}

@@ -30,9 +26,10 @@

30module Servant.Reflex

26module Servant.Reflex

31 ( client

27 ( client

32 , clientWithOpts

28 , clientWithOpts

29+ , clientWithOptsAndResultHandler

33 , clientWithRoute

30 , clientWithRoute

31+ , clientWithRouteAndResultHandler

34 , BuildHeaderKeysTo(..)

32 , BuildHeaderKeysTo(..)

35− , GHCJS'MimeRender(..)

36 , toHeaders

33 , toHeaders

37 , HasClient

34 , HasClient

38 , Client

35 , Client

@@ -42,56 +39,56 @@ module Servant.Reflex

43------------------------------------------------------------------------------

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

44import Control.Applicative

41import Control.Applicative

45−import qualified Data.ByteString as BS

42+import qualified Data.CaseInsensitive as CI

46−import qualified Data.ByteString.Lazy as BL

47−import Data.CaseInsensitive (mk)

48import Data.Functor.Identity

43import Data.Functor.Identity

49−import Data.Kind (Type)

50−import qualified Data.Map as Map

44+import qualified Data.Map as Map

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

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

52−import Data.Proxy (Proxy (..))

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

53−import qualified Data.Set as Set

47+import qualified Data.Set as Set

54−import Data.Text (Text)

48+import Data.Text (Text)

55−import qualified Data.Text as T

49+import qualified Data.Text as T

56−import qualified Data.Text.Encoding as E

50+import qualified Data.Text.Encoding as E

57−import qualified Data.Text.Lazy as TL

58−import GHC.Exts (Constraint)

51+import GHC.Exts (Constraint)

59−import GHC.TypeLits (KnownSymbol, symbolVal)

52+import GHC.TypeLits (KnownSymbol, symbolVal)

60−import GHCJS.DOM.Types (Blob)

61−import Servant.API ((:<|>) (..), (:>), Accept (..),

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

62− BasicAuth, BasicAuthData,

63− BuildHeadersTo (..), Capture,

54+ BasicAuthData, BuildHeadersTo (..),

64− FormUrlEncoded, Header, Headers (..),

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

65− HttpVersion, IsSecure, JSON,

56+ HttpVersion, IsSecure,

66− MimeRender (..), NoContent,

57+ MimeRender (..), MimeUnrender,

67− OctetStream, PlainText, QueryFlag,

58+ NoContent, QueryFlag, QueryParam,

68− QueryParam, QueryParams, Raw,

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

69− ReflectMethod (..), RemoteHost,

60+ RemoteHost, ReqBody,

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

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

71− Verb, contentType)

62+ contentType)

63+import Servant.API.Description (Summary)

72−import qualified Servant.Auth as Auth

64+import qualified Servant.Auth as Auth

73−

65+

74−import Reflex.Dom.Core (Dynamic, Event, IsXhrPayload, Reflex,

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

75− XhrRequest (..), XhrResponse (..),

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

76− XhrResponseHeaders (..),

68+ XhrResponseHeaders (..),

77− attachPromptlyDynWith, constDyn, ffor,

69+ attachPromptlyDynWith, constDyn, ffor,

78− fmapMaybe, leftmost,

70+ fmapMaybe, leftmost,

79− performRequestsAsync)

71+ performRequestsAsync)

80------------------------------------------------------------------------------

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

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

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

82− SupportsServantReflex, baseUrlWidget,

83− showBaseUrl)

74+ showBaseUrl,

75+ SupportsServantReflex)

84−import Servant.Common.Req (ClientOptions (..), MimeUnrender (..),

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

85− QParam (..), QueryPart (..), Req (..),

77+ defaultClientOptions,

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

86− ReqResult (..), addHeader, authData,

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

87− defReq, defaultClientOptions,

80+ defReq, evalResponse, prependToPathParts,

81+ -- performRequestCT,

88− evalResponse, performRequestsCT,

82+ performRequestsCT,

83+ -- performRequestNoBody,

89− performRequestsNoBody,

84+ performRequestsNoBody,

90− performSomeRequestsAsync,

85+ performSomeRequestsAsync,

91− prependToPathParts, qParamToQueryPart,

86+ qParamToQueryPart, reqBody,

92− qParams, reqBody, reqFailure,

87+ reqSuccess, reqFailure,

93− reqMethod, reqSuccess, reqTag,

88+ reqMethod, respHeaders,

89+ response,

90+ reqTag,

94− respHeaders, response, withCredentials)

91+ qParams, withCredentials)

97-- * Accessing APIs as a Client

94-- * Accessing APIs as a Client

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

106-- >

103-- >

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

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

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

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

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

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

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

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

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

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

112client

109client

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

128 -> Client t m layout tag

125 -> Client t m layout tag

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

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

130

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+

131

142

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

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

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

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

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

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

135−class HasClient t m layout (tag :: Type) where

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

136− type Client t m layout tag :: Type

147+ type Client t m layout tag :: *

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

138

167

139

168

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

141 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

142

171

143− clientWithRoute Proxy q pTag req baseurl opts =

172+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =

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

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

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

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

146

175

147

176

148-- Capture. Example:

177-- Capture. Example:

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

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

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

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

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

165

194

166− clientWithRoute Proxy q t req baseurl opts val =

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

167− clientWithRoute (Proxy :: Proxy sublayout)

196+ clientWithRouteAndResultHandler

168− q t

169− (prependToPathParts p req)

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

170− baseurl opts

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

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

172

199

173

200

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

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

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

181 -- TODO how to access input types here?

208 -- TODO how to access input types here?

182 -- ExceptT ServantError IO a

209 -- ExceptT ServantError IO a

183− clientWithRoute Proxy _ _ req baseurl opts trigs =

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

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

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

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

186 req' = req { reqMethod = method }

213 req' = req { reqMethod = method }

187

214

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

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

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

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

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

196 -- ExceptT ServantError IO NoContent

223 -- ExceptT ServantError IO NoContent

197− clientWithRoute Proxy _ _ req baseurl opts =

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

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

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

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

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

200

227

201

228

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

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

203toHeaders r =

230toHeaders r =

204− let toBS = E.encodeUtf8

205− hdrs = maybe []

231+ let hdrs = maybe []

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

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

207 (Map.toList $ _xhrResponse_headers xhr))

233 (Map.toList $ _xhrResponse_headers xhr))

208 (response r)

234 (response r)

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

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

210

236

237+

211class BuildHeaderKeysTo hs where

238class BuildHeaderKeysTo hs where

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

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

213

240

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

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

215 where buildHeaderKeysTo _ = []

242 where buildHeaderKeysTo _ = []

216

243

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

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

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

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

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

250+

220

251

221-- HEADERS Verb (Content) --

252-- HEADERS Verb (Content) --

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

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

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

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

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

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

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

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

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

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

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

236 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

237− return $ toHeaders <$> resp

268+ wrap $ toHeaders <$> resp

238 where req' = req { respHeaders =

269 where req' = req { respHeaders =

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

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

240 }

271 }

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

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

248 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

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

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

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

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

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

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

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

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

253− return $ toHeaders <$> resp

284+ wrap $ toHeaders <$> resp

254 where req' = req {respHeaders =

285 where req' = req {respHeaders =

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

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

256 }

287 }

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

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

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

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

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

279

310

280− clientWithRoute Proxy q t req baseurl opts eVal =

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

312+ clientWithRouteAndResultHandler

281− clientWithRoute (Proxy :: Proxy sublayout)

313+ (Proxy :: Proxy sublayout) q t

282− q t

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

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

284− baseurl opts

315+ baseurl opts wrap

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

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

286

317

287

318

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

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

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

296 Client t m sublayout tag

327 Client t m sublayout tag

297

328

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

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

341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

342+

343+

300

344

301

345

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

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

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

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

333

377

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

335− clientWithRoute Proxy q t req baseurl opts mparam =

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

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

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

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

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

338

382

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

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

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

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

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

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

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

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

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

380

424

381− clientWithRoute Proxy q t req baseurl opts paramlist =

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

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

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

383

427

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

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

385 pname = symbolVal (Proxy :: Proxy sym)

429 pname = symbolVal (Proxy :: Proxy sym)

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

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

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

419 Dynamic t Bool -> Client t m sublayout tag

463 Dynamic t Bool -> Client t m sublayout tag

420

464

421− clientWithRoute Proxy q t req baseurl opts flag =

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

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

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

423

467

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

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

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

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

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

433 -> Event t tag

477 -> Event t tag

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

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

435

479

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

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

437

481

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

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

439 Left e -> Left e

483 Left e -> Left e

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

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

445

489

446 resps <- performRequestsAsync okReq

490 resps <- performRequestsAsync okReq

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

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

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

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

449 ]

493 ]

450

494

@@ -469,73 +513,30 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where

469-- > where host = BaseUrl Http "localhost" 8080

513-- > where host = BaseUrl Http "localhost" 8080

470-- > -- then you can just use "addBook" to query that endpoint

514-- > -- then you can just use "addBook" to query that endpoint

471

515

472−instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),

473− HasClient t m sublayout tag, Reflex t)

516+instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)

474− => HasClient t m (ReqBody (ct ': cts) (a :: Type) :> sublayout) tag where

517+ => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where

475

518

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

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

477− Dynamic t (Either Text (ToConvert ct a)) -> Client t m sublayout tag

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

478

521

479− clientWithRoute Proxy q t Req{..} baseurl opts body =

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

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

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

481− where req' = Req { reqBody = Just $ (fmap . fmap)

524+ where req' = req { reqBody = bodyBytesCT }

482− (\b -> (ghcjsMimeRender ctProxy atProxy b, ctString)) body

483− , ..}

484 ctProxy = Proxy :: Proxy ct

525 ctProxy = Proxy :: Proxy ct

485− atProxy = Proxy :: Proxy a

486 ctString = T.pack $ show $ contentType ctProxy

526 ctString = T.pack $ show $ contentType ctProxy

527+ bodyBytesCT = Just $ (fmap . fmap)

528+ (\b -> (mimeRender ctProxy b, ctString))

529+ body

487

530

488−class Accept ctype => GHCJS'MimeRender (ctype :: Type) (a :: Type) where

489− type ToConvert ctype a :: Type

490− type ToConvert ctype a = a

491−

492− type ToSend ctype a :: Type

493− type ToSend ctype a = BS.ByteString

494

531

495− ghcjsMimeRender

496− :: IsXhrPayload (ToSend ctype a)

497− => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a

498− default ghcjsMimeRender

499− :: (MimeRender ctype a,

500− MimeRender ctype (ToConvert ctype a), ToSend ctype a ~ BS.ByteString)

501− => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a

502− ghcjsMimeRender ctype _ = BL.toStrict . mimeRender ctype

503−

504−instance MimeRender JSON x => GHCJS'MimeRender JSON x

505−

506−instance MimeRender FormUrlEncoded x => GHCJS'MimeRender FormUrlEncoded x

507−

508−instance GHCJS'MimeRender OctetStream BL.ByteString where

509− type ToConvert OctetStream BL.ByteString = Either BL.ByteString Blob

510− type ToSend OctetStream BL.ByteString = Either BS.ByteString Blob

511− ghcjsMimeRender _ _ = \case Left bl -> Left $ BL.toStrict bl; Right x -> Right x

512−

513−instance GHCJS'MimeRender PlainText String where

514− type ToSend PlainText String = Text

515− ghcjsMimeRender _ _ = T.pack

516−

517−instance GHCJS'MimeRender PlainText Text where

518− type ToSend PlainText Text = Text

519− ghcjsMimeRender _ _ = id

520−

521−instance GHCJS'MimeRender PlainText TL.Text where

522− type ToSend PlainText TL.Text = Text

523− ghcjsMimeRender _ _ = TL.toStrict

524−

525−instance GHCJS'MimeRender PlainText BL.ByteString where

526− type ToSend PlainText BL.ByteString = BS.ByteString

527− ghcjsMimeRender _ _ = BL.toStrict

528−

529−instance GHCJS'MimeRender PlainText BS.ByteString where

530− ghcjsMimeRender _ _ = id

531

532

532-- | Make the querying function append @path@ to the request path.

533-- | Make the querying function append @path@ to the request path.

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

534 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

535

536

536− clientWithRoute Proxy q t req baseurl opts =

537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =

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

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

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

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

539

540

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

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

541

542

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

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

544 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

545

546

546− clientWithRoute Proxy q t req baseurl =

547+ clientWithRouteAndResultHandler Proxy =

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

548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

548

549

550

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

551 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

552

553

553− clientWithRoute Proxy q t req baseurl =

554+ clientWithRouteAndResultHandler Proxy =

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

555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

555

556

557

558

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

559 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

560

561

561− clientWithRoute Proxy q t req baseurl =

562+ clientWithRouteAndResultHandler Proxy =

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

563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

563

564

565

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

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

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

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

569 -> Client t m api tag

570 -> Client t m api tag

570

571

571− clientWithRoute Proxy q t req baseurl opts authdata =

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

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

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

573 where

574 where

574 req' = req { authData = Just authdata }

575 req' = req { authData = Just authdata }

575

576

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

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

613

614

614 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

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

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

616

617

618

618type family HasCookieAuth xs :: Constraint where

619type family HasCookieAuth xs :: Constraint where

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

621 HasCookieAuth '[] = CookieAuthNotEnabled

622 HasCookieAuth '[] = CookieAuthNotEnabled

622

623

623class CookieAuthNotEnabled

624class CookieAuthNotEnabled

625+

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

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

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE RecordWildCards #-}

11{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE TupleSections #-}

11{-# LANGUAGE TupleSections #-}

13{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeFamilies #-}

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

38 ) where

37 ) where

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

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

41−import Control.Applicative (liftA2)

40+import Control.Applicative (liftA2)

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

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

43−import Data.Proxy (Proxy (..))

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

44−import qualified Data.Set as Set

43+import qualified Data.Set as Set

45−import Data.Text (Text)

44+import Data.Text (Text)

46−import qualified Data.Text as T

45+import qualified Data.Text as T

47−import qualified Data.Text.Encoding as E

46+import qualified Data.Text.Encoding as E

48−import GHC.TypeLits (KnownSymbol, symbolVal)

47+import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

50− BasicAuthData, BuildHeadersTo (..),

49+ BasicAuthData, BuildHeadersTo (..),

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

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

52− HttpVersion, IsSecure, NoContent,

51+ HttpVersion, IsSecure,

52+ MimeRender (..), MimeUnrender,

53− QueryFlag, QueryParam, QueryParams,

53+ NoContent, QueryFlag, QueryParam,

54− Raw, ReflectMethod (..), RemoteHost,

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

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, IsXhrPayload, 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)

65−import Servant.Common.Req (ClientOptions, MimeUnrender,

67+import Servant.Common.Req (ClientOptions,

66− QParam (..), QueryPart (..), Req (..),

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

67− ReqResult (..), SomeXhrRequest (..),

68− addHeader, authData, defReq,

69+ ReqResult (..), addHeader, authData,

70+ defReq,

69 defaultClientOptions,

71 defaultClientOptions,

70 performRequestsCT,

72 performRequestsCT,

71 performRequestsNoBody,

73 performRequestsNoBody,

@@ -74,8 +76,7 @@ import Servant.Common.Req (ClientOptions, MimeUnrender,

74 qParams, reqBody, reqFailure,

76 qParams, reqBody, reqFailure,

75 reqMethod, reqSuccess, reqSuccess',

77 reqMethod, reqSuccess, reqSuccess',

76 respHeaders, response, withCredentials)

78 respHeaders, response, withCredentials)

77−import Servant.Reflex (BuildHeaderKeysTo (..),

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

78− GHCJS'MimeRender (..), toHeaders)

81------------------------------------------------------------------------------

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

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

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

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

242

243

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+

244------------------------------------------------------------------------------

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

245instance (KnownSymbol sym,

257instance (KnownSymbol sym,

246 ToHttpApiData a,

258 ToHttpApiData a,

@@ -314,31 +326,29 @@ instance (SupportsServantReflex t m,

314 clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do

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

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

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

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

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

317− rawReqs''' = (fmap . fmap . fmap) (SomeXhrRequest . fmap Just) rawReqs''

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

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

319 return resps

330 return resps

320 where

331 where

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

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

322 aux (tag, Left e) = RequestFailure tag e

333 aux (tag, Left e) = RequestFailure tag e

323

334

324

335

325−instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),

336+instance (MimeRender ct a,

326 HasClientMulti t m sublayout f tag,

337 HasClientMulti t m sublayout f tag,

327 Reflex t,

338 Reflex t,

328 Applicative f)

339 Applicative f)

329 => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where

340 => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where

330

341

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

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

332− Dynamic t (f (Either Text (ToConvert ct a))) -> ClientMulti t m sublayout f tag

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

333

344

334 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

345 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

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

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

336− where req' b Req{..} = Req { reqBody = bodyBytesCT (constDyn b), .. }

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

337 ctProxy = Proxy :: Proxy ct

348 ctProxy = Proxy :: Proxy ct

338− atProxy = Proxy :: Proxy a

339 ctString = T.pack $ show $ contentType ctProxy

349 ctString = T.pack $ show $ contentType ctProxy

340 bodyBytesCT b = Just $ (fmap . fmap)

350 bodyBytesCT b = Just $ (fmap . fmap)

341− (\b' -> (ghcjsMimeRender ctProxy atProxy b', ctString))

351+ (\b' -> (mimeRender ctProxy b', ctString))

342 b

352 b

343 reqs' = liftA2 req' <$> bodies <*> reqs

353 reqs' = liftA2 req' <$> bodies <*> reqs

344

354

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