master..ddbf55d · servant-reflex

git.iko.soy/servant-reflex

on ddbf55d help sign in

.gitignore−2

since splitsnapshots

unifiedsplit

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

7*.stats

8out

9/.stack-work/

10−TAGS

11−dist-newstyle

.gitmodules+12

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

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+56−12

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

1−language: nix

1+sudo: required

2−nix: 2.3.6

3−sudo: require

3+before_cache:

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

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

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+

5before_install:

22before_install:

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

23+ - unset CC

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

25+ - git submodule update --init --recursive

8−before_script:

27+install:

9− - sudo systemctl restart nix-daemon.service

28+ - cabal --version

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

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

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

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

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

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

33+ then

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

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

36+ fi

37+ - travis_retry cabal update -v

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

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

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

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

42+ - sleep 3

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

44+ - sleep 3

13script:

46script:

14− - nix-build travis.nix -A build

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

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

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

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

49+ - ./build.sh

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

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

51+

52+cache:

53+ directories:

54+ - /nix

55+ - $HOME/.cabal/packages

56+ - $HOME/.cabal/store

57+

58+env:

59+ global:

60+ - ENCRYPTION_LABEL: "3c89d919c82e"

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

README.md+33−70

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

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

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

8−API changes its input parameters or return type, XHR requests from the

9−frontend will fail at runtime. If your API is defined by

10−[servant](https://haskell-servant.readthedocs.io) combinators, you can use

11−`servant-reflex` to share the API between the server and frontend.

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

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.

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

16## Example

12## Example

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

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:

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

21```haskell

16```haskell

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

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

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

29 :<|> Raw

24 :<|> Raw

30```

25```

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

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

33−an `XhrRequest`.

35```haskell

29```haskell

@@ -43,16 +37,7 @@ an `XhrRequest`.

43 (constDyn (BasePath "/"))

37 (constDyn (BasePath "/"))

44```

38```

46−These client functions are computed from your API type. They manage

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.

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.

57```haskell

42```haskell

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

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

@@ -77,13 +62,7 @@ parameter is a trigger event for the XHR request. The return value

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

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

78```

63```

80−`ReqResult tag a` is defined in

81−[`Servant.Common.Req`](https://github.com/imalsogreg/servant-reflex/blob/6d866e338edb9bf6fd8f8d5083ff0187b4d8c0d2/src/Servant/Common/Req.hs#L40-L42)

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:

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:

88```haskell

67```haskell

89 -- ... continued ...

68 -- ... continued ...

@@ -101,8 +80,7 @@ elimination functions to filter the result type you care about, like this:

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

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

102```

81```

103

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

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

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

106

107```haskell

85```haskell

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

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

@@ -125,53 +103,47 @@ trigger the API calls, and text elements to show the results:

125 display =<< holdDyn Nothing outputDouble

103 display =<< holdDyn Nothing outputDouble

126```

104```

127

105

128−For a great introduction to recative DOM building, see the

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.

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.

133

107

134

108

135## Building the library and test server

109## Building the library and test server

136

110

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

138−ghcjs-compiled frontend

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

140−ghc-compiled backend

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

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:

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

112+

143−manages the frontend build as a dependency.

113+

114+First build the library:

144

115

145```

116```

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

117+git submodule update --init --recursive

118+./build.sh

147```

119```

148

120

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

121+Then build the test server:

122+

123+```

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

125+```

126+

127+

128+## Running the example site

129+

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

150

131

151```

132```

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

133+cd testserver

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

153```

135```

154

136

155−Browse to [http://localhost:8000](http://localhost:8000) and click around.

137+And simply browse to `localhost:8001`

156−Open the firefox or chrome developer tools and examine the XHR activity

157−under the Network tab.

158

138

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

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

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

161

140

162

141

163## Tagging requests

142## Tagging requests

164

143

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

166−event streams. The individual input events and responses occur at different

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.

167−times and aren't automatically paired up, but you can recover the

168−relationship by tagging the requests.

169

145

170−So far we have used an `Event t ()` to trigger sending a request. If we choose

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:

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:

175

147

176```haskell

148```haskell

177 ...

149 ...

@@ -201,10 +173,7 @@ its request. Imagine we wanted to display not just the last "double" from

201

173

202## Simultaneous requests

174## Simultaneous requests

203

175

204−`Servant.Reflex.Multi` provides an alternative client-generation function

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:

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:

208

177

209```haskell

178```haskell

210sayHi

179sayHi

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

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

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

216```

185```

217

186

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

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.

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.shnew file+3

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

1+#!/usr/bin/env bash

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

ChangeLog.md → changelog.mdrenamed+1−14

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

1−0.3.5

2−-----

3−

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

8−

9−0.3.4

10−-----

11−

12−Add selenium-based test suite

13−

140.3.3

10.3.3

15-----

2-----

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

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

200.3.2

70.3.2

default.nixdeleted−21

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

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-datanew file+1

Submodule changed.

deps/reflex-platformnew file+1

Submodule changed.

deps/servantnew file+1

Submodule changed.

deps/servant-snapnew file+1

Submodule changed.

exec/Example.hs+2−2

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

21import API

22import Data.Proxy

23import Text.Read (readMaybe)

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

24+import Reflex.Dom hiding (run)

25−import Reflex.Dom (mainWidget)

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

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

27import Servant.Reflex

26import Servant.Reflex

28import Servant.Reflex.Multi

27import Servant.Reflex.Multi

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

99 -- Name the computed API client functions

98 -- Name the computed API client functions

100 let tweakRequest = ClientOptions $ \r -> do

99 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.confdeleted−3

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

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

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

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

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

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.nixdeleted−17

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

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

2−

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.nixdeleted−9

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

1−servant-reflex: self: super:

2−

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.nixnew file+11

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

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.nixnew file+9

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

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

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

1Name: servant-reflex

2−Version: 0.3.6

2+Version: 0.3.3

3−Synopsis: servant API generator for reflex apps

3+Synopsis: Servant reflex API generator

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

4+Description: Servant reflex API generator

5License: BSD3

6License-file: LICENSE.md

7Author: Greg Hale, Doug Beardsley

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

18library

19 exposed-modules:

20− Servant.Common.BaseUrl

21− Servant.Common.Req

22 Servant.Reflex

20 Servant.Reflex

23 Servant.Reflex.Multi

21 Servant.Reflex.Multi

23+ other-modules:

24+ Servant.Common.BaseUrl

25+ Servant.Common.Req

26+

25 hs-source-dirs: src

27 hs-source-dirs: src

26 build-depends:

28 build-depends:

27− base >= 4.8 && < 5,

29+ base >= 4.8 && < 4.10,

30+ aeson >= 0.11 && < 1.3,

28 bytestring >= 0.10 && < 0.11,

31 bytestring >= 0.10 && < 0.11,

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

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

30− containers >= 0.5.6 && < 0.7,

33+ containers >= 0.5.6 && < 0.6,

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

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

32− exceptions >= 0.8 && < 0.11,

35+ exceptions >= 0.8 && < 0.9,

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

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

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

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

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

38+ http-media >= 0.6 && < 0.8,

36 jsaddle >= 0.8 && < 0.10,

39 jsaddle >= 0.8 && < 0.10,

37 mtl >= 2.2.1 && < 2.3,

40 mtl >= 2.2.1 && < 2.3,

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

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

39− reflex >= 0.5 && < 0.9,

42+ reflex >= 0.5 && < 0.6,

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

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

41 safe >= 0.3.9 && < 0.4,

44 safe >= 0.3.9 && < 0.4,

42− servant >= 0.16 && < 0.18,

45+ servant >= 0.13 && < 0.14,

46+ servant-checked-exceptions >= 1.1.0.0 && < 1.2,

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

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

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

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

45 text >= 1.2 && < 1.3,

49 text >= 1.2 && < 1.3,

46 transformers >= 0.4 && < 0.6

50 transformers >= 0.4 && < 0.6

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

52+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

50 default-language: Haskell2010

54 default-language: Haskell2010

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

54 buildable: True

58 buildable: True

55 else

59 else

56 buildable: False

60 buildable: False

57− build-depends:

61+ build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text

58− aeson,

59− reflex,

60− servant-reflex,

61− base,

62− scientific,

63− servant,

64− reflex-dom,

65− reflex-dom-core,

66− text

67 default-language: Haskell2010

62 default-language: Haskell2010

68 main-is: Example.hs

63 main-is: Example.hs

69 other-modules: API

64 other-modules: API

shell.nixdeleted−1

@@ -1 +0,0 @@

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

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

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

85 where pathWidget :: m (Dynamic t BaseUrl)

86 pathWidget = do

87 text "Url base path"

88− t <- inputElement def

88+ t <- textInput (def {_textInputConfig_attributes =

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

89 return $ BasePath <$> value t

90 return $ BasePath <$> value t

90 fullUrlWidget :: m (Dynamic t BaseUrl)

91 fullUrlWidget :: m (Dynamic t BaseUrl)

91 fullUrlWidget = do

92 fullUrlWidget = do

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

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

93− srv <- inputElement def

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

94 text ":"

95 text ":"

95− prt <- inputElement def

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

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

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

97− path <- inputElement def

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

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

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

src/Servant/Common/Req.hs+137−102

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

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE DeriveFunctor #-}

3+{-# LANGUAGE ExistentialQuantification #-}

3−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

4−{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE LambdaCase #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE NamedFieldPuns #-}

5−{-# LANGUAGE OverloadedStrings #-}

11+{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE LambdaCase #-}

7−{-# LANGUAGE RankNTypes #-}

12+{-# LANGUAGE RankNTypes #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TupleSections #-}

14+{-# LANGUAGE TupleSections #-}

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

11module Servant.Common.Req where

17module Servant.Common.Req where

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

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

14−import Control.Applicative (liftA2, liftA3)

20+import Control.Applicative (liftA2, liftA3)

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

16import Control.Concurrent

21import Control.Concurrent

17−import Control.Monad (join)

22+import Control.Monad (join)

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

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

24+import Data.Aeson

19−import Data.Bifunctor (first)

25+import Data.Bifunctor (first)

20−import qualified Data.ByteString.Builder as Builder

26+import qualified Data.ByteString as BS

27+import qualified Data.ByteString.Builder as BB

28+import Data.ByteString.Lazy (ByteString)

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

29+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)

25import Data.Functor.Compose

30import 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)

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

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

27−import Data.Proxy (Proxy(..))

35+import Data.Proxy (Proxy (..))

28−import Data.Text (Text)

36+import Data.Text (Text)

29−import qualified Data.Text as T

37+import qualified Data.Text as T

30−import qualified Data.Text.Encoding as TE

38+import qualified Data.Text.Encoding as T

39+import qualified Data.Text.Lazy as TL

31−import Data.Traversable (forM)

40+import Data.Traversable (forM)

41+import qualified Language.Javascript.JSaddle as JS

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

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

33−import qualified Network.URI as N

43+import qualified Network.URI as N

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

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

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

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

36− SupportsServantReflex)

46+ JSON, NoContent (..),

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

47+ OctetStream, PlainText)

48+import Servant.Common.BaseUrl (BaseUrl,

49+ SupportsServantReflex,

50+ showBaseUrl)

51+import Web.FormUrlEncoded (FromForm, urlDecodeAsForm)

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

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

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

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

40import Servant.API.BasicAuth

54import Servant.API.BasicAuth

55+-------------------------------------------------------------------------------

57+-- #ifndef __GHCJS__

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

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

60+-- #endif

43−------------------------------------------------------------------------------

62+-----------------------------------------------------------------------------

44-- | The result of a request event

63-- | The result of a request event

45data ReqResult tag a

64data ReqResult tag a

46 = ResponseSuccess tag a XhrResponse

65 = ResponseSuccess tag a XhrResponse

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

93reqFailure (RequestFailure _ s) = Just s

112reqFailure (RequestFailure _ s) = Just s

94reqFailure _ = Nothing

113reqFailure _ = 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−

103

115

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

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

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

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

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

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

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

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

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

143-- the shape of a servant API

155-- the shape of a servant API

144−data Req t = Req

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

145 { reqMethod :: Text

157 { reqMethod :: Text

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

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

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

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

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

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

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

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

150 , respHeaders :: XhrResponseHeaders

162 , respHeaders :: XhrResponseHeaders

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

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

152 }

164 }

153

165

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

167+

154defReq :: Req t

168defReq :: Req t

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

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

156

170

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

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

158prependToPathParts p req =

172prependToPathParts p req =

159 req { reqPathParts = p : reqPathParts req }

173 req { reqPathParts = p : reqPathParts req }

160

174

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

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

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

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

163−

164

177

165reqToReflexRequest

178reqToReflexRequest

166− :: forall t. Reflex t

179+ :: forall t. Reflex t

167− => Text

180+ => Text

168− -> Dynamic t BaseUrl

181+ -> Dynamic t BaseUrl

169− -> Req t

182+ -> Req t

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

183+ -> Dynamic t (Either Text SomeXhrRequest)

171−reqToReflexRequest reqMeth reqHost req =

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

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

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

173 t = sequence $ reverse $ reqPathParts req

186 t = sequence $ reverse $ reqPathParts req

174

187

@@ -220,33 +233,33 @@ reqToReflexRequest reqMeth reqHost req =

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

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

221

234

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

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

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

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

224− -> Either Text (XhrRequestConfig XhrPayload)

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

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

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

226 (_, Left e) -> Left e

239 (_, Left e) -> Left e

227 (Left e, _) -> Left e

240 (Left e, _) -> Left e

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

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

229 Right $ XhrRequestConfig

242 Right $ XhrRequestConfig

230− { _xhrRequestConfig_sendData = bytesToPayload bBytes

243+ { _xhrRequestConfig_sendData = Just bBytes

231 , _xhrRequestConfig_headers =

244 , _xhrRequestConfig_headers =

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

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

233 , _xhrRequestConfig_user = Nothing

246 , _xhrRequestConfig_user = Nothing

234 , _xhrRequestConfig_password = Nothing

247 , _xhrRequestConfig_password = Nothing

235− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

248+ , _xhrRequestConfig_responseType = Nothing

236 , _xhrRequestConfig_withCredentials = False

249 , _xhrRequestConfig_withCredentials = False

237 , _xhrRequestConfig_responseHeaders = def

250 , _xhrRequestConfig_responseHeaders = def

238 }

251 }

239

252

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

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

241− xhrOpts = case reqBody req of

254+ xhrOpts = case reqBody of

242 Nothing -> ffor xhrHeaders $ \case

255 Nothing -> ffor xhrHeaders $ \case

243 Left e -> Left e

256 Left e -> Left e

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

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

245 , _xhrRequestConfig_user = Nothing

258 , _xhrRequestConfig_user = Nothing

246 , _xhrRequestConfig_password = Nothing

259 , _xhrRequestConfig_password = Nothing

247− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

260+ , _xhrRequestConfig_responseType = Nothing

248− , _xhrRequestConfig_sendData = mempty

249 , _xhrRequestConfig_withCredentials = False

261 , _xhrRequestConfig_withCredentials = False

262+ , _xhrRequestConfig_sendData = Nothing

250 }

263 }

251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

264 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

252

265

@@ -254,16 +267,16 @@ reqToReflexRequest reqMeth reqHost req =

254 mkAuth _ (Left e) = Left e

267 mkAuth _ (Left e) = Left e

255 mkAuth Nothing r = r

268 mkAuth Nothing r = r

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

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

257− { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u

270+ { _xhrRequestConfig_user = Just $ T.decodeUtf8 u

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

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

259

272

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

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

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

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

262 addAuth xhr = case authData req of

275 addAuth xhr = case authData req of

263− Nothing -> xhr

276+ Nothing -> xhr

264 Just auth -> liftA2 mkAuth auth xhr

277 Just auth -> liftA2 mkAuth auth xhr

265

278

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

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

267

280

268 in xhrReq

281 in xhrReq

269

282

@@ -272,8 +285,14 @@ reqToReflexRequest reqMeth reqHost req =

272displayHttpRequest :: Text -> Text

285displayHttpRequest :: Text -> Text

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

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

274

287

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+

275-- | This function performs the request

294-- | This function performs the request

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

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

277 => Text

296 => Text

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

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

279 -> Dynamic t BaseUrl

298 -> Dynamic t BaseUrl

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

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

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

287

306

288 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

307 -- xhrReqs = fmap snd <$> xhrReqsAndDebugs

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

289 reqs = attachPromptlyDynWith

309 reqs = attachPromptlyDynWith

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

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

291

311

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

301 HasWebView (Performable m),

321 HasWebView (Performable m),

302 PerformEvent t m,

322 PerformEvent t m,

303 TriggerEvent t m,

323 TriggerEvent t m,

304− Traversable f,

324+ Traversable f

305− IsXhrPayload a,

306− Show a

307 )

325 )

308 => ClientOptions

326 => ClientOptions

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

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

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

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

311−performSomeRequestsAsync opts =

329+performSomeRequestsAsync opts sxhr =

312− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

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

313

331

314

332

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

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

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

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

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

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

318performSomeRequestsAsync'

336performSomeRequestsAsync'

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

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

320 => ClientOptions

338 => ClientOptions

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

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

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

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

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

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

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

324 rs <- hrs

343 rs <- hrs

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

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

326 Left e -> do

345 Left e -> do

327 resp <- liftIO $ newMVar (Left e)

346 resp <- liftIO $ newMVar (Left e)

328 return resp

347 return resp

329− Right r' -> do

348+ Right (SomeXhrRequest r') -> do

330 resp <- liftIO newEmptyMVar

349 resp <- liftIO newEmptyMVar

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

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

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

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

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

335 return ()

354 return ()

336

355

337

356

338−

339−type XhrPayload = ByteString

340−bytesToPayload :: BL.ByteString -> XhrPayload

341−bytesToPayload = BL.toStrict

342−

343−

344performRequestsCT

357performRequestsCT

345 :: (SupportsServantReflex t m,

358 :: (SupportsServantReflex t m,

346 MimeUnrender ct a, Traversable f)

359 MimeUnrender ct a, Traversable f)

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

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

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

354performRequestsCT ct reqMeth reqs reqHost opts trigger = do

367performRequestsCT ct reqMeth reqs reqHost opts trigger = do

355 resps <- performRequests reqMeth reqs reqHost opts trigger

368 resps <- performRequests reqMeth reqs reqHost opts trigger

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

357− first T.pack .

369+ let decodeResp x = first T.pack

358− mimeUnrender ct $

370+ . mimeUnrender ct

359− BL.fromStrict x

371+ . JS.textToJSString

360− decodeResp _ = Left "No body"

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

361 return $ fmap

373 return $ fmap

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

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

363 Left e -> RequestFailure t e

375 Left e -> RequestFailure t e

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

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

365 )

377 )

366 resps

378 resps

367

379

@@ -388,7 +400,7 @@ evalResponse

388 :: (XhrResponse -> Either Text a)

400 :: (XhrResponse -> Either Text a)

389 -> (tag, XhrResponse)

401 -> (tag, XhrResponse)

390 -> ReqResult tag a

402 -> ReqResult tag a

391−evalResponse decode (tag, xhr) =

403+evalResponse decodeRes (tag, xhr) =

392 let status = _xhrResponse_status xhr

404 let status = _xhrResponse_status xhr

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

405 okStatus = status >= 200 && status < 400

394 errMsg = fromMaybe

406 errMsg = fromMaybe

@@ -399,33 +411,56 @@ evalResponse decode (tag, xhr) =

399 then either

411 then either

400 (\e -> ResponseFailure tag e xhr)

412 (\e -> ResponseFailure tag e xhr)

401 (\v -> ResponseSuccess tag v xhr)

413 (\v -> ResponseSuccess tag v xhr)

402− (decode xhr)

414+ (decodeRes xhr)

403 else ResponseFailure tag errMsg xhr

415 else ResponseFailure tag errMsg xhr

404 in respPayld

416 in respPayld

405

417

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

411

418

412−------------------------------------------------------------------------------

419+-- | Similar to 'Servant.API.ContentType.MimeUnrender' but with the differnce that

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

420+-- the second argument expects a JSString instead of ByteString.

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

421+-- This can lead to better performance ghcjs.

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

422+class Accept contentType => MimeUnrender contentType a where

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

423+ mimeUnrender :: Proxy contentType -> JS.JSString -> Either String a

424+

425+instance FromJSON a => MimeUnrender JSON a where

426+ mimeUnrender _ = note "Failed to decode response" . jsonDecode

427+

428+-- | @urlDecodeAsForm@

429+-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only

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

431+instance FromForm a => MimeUnrender FormUrlEncoded a where

432+ mimeUnrender _ = first T.unpack . urlDecodeAsForm . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString

417

433

434+-- | @left show . TextL.decodeUtf8'@

435+instance MimeUnrender PlainText TL.Text where

436+ mimeUnrender _ = pure . JS.lazyTextFromJSString

437+

438+-- | @left show . TextS.decodeUtf8' . toStrict@

439+instance MimeUnrender PlainText T.Text where

440+ mimeUnrender _ = pure . JS.textFromJSString

441+

442+-- | @Right . BC.unpack@

443+instance MimeUnrender PlainText String where

444+ mimeUnrender _ = Right . T.unpack . JS.textFromJSString

445+

446+-- | @Right . id@

447+instance MimeUnrender OctetStream ByteString where

448+ mimeUnrender _ = pure . BB.toLazyByteString . T.encodeUtf8Builder . JS.textFromJSString

449+

450+-- | @Right . toStrict@

451+instance MimeUnrender OctetStream BS.ByteString where

452+ mimeUnrender _ = pure . T.encodeUtf8 . JS.textFromJSString

418

453

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

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

420−note e = maybe (Left e) Right

455+note e Nothing = Left e

456+note _ (Just a) = Right a

421

457

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

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

423fmapL _ (Right a) = Right a

459fmapL _ (Right a) = Right a

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

460fmapL f (Left e) = Left (f e)

425

461

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

462+builderToText :: BB.Builder -> T.Text

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

463+builderToText = T.decodeUtf8 . BL.toStrict . BB.toLazyByteString

428

464

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

465escape :: T.Text -> T.Text

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

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

431−

src/Servant/Reflex.hs+296−79

@@ -1,14 +1,19 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE DefaultSignatures #-}

5+{-# LANGUAGE ExtendedDefaultRules #-}

4{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FlexibleInstances #-}

8+{-# LANGUAGE FunctionalDependencies #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE InstanceSigs #-}

10{-# LANGUAGE InstanceSigs #-}

11+{-# LANGUAGE LambdaCase #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

12{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE OverloadedStrings #-}

13{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE PolyKinds #-}

14{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE Rank2Types #-}

15{-# LANGUAGE Rank2Types #-}

16+{-# LANGUAGE RecordWildCards #-}

12{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE TupleSections #-}

18{-# LANGUAGE TupleSections #-}

14{-# LANGUAGE TypeFamilies #-}

19{-# LANGUAGE TypeFamilies #-}

@@ -30,6 +35,7 @@ module Servant.Reflex

30 , clientWithRoute

35 , clientWithRoute

31 , clientWithRouteAndResultHandler

36 , clientWithRouteAndResultHandler

32 , BuildHeaderKeysTo(..)

37 , BuildHeaderKeysTo(..)

38+ , GHCJS'MimeRender(..)

33 , toHeaders

39 , toHeaders

34 , HasClient

40 , HasClient

35 , Client

41 , Client

@@ -39,56 +45,101 @@ module Servant.Reflex

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

46------------------------------------------------------------------------------

41import Control.Applicative

47import Control.Applicative

42−import qualified Data.CaseInsensitive as CI

48+import qualified Data.ByteString as BS

49+import qualified Data.ByteString.Lazy as BL

50+import Data.CaseInsensitive (mk)

43import Data.Functor.Identity

51import Data.Functor.Identity

52+import Data.Kind (Type)

44−import qualified Data.Map as Map

53+import qualified Data.Map as Map

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

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

46−import Data.Proxy (Proxy (..))

55+import Data.Proxy (Proxy (..))

47−import qualified Data.Set as Set

56+import qualified Data.Set as Set

48−import Data.Text (Text)

57+import Data.Text (Text)

49−import qualified Data.Text as T

58+import qualified Data.Text as T

50−import qualified Data.Text.Encoding as E

59+import qualified Data.Text.Encoding as E

60+import qualified Data.Text.Lazy as TL

51−import GHC.Exts (Constraint)

61+import GHC.Exts (Constraint)

52−import GHC.TypeLits (KnownSymbol, symbolVal)

62+import GHC.TypeLits (KnownSymbol,

63+ symbolVal)

64+import GHCJS.DOM.Types (Blob)

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

66+ (:>),

67+ Accept (..),

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

68+ BasicAuth,

69+ BasicAuthData,

54− BasicAuthData, BuildHeadersTo (..),

70+ BuildHeadersTo (..),

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

71+ Capture,

72+ FormUrlEncoded,

73+ Header,

74+ Headers (..),

56− HttpVersion, IsSecure,

75+ HttpVersion,

76+ IsSecure,

77+ JSON,

57− MimeRender (..), MimeUnrender,

78+ MimeRender (..),

79+ NoContent,

80+ OctetStream,

81+ PlainText,

82+ QueryFlag,

58− NoContent, QueryFlag, QueryParam,

83+ QueryParam,

84+ QueryParams,

85+ Raw,

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

86+ ReflectMethod (..),

60− RemoteHost, ReqBody,

87+ RemoteHost,

88+ ReqBody,

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

89+ ToHttpApiData (..),

90+ Vault, Verb,

62− contentType)

91+ contentType)

63−import Servant.API.Description (Summary)

64−import qualified Servant.Auth as Auth

92+import qualified Servant.Auth as Auth

65−

93+

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

94+import Reflex.Dom.Core (Dynamic,

95+ Event,

96+ IsXhrPayload,

97+ Reflex,

98+ XhrRequest (..),

67− XhrRequest (..), XhrResponse (..),

99+ XhrResponse (..),

68− XhrResponseHeaders (..),

100+ XhrResponseHeaders (..),

69− attachPromptlyDynWith, constDyn, ffor,

101+ attachPromptlyDynWith,

102+ constDyn,

103+ ffor,

70− fmapMaybe, leftmost,

104+ fmapMaybe,

105+ leftmost,

71− performRequestsAsync)

106+ performRequestsAsync)

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

107------------------------------------------------------------------------------

108+import Servant.Checked.Exceptions.Internal.Envelope (Envelope)

109+import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow,

110+ Throwing,

111+ ThrowingNonterminal,

112+ Throws)

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

113+import Servant.Common.BaseUrl (BaseUrl (..),

114+ Scheme (..),

115+ SupportsServantReflex,

116+ baseUrlWidget,

74− showBaseUrl,

117+ showBaseUrl)

75− SupportsServantReflex)

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

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

77− defaultClientOptions,

119+ MimeUnrender (..),

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

120+ QParam (..),

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

121+ QueryPart (..),

122+ Req (..),

123+ ReqResult (..),

124+ addHeader,

125+ authData,

126+ defReq,

127+ defaultClientOptions,

80− defReq, evalResponse, prependToPathParts,

128+ evalResponse,

81− -- performRequestCT,

82− performRequestsCT,

129+ performRequestsCT,

83− -- performRequestNoBody,

84− performRequestsNoBody,

130+ performRequestsNoBody,

85− performSomeRequestsAsync,

131+ performSomeRequestsAsync,

132+ prependToPathParts,

86− qParamToQueryPart, reqBody,

133+ qParamToQueryPart,

134+ qParams,

135+ reqBody,

87− reqSuccess, reqFailure,

136+ reqFailure,

137+ reqMethod,

138+ reqSuccess,

139+ reqTag,

88− reqMethod, respHeaders,

140+ respHeaders,

89− response,

141+ response,

90− reqTag,

91− qParams, withCredentials)

142+ withCredentials)

143

144

94-- * Accessing APIs as a Client

145-- * Accessing APIs as a Client

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

103-- >

154-- >

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

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

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

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

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

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

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

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

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

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

109client

160client

@@ -228,26 +279,22 @@ instance {-# OVERLAPPING #-}

228

279

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

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

230toHeaders r =

281toHeaders r =

282+ let toBS = E.encodeUtf8

231− let hdrs = maybe []

283+ hdrs = maybe []

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

284+ (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))

233 (Map.toList $ _xhrResponse_headers xhr))

285 (Map.toList $ _xhrResponse_headers xhr))

234 (response r)

286 (response r)

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

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

236

288

237−

238class BuildHeaderKeysTo hs where

289class BuildHeaderKeysTo hs where

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

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

240

291

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

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

242 where buildHeaderKeysTo _ = []

293 where buildHeaderKeysTo _ = []

243

294

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

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

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

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

246− buildHeaderKeysTo _ =

247− let

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

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

297+ buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)

250−

251

298

252-- HEADERS Verb (Content) --

299-- HEADERS Verb (Content) --

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

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

@@ -329,19 +376,6 @@ instance HasClient t m sublayout tag

329 clientWithRouteAndResultHandler Proxy =

376 clientWithRouteAndResultHandler Proxy =

330 clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

377 clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

331

378

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

333−-- functions.

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

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

336−

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

338− Client t m sublayout tag

339−

340− clientWithRouteAndResultHandler Proxy =

341− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

342−

343−

344−

345

379

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

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

347-- the corresponding querying function will automatically take

381-- the corresponding querying function will automatically take

@@ -513,22 +547,65 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where

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

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

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

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

515

549

550+instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),

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

551+ HasClient t m sublayout tag, Reflex t)

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

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

518

553

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

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

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

555+ Dynamic t (Either Text (ToConvert ct a)) -> Client t m sublayout tag

521

556

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

557+ clientWithRouteAndResultHandler Proxy q t Req{..} baseurl opts wrap body =

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

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

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

559+ where req' = Req { reqBody = Just $ (fmap . fmap)

560+ (\b -> (ghcjsMimeRender ctProxy atProxy b, ctString)) body

561+ , ..}

525 ctProxy = Proxy :: Proxy ct

562 ctProxy = Proxy :: Proxy ct

563+ atProxy = Proxy :: Proxy a

526 ctString = T.pack $ show $ contentType ctProxy

564 ctString = T.pack $ show $ contentType ctProxy

527− bodyBytesCT = Just $ (fmap . fmap)

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

529− body

530

565

566+class Accept ctype => GHCJS'MimeRender (ctype :: Type) (a :: Type) where

567+ type ToConvert ctype a :: Type

568+ type ToConvert ctype a = a

531

569

570+ type ToSend ctype a :: Type

571+ type ToSend ctype a = BS.ByteString

572+

573+ ghcjsMimeRender

574+ :: IsXhrPayload (ToSend ctype a)

575+ => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a

576+ default ghcjsMimeRender

577+ :: (MimeRender ctype a,

578+ MimeRender ctype (ToConvert ctype a), ToSend ctype a ~ BS.ByteString)

579+ => Proxy ctype -> Proxy a -> ToConvert ctype a -> ToSend ctype a

580+ ghcjsMimeRender ctype _ = BL.toStrict . mimeRender ctype

581+

582+instance MimeRender JSON x => GHCJS'MimeRender JSON x

583+

584+instance MimeRender FormUrlEncoded x => GHCJS'MimeRender FormUrlEncoded x

585+

586+instance GHCJS'MimeRender OctetStream BL.ByteString where

587+ type ToConvert OctetStream BL.ByteString = Either BL.ByteString Blob

588+ type ToSend OctetStream BL.ByteString = Either BS.ByteString Blob

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

590+

591+instance GHCJS'MimeRender PlainText String where

592+ type ToSend PlainText String = Text

593+ ghcjsMimeRender _ _ = T.pack

594+

595+instance GHCJS'MimeRender PlainText Text where

596+ type ToSend PlainText Text = Text

597+ ghcjsMimeRender _ _ = id

598+

599+instance GHCJS'MimeRender PlainText TL.Text where

600+ type ToSend PlainText TL.Text = Text

601+ ghcjsMimeRender _ _ = TL.toStrict

602+

603+instance GHCJS'MimeRender PlainText BL.ByteString where

604+ type ToSend PlainText BL.ByteString = BS.ByteString

605+ ghcjsMimeRender _ _ = BL.toStrict

606+

607+instance GHCJS'MimeRender PlainText BS.ByteString where

608+ ghcjsMimeRender _ _ = id

532

609

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

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

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

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

@@ -623,3 +700,143 @@ type family HasCookieAuth xs :: Constraint where

623

700

624class CookieAuthNotEnabled

701class CookieAuthNotEnabled

625

702

703+{- servant-checked-exceptions

704+~~~~~~~~~~~~~~~~~~~~~

705+-}

706+

707+-- | Change a 'Throws' into 'Throwing'.

708+instance (Monad m, HasClient t m (Throwing '[e] :> api) tag) => HasClient t m (Throws e :> api) tag where

709+ type Client t m (Throws e :> api) tag = Client t m (Throwing '[e] :> api) tag

710+

711+ clientWithRouteAndResultHandler

712+ :: Proxy (Throws e :> api)

713+ -> Proxy m

714+ -> Proxy tag

715+ -> Req t

716+ -> Dynamic t BaseUrl

717+ -> ClientOptions

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

719+ -> Client t m (Throwing '[e] :> api) tag

720+ clientWithRouteAndResultHandler _ = clientWithRouteAndResultHandler (Proxy :: Proxy (Throwing '[e] :> api))

721+

722+-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'

723+-- but returning an @'Envelope' es@.

724+instance (HasClient t m (Verb method status ctypes (Envelope es a)) tag) =>

725+ HasClient t m (Throwing es :> Verb method status ctypes a) tag where

726+

727+ type Client t m (Throwing es :> Verb method status ctypes a) tag =

728+ Client t m (Verb method status ctypes (Envelope es a)) tag

729+

730+ clientWithRouteAndResultHandler

731+ :: Proxy (Throwing es :> Verb method status ctypes a)

732+ -> Proxy m

733+ -> Proxy tag

734+ -> Req t

735+ -> Dynamic t BaseUrl

736+ -> ClientOptions

737+ -> (forall x. Event t (ReqResult tag x) -> m (Event t (ReqResult tag x)))

738+ -> Client t m (Verb method status ctypes (Envelope es a)) tag

739+ clientWithRouteAndResultHandler Proxy =

740+ clientWithRouteAndResultHandler (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))

741+

742+-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'

743+-- but returning an @'Envelope' \'[]@.

744+instance (Monad m, HasClient t m (Verb method status ctypes (Envelope '[] a)) tag) =>

745+ HasClient t m (NoThrow :> Verb method status ctypes a) tag where

746+

747+ type Client t m (NoThrow :> Verb method status ctypes a) tag =

748+ Client t m (Verb method status ctypes (Envelope '[] a)) tag

749+

750+ clientWithRouteAndResultHandler

751+ :: Proxy (NoThrow :> Verb method status ctypes a)

752+ -> Proxy m

753+ -> Proxy tag

754+ -> Req t

755+ -> Dynamic t BaseUrl

756+ -> ClientOptions

757+ -> (forall x. Event t (ReqResult tag x) -> m (Event t (ReqResult tag x)))

758+ -> Client t m (Verb method status ctypes (Envelope '[] a)) tag

759+ clientWithRouteAndResultHandler Proxy =

760+ clientWithRouteAndResultHandler (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))

761+

762+-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each

763+-- branch of the API.

764+instance (Monad m, HasClient t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag) =>

765+ HasClient t m (Throwing es :> (api1 :<|> api2)) tag where

766+

767+ type Client t m (Throwing es :> (api1 :<|> api2)) tag =

768+ Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag

769+

770+ clientWithRouteAndResultHandler

771+ :: Proxy (Throwing es :> (api1 :<|> api2))

772+ -> Proxy m

773+ -> Proxy tag

774+ -> Req t

775+ -> Dynamic t BaseUrl

776+ -> ClientOptions

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

778+ -> Client t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) tag

779+ clientWithRouteAndResultHandler _ =

780+ clientWithRouteAndResultHandler (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))

781+

782+-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each branch of the

783+-- API.

784+instance (Monad m, HasClient t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag) =>

785+ HasClient t m (NoThrow :> (api1 :<|> api2)) tag where

786+

787+ type Client t m (NoThrow :> (api1 :<|> api2)) tag =

788+ Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag

789+

790+ clientWithRouteAndResultHandler

791+ :: Proxy (NoThrow :> (api1 :<|> api2))

792+ -> Proxy m

793+ -> Proxy tag

794+ -> Req t

795+ -> Dynamic t BaseUrl

796+ -> ClientOptions

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

798+ -> Client t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) tag

799+ clientWithRouteAndResultHandler _ =

800+ clientWithRouteAndResultHandler (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))

801+

802+-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the

803+-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other

804+-- combinator, push it down so it is closer to the 'Verb'.

805+instance (Monad m, HasClient t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag) =>

806+ HasClient t m (Throwing es :> api :> apis) tag where

807+

808+ type Client t m (Throwing es :> api :> apis) tag =

809+ Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag

810+

811+ clientWithRouteAndResultHandler

812+ :: Proxy (Throwing es :> api :> apis)

813+ -> Proxy m

814+ -> Proxy tag

815+ -> Req t

816+ -> Dynamic t BaseUrl

817+ -> ClientOptions

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

819+ -> Client t m (ThrowingNonterminal (Throwing es :> api :> apis)) tag

820+ clientWithRouteAndResultHandler _ =

821+ clientWithRouteAndResultHandler (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))

822+

823+-- | When 'NoThrow' comes before any other combinator, push it down so it is

824+-- closer to the 'Verb'.

825+instance (Monad m, HasClient t m (api :> NoThrow :> apis) tag) =>

826+ HasClient t m (NoThrow :> api :> apis) tag where

827+

828+ type Client t m (NoThrow :> api :> apis) tag =

829+ Client t m (api :> NoThrow :> apis) tag

830+

831+ clientWithRouteAndResultHandler

832+ :: Proxy (NoThrow :> api :> apis)

833+ -> Proxy m

834+ -> Proxy tag

835+ -> Req t

836+ -> Dynamic t BaseUrl

837+ -> ClientOptions

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

839+ -> Client t m (api :> NoThrow :> apis) tag

840+ clientWithRouteAndResultHandler _ =

841+ clientWithRouteAndResultHandler (Proxy :: Proxy (api :> NoThrow :> apis))

842+

src/Servant/Reflex/Multi.hs+224−55

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

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE RecordWildCards #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TupleSections #-}

12{-# LANGUAGE TupleSections #-}

12{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeFamilies #-}

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

37 ) where

38 ) where

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

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

40−import Control.Applicative (liftA2)

41+import Control.Applicative (liftA2)

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

42+import Data.Functor.Compose (Compose (..),

43+ getCompose)

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

44+import Data.Proxy (Proxy (..))

43−import qualified Data.Set as Set

45+import qualified Data.Set as Set

44−import Data.Text (Text)

46+import Data.Text (Text)

45−import qualified Data.Text as T

47+import qualified Data.Text as T

46−import qualified Data.Text.Encoding as E

48+import qualified Data.Text.Encoding as E

47−import GHC.TypeLits (KnownSymbol, symbolVal)

49+import GHC.TypeLits (KnownSymbol,

50+ symbolVal)

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

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

52+ (:>),

53+ BasicAuth,

54+ BasicAuthData,

49− BasicAuthData, BuildHeadersTo (..),

55+ BuildHeadersTo (..),

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

56+ Capture,

57+ Header,

58+ Headers (..),

51− HttpVersion, IsSecure,

59+ HttpVersion,

52− MimeRender (..), MimeUnrender,

60+ IsSecure,

61+ NoContent,

62+ QueryFlag,

53− NoContent, QueryFlag, QueryParam,

63+ QueryParam,

64+ QueryParams,

65+ Raw,

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

66+ ReflectMethod (..),

55− RemoteHost, ReqBody,

67+ RemoteHost,

68+ ReqBody,

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

69+ ToHttpApiData (..),

70+ Vault, Verb,

57− contentType)

71+ contentType)

58−import Servant.API.Description (Summary)

72+

59−

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

73+import Reflex.Dom.Core (Dynamic,

74+ Event,

75+ IsXhrPayload,

76+ Reflex,

61− XhrRequest (..),

77+ XhrRequest (..),

62− XhrResponseHeaders (..),

78+ XhrResponseHeaders (..),

63− attachPromptlyDynWith, constDyn)

79+ attachPromptlyDynWith,

80+ constDyn)

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

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

82+import Servant.Checked.Exceptions.Internal.Envelope (Envelope)

83+import Servant.Checked.Exceptions.Internal.Servant.API (NoThrow,

84+ Throwing,

85+ ThrowingNonterminal,

86+ Throws)

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

87+import Servant.Common.BaseUrl (BaseUrl (..),

88+ Scheme (..),

66− SupportsServantReflex)

89+ SupportsServantReflex)

67−import Servant.Common.Req (ClientOptions,

90+import Servant.Common.Req (ClientOptions,

91+ MimeUnrender,

92+ QParam (..),

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

93+ QueryPart (..),

94+ Req (..),

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

95+ ReqResult (..),

96+ SomeXhrRequest (..),

97+ addHeader,

98+ authData,

70− defReq,

99+ defReq,

71− defaultClientOptions,

100+ defaultClientOptions,

72− performRequestsCT,

101+ performRequestsCT,

73− performRequestsNoBody,

102+ performRequestsNoBody,

74− performSomeRequestsAsync,

103+ performSomeRequestsAsync,

75− prependToPathParts, qParamToQueryPart,

104+ prependToPathParts,

105+ qParamToQueryPart,

106+ qParams,

107+ reqBody,

76− qParams, reqBody, reqFailure,

108+ reqFailure,

109+ reqMethod,

77− reqMethod, reqSuccess, reqSuccess',

110+ reqSuccess,

111+ reqSuccess',

112+ respHeaders,

113+ response,

78− respHeaders, response, withCredentials)

114+ withCredentials)

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

115+import Servant.Reflex (BuildHeaderKeysTo (..),

116+ GHCJS'MimeRender (..),

117+ toHeaders)

118

119

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

120------------------------------------------------------------------------------

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

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

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

243

281

244

282

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−

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

283------------------------------------------------------------------------------

257instance (KnownSymbol sym,

284instance (KnownSymbol sym,

258 ToHttpApiData a,

285 ToHttpApiData a,

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

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

353 clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do

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

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

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

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

356+ rawReqs''' = (fmap . fmap . fmap) (SomeXhrRequest . fmap Just) rawReqs''

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

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

330 return resps

358 return resps

331 where

359 where

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

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

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

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

334

362

335

363

336−instance (MimeRender ct a,

364+instance (GHCJS'MimeRender ct a, IsXhrPayload (ToSend ct a), Show (ToSend ct a),

337 HasClientMulti t m sublayout f tag,

365 HasClientMulti t m sublayout f tag,

338 Reflex t,

366 Reflex t,

339 Applicative f)

367 Applicative f)

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

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

341

369

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

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

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

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

344

372

345 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

373 clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

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

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

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

375+ where req' b Req{..} = Req { reqBody = bodyBytesCT (constDyn b), .. }

348 ctProxy = Proxy :: Proxy ct

376 ctProxy = Proxy :: Proxy ct

377+ atProxy = Proxy :: Proxy a

349 ctString = T.pack $ show $ contentType ctProxy

378 ctString = T.pack $ show $ contentType ctProxy

350 bodyBytesCT b = Just $ (fmap . fmap)

379 bodyBytesCT b = Just $ (fmap . fmap)

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

380+ (\b' -> (ghcjsMimeRender ctProxy atProxy b', ctString))

352 b

381 b

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

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

354

383

@@ -399,3 +428,143 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)

399 where

428 where

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

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

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

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

431+

432+{- servant-checked-exceptions

433+~~~~~~~~~~~~~~~~~~~~~

434+-}

435+

436+-- | Change a 'Throws' into 'Throwing'.

437+instance (HasClientMulti t m (Throwing '[e] :> api) f tag) => HasClientMulti t m (Throws e :> api) f tag where

438+ type ClientMulti t m (Throws e :> api) f tag = ClientMulti t m (Throwing '[e] :> api) f tag

439+

440+ clientWithRouteMulti

441+ :: Proxy (Throws e :> api)

442+ -> Proxy m

443+ -> Proxy f

444+ -> Proxy tag

445+ -> Dynamic t (f (Req t))

446+ -> Dynamic t BaseUrl

447+ -> ClientOptions

448+ -> ClientMulti t m (Throwing '[e] :> api) f tag

449+ clientWithRouteMulti _ = clientWithRouteMulti (Proxy :: Proxy (Throwing '[e] :> api))

450+

451+-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'

452+-- but returning an @'Envelope' es@.

453+instance (HasClientMulti t m (Verb method status ctypes (Envelope es a)) f tag) =>

454+ HasClientMulti t m (Throwing es :> Verb method status ctypes a) f tag where

455+

456+ type ClientMulti t m (Throwing es :> Verb method status ctypes a) f tag =

457+ ClientMulti t m (Verb method status ctypes (Envelope es a)) f tag

458+

459+ clientWithRouteMulti

460+ :: Proxy (Throwing es :> Verb method status ctypes a)

461+ -> Proxy m

462+ -> Proxy f

463+ -> Proxy tag

464+ -> Dynamic t (f (Req t))

465+ -> Dynamic t BaseUrl

466+ -> ClientOptions

467+ -> ClientMulti t m (Verb method status ctypes (Envelope es a)) f tag

468+ clientWithRouteMulti Proxy =

469+ clientWithRouteMulti (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))

470+

471+-- | When 'NoThrow' comes before a 'Verb', change it into the same 'Verb'

472+-- but returning an @'Envelope' \'[]@.

473+instance (HasClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag) =>

474+ HasClientMulti t m (NoThrow :> Verb method status ctypes a) f tag where

475+

476+ type ClientMulti t m (NoThrow :> Verb method status ctypes a) f tag =

477+ ClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag

478+

479+ clientWithRouteMulti

480+ :: Proxy (NoThrow :> Verb method status ctypes a)

481+ -> Proxy m

482+ -> Proxy f

483+ -> Proxy tag

484+ -> Dynamic t (f (Req t))

485+ -> Dynamic t BaseUrl

486+ -> ClientOptions

487+ -> ClientMulti t m (Verb method status ctypes (Envelope '[] a)) f tag

488+ clientWithRouteMulti Proxy =

489+ clientWithRouteMulti (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))

490+

491+-- | When @'Throwing' es@ comes before ':<|>', push @'Throwing' es@ into each

492+-- branch of the API.

493+instance HasClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag =>

494+ HasClientMulti t m (Throwing es :> (api1 :<|> api2)) f tag where

495+

496+ type ClientMulti t m (Throwing es :> (api1 :<|> api2)) f tag =

497+ ClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag

498+

499+ clientWithRouteMulti

500+ :: Proxy (Throwing es :> (api1 :<|> api2))

501+ -> Proxy m

502+ -> Proxy f

503+ -> Proxy tag

504+ -> Dynamic t (f (Req t))

505+ -> Dynamic t BaseUrl

506+ -> ClientOptions

507+ -> ClientMulti t m ((Throwing es :> api1) :<|> (Throwing es :> api2)) f tag

508+ clientWithRouteMulti _ =

509+ clientWithRouteMulti (Proxy :: Proxy ((Throwing es :> api1) :<|> (Throwing es :> api2)))

510+

511+-- | When 'NoThrow' comes before ':<|>', push 'NoThrow' into each branch of the

512+-- API.

513+instance HasClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag =>

514+ HasClientMulti t m (NoThrow :> (api1 :<|> api2)) f tag where

515+

516+ type ClientMulti t m (NoThrow :> (api1 :<|> api2)) f tag =

517+ ClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag

518+

519+ clientWithRouteMulti

520+ :: Proxy (NoThrow :> (api1 :<|> api2))

521+ -> Proxy m

522+ -> Proxy f

523+ -> Proxy tag

524+ -> Dynamic t (f (Req t))

525+ -> Dynamic t BaseUrl

526+ -> ClientOptions

527+ -> ClientMulti t m ((NoThrow :> api1) :<|> (NoThrow :> api2)) f tag

528+ clientWithRouteMulti _ =

529+ clientWithRouteMulti (Proxy :: Proxy ((NoThrow :> api1) :<|> (NoThrow :> api2)))

530+

531+-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the

532+-- @e@ onto the @es@. Otherwise, if @'Throws' e@ comes before any other

533+-- combinator, push it down so it is closer to the 'Verb'.

534+instance HasClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag =>

535+ HasClientMulti t m (Throwing es :> api :> apis) f tag where

536+

537+ type ClientMulti t m (Throwing es :> api :> apis) f tag =

538+ ClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag

539+

540+ clientWithRouteMulti

541+ :: Proxy (Throwing es :> api :> apis)

542+ -> Proxy m

543+ -> Proxy f

544+ -> Proxy tag

545+ -> Dynamic t (f (Req t))

546+ -> Dynamic t BaseUrl

547+ -> ClientOptions

548+ -> ClientMulti t m (ThrowingNonterminal (Throwing es :> api :> apis)) f tag

549+ clientWithRouteMulti _ =

550+ clientWithRouteMulti (Proxy :: Proxy (ThrowingNonterminal (Throwing es :> api :> apis)))

551+

552+-- | When 'NoThrow' comes before any other combinator, push it down so it is

553+-- closer to the 'Verb'.

554+instance HasClientMulti t m (api :> NoThrow :> apis) f tag =>

555+ HasClientMulti t m (NoThrow :> api :> apis) f tag where

556+

557+ type ClientMulti t m (NoThrow :> api :> apis) f tag =

558+ ClientMulti t m (api :> NoThrow :> apis) f tag

559+

560+ clientWithRouteMulti

561+ :: Proxy (NoThrow :> api :> apis)

562+ -> Proxy m

563+ -> Proxy f

564+ -> Proxy tag

565+ -> Dynamic t (f (Req t))

566+ -> Dynamic t BaseUrl

567+ -> ClientOptions

568+ -> ClientMulti t m (api :> NoThrow :> apis) f tag

569+ clientWithRouteMulti _ =

570+ clientWithRouteMulti (Proxy :: Proxy (api :> NoThrow :> apis))

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

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

9import Data.Foldable

10import Test.WebDriver.Commands.Wait

11import Test.Hspec.WebDriver

12−import Test.Hspec.WebDriver (chromeCaps)

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

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

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

29spec = do

28spec = do

30 describe "servant-reflex tests" $ do

29 describe "servant-reflex tests" $ do

32− session "test page" $ using [chromeCaps] $ do

31+ session "test page" $ using Chrome $ do

34 it "opens the page" $ runWD $

33 it "opens the page" $ runWD $

35 openPage "http://localhost:8000"

34 openPage "http://localhost:8000"

testserver/API.hsmode 100644 → 120000+1−69

@@ -1,69 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE TypeOperators #-}

4−

5−module API where

6−

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

@@ -0,0 +1 @@

1+../exec/API.hs

testserver/Main.hs+3−10

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

7{-# LANGUAGE TypeOperators #-}

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

10−import Control.Monad.Reader (reader)

11import Data.Aeson

10import Data.Aeson

12import Data.Bool

11import Data.Bool

13import Data.Char (toUpper)

12import Data.Char (toUpper)

14import qualified Data.List as L

13import qualified Data.List as L

15−import Data.Maybe (fromMaybe)

16import Data.Monoid

14import Data.Monoid

17import Data.Proxy

15import Data.Proxy

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

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

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

27import Servant

25import Servant

28import Servant.Server

26import Servant.Server

29-- import Snap.Util.FileServe

27-- import Snap.Util.FileServe

30−import System.Environment (lookupEnv)

31import API

28import API

32import Snap

29import Snap

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

43testApi :: Proxy API

40testApi :: Proxy API

44testApi = Proxy

41testApi = Proxy

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

43+data App = App

48-- Server-side handlers.

45-- Server-side handlers.

49--

46--

@@ -54,7 +51,7 @@ data App = App { appStaticDir :: String }

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

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

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

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

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

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

57− :<|> statics

54+ :<|> serveDirectory "static"

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

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

59 sayhi nm greetings withGusto = case nm of

56 sayhi nm greetings withGusto = case nm of

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

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

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

79 req <- getRequest

76 req <- getRequest

80 liftIO $ putStrLn (show req)

77 liftIO $ putStrLn (show req)

81 return 101

78 return 101

82− statics = do

83− staticDir <- reader appStaticDir

84− serveDirectory staticDir

86-- Turn the server into a WAI app. 'serve' is provided by servant,

80-- Turn the server into a WAI app. 'serve' is provided by servant,

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

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

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

92initApp :: SnapletInit App App

86initApp :: SnapletInit App App

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

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

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

95 addRoutes [("", test)

88 addRoutes [("", test)

96 ,("", serveDirectory "static")

89 ,("", serveDirectory "static")

97 ]

90 ]

98− return (App staticDir)

91+ return App

100-- Put this all to work!

93-- Put this all to work!

101main :: IO ()

94main :: IO ()

testserver/run-wd-tests.shnew file+5

@@ -0,0 +1,5 @@

1+#!/usr/bin/env bash

3+dist/build/back/back -p 8000 &

4+phantomjs --webdriver=127.0.0.1:4444 &

5+dist/build/spec/spec

testserver/testserver.cabal+4−5

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

19 main-is: Main.hs

20 -- other-modules:

21 -- other-extensions:

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

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

23− , base >=4.8 && < 5

23+ , base >=4.8 && <4.11

24− , mtl

25 , snap >= 1.0 && < 1.2

24 , snap >= 1.0 && < 1.2

26− , snap-server >= 1.0 && < 1.2

25+ , snap-server >= 1.0 && < 1.1

27 , snap-core >= 1.0 && < 1.1

26 , snap-core >= 1.0 && < 1.1

28− , servant >= 0.16 && < 0.18

27+ , servant >= 0.8 && < 0.12

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

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

30 , text >= 1.0 && < 1.3

29 , text >= 1.0 && < 1.3

31 -- hs-source-dirs:

30 -- hs-source-dirs:

testserver/tr.nixnew file+32

@@ -0,0 +1,32 @@

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

2+let

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.nixdeleted−70

@@ -1,70 +0,0 @@

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)

5−

6− jsCompiler ? "ghcjs"

7− # ^ Choose a GHCJS for compiling the frontend

8− # (ghcjs, ghcjs8_0, ghcjs8_2 or ghcjs8_4)

9−

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