f5edec9...master · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

on master help sign in

.gitignore+2−1

since splitsnapshots

unifiedsplit

@@ -6,5 +6,6 @@ log

6*.webapp

7*.stats

8out

9−reflex-platform

10/.stack-work/

9/.stack-work/

10+TAGS

11+dist-newstyle

.gitmodules−15

@@ -1,15 +0,0 @@

1−[submodule "deps/reflex-dom"]

2− path = deps/reflex-dom

3− url = https://github.com/reflex-frp/reflex-dom.git

4−[submodule "deps/reflex"]

5− path = deps/reflex

6− url = https://github.com/reflex-frp/reflex.git

7−[submodule "deps/http-api-data"]

8− path = deps/http-api-data

9− url = https://github.com/fizruk/http-api-data

10−[submodule "deps/servant"]

11− path = deps/servant

12− url = https://github.com/haskell-servant/servant

13−[submodule "deps/servant-snap"]

14− path = deps/servant-snap

15− url = https://github.com/haskell-servant/servant-snap

.travis.yml+12−57

@@ -1,62 +1,17 @@

1−sudo: required

1+language: nix

2−

2+nix: 2.3.6

3−before_cache:

3+sudo: require

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

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

6−

7−addons:

8− apt:

9− - phantomjs

10−

11−matrix:

12− include:

13− - env: CABALVER=1.24 GHCVER=7.10.3

14− compiler: ": #GHC 7.10.3"

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

16− - env: CABALVER=1.24 GHCVER=8.0.1

17− compiler: ": #GHC 8.0.1"

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

19−

20−

22before_install:

5before_install:

23− - unset CC

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

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

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

27−install:

8+before_script:

28− - cabal --version

9+ - sudo systemctl restart nix-daemon.service

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

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

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

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

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

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

33− then

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

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

36− fi

37− - travis_retry cabal update -v

38− - git clone https://github.com/reflex-frp/reflex-platform

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

40− - reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && cabal configure -fExample && cabal build"

41− - reflex-platform/work-on ghc ./testdriver --command "cd testdriver && cabal configure && cabal build"

42− - cd testserver && dist/build/back/back -p 8000 &

43− - sleep 3

44− - phantomjs --webdriver=127.0.0.1:4444 &

45− - sleep 3

47script:

13script:

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

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

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

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

50− - ./build.sh

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

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

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

52−

53−cache:

54− directories:

55− - /nix

56− - $HOME/.cabal/packages

57− - $HOME/.cabal/store

58−

59−env:

60− global:

61− - ENCRYPTION_LABEL: "3c89d919c82e"

62− - COMMIT_AUTHOR_EMAIL: "imalsogreg@gmail.com"

changelog.md → ChangeLog.mdrenamed+28

@@ -1,3 +1,31 @@

1+0.3.5

2+-----

4+ - Require reflex-dom-core >= 0.6 (for internal handling of case-insensitive headers)

5+ - Require servant >= 0.16

6+ - Eliminate use of deprecated widgets from reflex-dom-core

7+ - Bump the version of reflex-platform used in nix-shell and test suite

9+0.3.4

10+-----

11+

12+Add selenium-based test suite

13+

14+0.3.3

15+-----

16+

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

18+

19+

20+0.3.2

21+-----

22+

23+- **Addition of 'Servant.Reflex.Common.Req.ClientOpts'** which

24+allows the users to apply a final adjustment to Requests before

25+thery are sent, such as setting the 'withCredentials' flag

26+or print the Request to the console for debugging

27+[PR #47](https://github.com/imalsogreg/servant-reflex/pull/47)

28+

10.3

290.3

2---

30---

README.md+72−35

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

5## `servant-reflex` lets you share your `servant` APIs with the frontend

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

7+Keeping your frontend in sync with your API server can be difficult - when the

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

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

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

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

8−Syncronization between is checked at compile time, and rather than building XHR requests by hand, API endpoints are available behind `reflex`'s FRP semantics.

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

9−

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

12## Example

16## Example

14−We have a webservice API defined in a module where both the server (compiled with ghc) and the frontend (compiled with ghcjs) can see it:

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

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

16```haskell

21```haskell

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

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

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

24 :<|> Raw

29 :<|> Raw

25```

30```

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

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

33+an `XhrRequest`.

29```haskell

35```haskell

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

37 (constDyn (BasePath "/"))

43 (constDyn (BasePath "/"))

38```

44```

40−These client functions are computed from your API type. They manage serialization, XhrRequest generation, and deserialization for you. `a` parameters used in URL captures become `Dynamic t (Either Text a)` parameters in the client functions. 'QueryFlag', 'QueryParams' and 'QueryParam' API parameters map to 'Dynamic t Bool', 'Dynamic t [a]' and 'Dynamic t (QParam a)' respectively. These parameters to the client function are wrapped with failure possibility to allow you to indicate at any time whether input validation for that parameter has failed and no valid XHR request can be generated. The final parameter is a trigger event for the XHR request. The return value `Event t (ReqResult a)` contains responses from the API server.

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

47+serialization, `XhrRequest` generation, and deserialization for you. `a`

48+parameters used in URL captures become `Dynamic t (Either Text a)` parameters

49+in the client functions. `QueryFlag`, `QueryParams` and `QueryParam` API

50+parameters map to `Dynamic t Bool`, `Dynamic t [a]` and `Dynamic t (QParam a)`

51+respectively. These parameters to the client function are wrapped with failure

52+possibility to allow you to indicate at any time whether input validation for

53+that parameter has failed and no valid XHR request can be generated. The final

54+parameter is a trigger event for the XHR request. The return value

55+`Event t (ReqResult a)` contains responses from the API server.

42```haskell

57```haskell

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

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

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

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

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

63```

78```

80+`ReqResult tag a` is defined in

65−`ReqResult tag a` is defined in [`Servant.Common.Req`](https://github.com/imalsogreg/servant-reflex/blob/6d866e338edb9bf6fd8f8d5083ff0187b4d8c0d2/src/Servant/Common/Req.hs#L40-L42) and reports whether or not your request was sent (if validation fails, the request won't be sent), and how decoding of the response went. You can pattern match on these explicitly, but usually you'll want to use `fmapMaybe :: (a -> Maybe b) -> Event t a -> Event t b` and one of the elimination functions to filter the result type you care about, like this:

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

82+and reports whether or not your request was sent (if validation fails, the

83+request won't be sent), and how decoding of the response went. You can pattern

84+match on these explicitly, but usually you'll want to use

85+`fmapMaybe :: (a -> Maybe b) -> Event t a -> Event t b` and one of the

86+elimination functions to filter the result type you care about, like this:

67```haskell

88```haskell

68 -- ... continued ...

89 -- ... continued ...

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

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

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

81```

102```

103

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

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

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

106

85```haskell

107```haskell

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

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

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

103 display =<< holdDyn Nothing outputDouble

125 display =<< holdDyn Nothing outputDouble

104```

126```

105

127

106−For a great introduction to recative DOM building, see the [README](https://github.com/reflex-frp/reflex-platform) for the `reflex-platform`. For more information about servant, see their [documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to the respective authors of these fabulous libraries.

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

129+[README](https://github.com/reflex-frp/reflex-platform) for the

130+`reflex-platform`. For more information about servant, see their

131+[documentation](http://haskell-servant.readthedocs.io/en/stable/). Thanks to

132+the respective authors of these fabulous libraries.

107

133

108

134

109## Building the library and test server

135## Building the library and test server

110

136

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

138+ghcjs-compiled frontend

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

140+ghc-compiled backend

111−This repository comes with a small example of an API shared between a ghcjs-compiled frontend ([exec/](https://github.com/imalsogreg/servant-reflex/tree/master/exec)) and a ghc-compiled backend ([testserver/](https://github.com/imalsogreg/servant-reflex/tree/master/testserver). To build these components:

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

112−

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

113−

143+manages the frontend build as a dependency.

114−First build the library:

115

144

116```

145```

117−git submodule update --init --recursive

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

118−./build.sh

119```

147```

120

148

121−Then build the test server:

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

122

150

123```

151```

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

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

125```

153```

126

154

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

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

157+under the Network tab.

127

158

128−## Running the example site

129−

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

131−

132−```

133−cd testserver

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

135−```

136−

137−And simply browse to `localhost:8001`

138−

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

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

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

140

161

141

162

142## Tagging requests

163## Tagging requests

143

164

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

144−The input and the return type of a client function like `getDouble` are both event streams. The individual input events and responses occur at different times and aren't automatically paired up, but you can recover the relationship by tagging the requests.

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

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

168+relationship by tagging the requests.

145

169

146−So far we have used an `Event t ()` to trigger sending a request. If we choose e.g. `Double` for the third `Proxy` argument to `client`, then `Event t Double` will be used to trigger requests, and each `ReqResult` will carry the tag of its request. Imagine we wanted to display not just the last "double" from `doubleIt`, but a whole table of valid inputs and their doubled responses:

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

171+e.g. `Double` for the third `Proxy` argument to `client`, then `Event t Double`

172+will be used to trigger requests, and each `ReqResult` will carry the tag of

173+its request. Imagine we wanted to display not just the last "double" from

174+`doubleIt`, but a whole table of valid inputs and their doubled responses:

147

175

148−```

176+```haskell

149 ...

177 ...

150 inp <- textInput def

178 inp <- textInput def

151

179

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

173

201

174## Simultaneous requests

202## Simultaneous requests

175

203

176−'Servant.Reflex.Multi' provides an alternative client-generation function called 'clientA' (client applicative). Choose a container type that has both `Applicative` and `Traversable` instances, and pass it to `clientA` through another 'Proxy'. Our `sayHi` client function will then have this type:

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

205+called `clientA` (client applicative). Choose a container type that has both

206+`Applicative` and `Traversable` instances, and pass it to `clientA` through

207+another `Proxy`. Our `sayHi` client function will then have this type:

177

208

178−```

209+```haskell

179sayHi

210sayHi

180 :: Dynamic t (f (QParam Text))

211 :: Dynamic t (f (QParam Text))

181 -> Dynamic t (f [Text])

212 -> Dynamic t (f [Text])

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

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

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

185```

216```

186

217

187−The dynamic params are each wrapped in `f`. For every firing of the trigger event `tag`, all of these parameters will be combined according to `f`'s applicative instance (when `f` is `[]`, you will get all combinations of all parameters taken together as a request; when `f` is 'ZipList', the Nth elemens of each parameters list will be taken together as a request). Using this interface, you can trigger many XHR's from a single event occurence, and expect the responses to be structured the same way as the requests.

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

219+event `tag`, all of these parameters will be combined according to `f`'s

220+`Applicative` instance (when `f` is `[]`, you will get all combinations of

221+all parameters taken together as a request; when `f` is `ZipList`, the Nth

222+elemens of each parameters list will be taken together as a request). Using

223+this interface, you can trigger many XHR's from a single event occurence, and

224+expect the responses to be structured the same way as the requests.

build.shdeleted−3

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

1−#!/usr/bin/env bash

2−

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

default.nixnew file+21

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

1+{ mkDerivation, base, bytestring, case-insensitive, containers

2+, data-default, exceptions, ghcjs-dom, http-api-data, http-media

3+, jsaddle, mtl, network-uri, reflex, reflex-dom, reflex-dom-core

4+, safe, servant, servant-auth, stdenv, string-conversions, text

5+, transformers

6+}:

7+mkDerivation {

8+ pname = "servant-reflex";

9+ version = "0.3.6";

10+ src = ./.;

11+ isLibrary = true;

12+ isExecutable = true;

13+ libraryHaskellDepends = [

14+ base bytestring case-insensitive containers data-default exceptions

15+ ghcjs-dom http-api-data http-media jsaddle mtl network-uri reflex

16+ reflex-dom reflex-dom-core safe servant servant-auth string-conversions

17+ text transformers

18+ ];

19+ description = "servant API generator for reflex apps";

20+ license = stdenv.lib.licenses.bsd3;

21+}

deps/http-api-datadeleted−1

Submodule changed.

deps/reflexdeleted−1

Submodule changed.

deps/reflex-domdeleted−1

Submodule changed.

deps/servantdeleted−1

Submodule changed.

deps/servant-snapdeleted−1

Submodule changed.

exec/API.hs+1

@@ -40,6 +40,7 @@ type API = "getunit" :> Get '[JSON] ()

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

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

42 :> Post '[JSON] Answer

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

43 :<|> Raw

44 :<|> Raw

45type GET = Get '[JSON] ()

46type GET = Get '[JSON] ()

exec/Example.hs+27−6

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

1+{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

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

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

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

15import Data.Text (Text)

16import Data.Text (Text)

16import qualified Data.Text as T

17import qualified Data.Text as T

18+import qualified Data.Text.Encoding as T

17import GHC.TypeLits

19import GHC.TypeLits

18import Servant.API

20import Servant.API

19import API

21import API

20import Data.Proxy

22import Data.Proxy

21import Text.Read (readMaybe)

23import Text.Read (readMaybe)

22−import Reflex.Dom

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

25+import Reflex.Dom (mainWidget)

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

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

24import Servant.Reflex

27import Servant.Reflex

25import Servant.Reflex.Multi

28import Servant.Reflex.Multi

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

43runMulti = do

46runMulti = do

44 url <- baseUrlWidget

47 url <- baseUrlWidget

45 el "br" blank

48 el "br" blank

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

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

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

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

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

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

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

66 textInput def

69 textInput def

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

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

68 b <- button "Go"

71 b <- button "Go"

69− r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts) (constDyn [True, False]) (1 <$ b)

72+ r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)

73+ (constDyn [True, False]) (1 <$ b)

74+

75+ dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .

76+ fmap reqSuccess <$> r')

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

73 return ()

79 return ()

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

91 el "br" (return ())

97 el "br" (return ())

93 -- Name the computed API client functions

99 -- Name the computed API client functions

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

101+ return $ r & withCredentials .~ True

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

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

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

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

105

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

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

107

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

177 el "p" $

186 el "p" $

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

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

179

188

189+ divClass "demo-group" $ do

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

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

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

193+ <$> fmap T.encodeUtf8 un

194+ <*> fmap T.encodeUtf8 pw

195+ b <- button "Get secret"

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

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

198+ display res

199+

200+

180showXhrResponse :: XhrResponse -> Text

201showXhrResponse :: XhrResponse -> Text

181showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

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

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

nix/nix.confnew file+3

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

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

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

3+trusted-users = travis

nix/reflex-platform.nixnew file+7

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

1+let

2+ rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;

3+in import (builtins.fetchTarball

4+ {

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

6+ sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;

7+ }) {}

nix/servant-snap.nixnew file+7

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

1+# Servant-snap is marked broken in nixpkgs

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

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

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

5+ rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";

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

7+}) {}

nix/testresults.nixnew file+17

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

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

3+reflexPlatform.nixpkgs.pkgs.runCommand "runWebdriveTest.sh" {} ''

4+ echo About to phantom

5+ ${phantomjs}/bin/phantomjs --webdriver=127.0.0.1:4444 &

6+ sleep 3

7+ echo About to Server

8+ STATIC_DIR=${testserver}/static ${testserver}/back -q --no-access-log --no-error-log -p 8000 &

9+ sleep 3

10+ ${curl}/bin/curl localhost:8000

11+ ${curl}/bin/curl localhost:8000/runmain.js

12+ echo About to testdrive

13+ ${testdriver}/bin/spec > $out 2>&1

14+ echo Done

15+ trap "exit" INT TERM

16+ trap "kill 0" EXIT

17+ ''

nix/testserver.nixnew file+9

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

1+servant-reflex: self: super:

3+(self.callCabal2nix "testserver" ../testserver {}).overrideDerivation (drv: {

4+ postInstall = ''

5+ cp dist/build/back/back $out/back

6+ mkdir $out/static

7+ cp ${servant-reflex}/bin/example.jsexe/* $out/static/

8+ '';

9+})

overrides-ghc.nixdeleted−19

@@ -1,19 +0,0 @@

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

2−let

3− pkgs = import <nixpkgs> {};

4− c2n = reflex-platform.cabal2nixResult;

5−in reflex-platform.ghc.override {

6− overrides = self: super: {

7− servant-snap = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap) {});

8− snap = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap) {});

9− snap-server = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-server) {});

10− io-streams = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams) {});

11− io-streams-haproxy = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});

12− heist = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});

13− xmlhtml = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});

14− snap-core = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-core) {});

15− servant = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant/servant) {});

16− Glob = pkgs.haskell.lib.dontCheck super.Glob;

17− http-api-data = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/http-api-data) {});

18− };

19−}

overrides.nixdeleted−35

@@ -1,35 +0,0 @@

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

2−let

3−

4− nixpkgs = (import <nixpkgs> {});

5− dontCheck = nixpkgs.pkgs.haskell.lib.dontCheck;

6− cabal2nixResult = reflex-platform.cabal2nixResult;

7−

8−in

9−reflex-platform.ghcjs.override {

10− overrides = self: super: {

11− servant = dontCheck (self.callPackage (cabal2nixResult deps/servant/servant) {});

12− http-api-data = dontCheck (self.callPackage (cabal2nixResult deps/http-api-data) {});

13− natural-transformation = self.callPackage (

14− { mkDerivation, base, containers, fetchgit, quickcheck-instances

15− , stdenv, tasty, tasty-quickcheck

16− }:

17− mkDerivation {

18− pname = "natural-transformation";

19− version = "0.4";

20− src = fetchgit {

21− url = "https://github.com/ku-fpg/natural-transformation";

22− sha256 = "0xbnnxbf5ydszbhf7h5ra3mrqy4mcyqc3zb2k8bwm1zyqrz6v0fs";

23− rev = "b1200c09dcafd034e32846413913b74735c8ba56";

24− };

25− libraryHaskellDepends = [ base ];

26− testHaskellDepends = [

27− base containers quickcheck-instances tasty tasty-quickcheck

28− ];

29− homepage = "https://github.com/ku-fpg/natural-transformation";

30− description = "A natural transformation package";

31− license = stdenv.lib.licenses.bsd3;

32− }

33− ) {};

34− };

35−}

servant-reflex.cabal+28−19

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

1Name: servant-reflex

2−Version: 0.3

2+Version: 0.3.6

3−Synopsis: Servant reflex API generator

3+Synopsis: servant API generator for reflex apps

4−Description: Servant reflex API generator

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

5−License: AllRightsReserved

5+License: BSD3

6License-file: LICENSE.md

7Author: Greg Hale, Doug Beardsley

8Maintainer: imalsogreg@gmail.com

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

18library

19 exposed-modules:

20− Servant.Reflex

21− Servant.Reflex.Multi

22−

23− other-modules:

24 Servant.Common.BaseUrl

20 Servant.Common.BaseUrl

25 Servant.Common.Req

21 Servant.Common.Req

22+ Servant.Reflex

23+ Servant.Reflex.Multi

27 hs-source-dirs: src

25 hs-source-dirs: src

28 build-depends:

26 build-depends:

29− base >= 4.8 && < 4.10,

27+ base >= 4.8 && < 5,

30 bytestring >= 0.10 && < 0.11,

28 bytestring >= 0.10 && < 0.11,

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

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

32− containers >= 0.5.6 && < 0.6,

30+ containers >= 0.5.6 && < 0.7,

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

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

34− exceptions >= 0.8 && < 0.9,

32+ exceptions >= 0.8 && < 0.11,

35− ghcjs-dom >= 0.2 && < 0.3,

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

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

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

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

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

36+ jsaddle >= 0.8 && < 0.10,

38 mtl >= 2.2.1 && < 2.3,

37 mtl >= 2.2.1 && < 2.3,

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

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

40− reflex >= 0.5 && < 0.6,

39+ reflex >= 0.5 && < 0.9,

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

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

42 safe >= 0.3.9 && < 0.4,

41 safe >= 0.3.9 && < 0.4,

43− servant >= 0.8 && < 0.11,

42+ servant >= 0.16 && < 0.19,

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

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

45 text >= 1.2 && < 1.3,

46 transformers >= 0.4 && < 0.6

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

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

50 default-language: Haskell2010

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

54 buildable: True

55 else

56 buildable: False

57− build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text

57+ build-depends:

58+ aeson,

59+ reflex,

60+ servant-reflex,

61+ base,

62+ scientific,

63+ servant,

64+ reflex-dom,

65+ reflex-dom-core,

66+ text

58 default-language: Haskell2010

67 default-language: Haskell2010

59 main-is: Example.hs

68 main-is: Example.hs

60 other-modules: API

69 other-modules: API

shell.nixnew file+1

@@ -0,0 +1 @@

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

src/Servant/Common/BaseUrl.hs+13−9

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

1{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

@@ -20,18 +21,22 @@ module Servant.Common.BaseUrl (

20) where

21) where

22import Control.Monad (join)

23import Control.Monad (join)

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

24+-- import Control.Monad.IO.Class (MonadIO)

24import Control.Monad.Fix (MonadFix)

25import Control.Monad.Fix (MonadFix)

25import Data.Monoid ((<>))

26import Data.Monoid ((<>))

26import Data.Text (Text)

27import Data.Text (Text)

27import qualified Data.Text as T

28import qualified Data.Text as T

28import GHC.Generics

29import GHC.Generics

30+import Language.Javascript.JSaddle.Monad (MonadJSM)

29import Reflex

31import Reflex

30−import Reflex.Dom

32+import Reflex.Dom.Core

31import Text.Read

33import Text.Read

33−

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

34−type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadIO (Performable m))

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

37+#else

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

39+#endif

36-- | URI scheme to use

41-- | URI scheme to use

37data Scheme =

42data Scheme =

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

84 where pathWidget :: m (Dynamic t BaseUrl)

89 where pathWidget :: m (Dynamic t BaseUrl)

85 pathWidget = do

90 pathWidget = do

86 text "Url base path"

91 text "Url base path"

87− t <- textInput (def {_textInputConfig_attributes =

92+ t <- inputElement def

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

89 return $ BasePath <$> value t

93 return $ BasePath <$> value t

90 fullUrlWidget :: m (Dynamic t BaseUrl)

94 fullUrlWidget :: m (Dynamic t BaseUrl)

91 fullUrlWidget = do

95 fullUrlWidget = do

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

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

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

97+ srv <- inputElement def

94 text ":"

98 text ":"

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

99+ prt <- inputElement def

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

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

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

101+ path <- inputElement def

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

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

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

@@ -1,20 +1,25 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

4{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE TupleSections #-}

9{-# LANGUAGE TupleSections #-}

9module Servant.Common.Req where

11module Servant.Common.Req where

11-------------------------------------------------------------------------------

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

12−import Control.Concurrent

13import Control.Applicative (liftA2, liftA3)

14import Control.Applicative (liftA2, liftA3)

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

16+import Control.Concurrent

14import Control.Monad (join)

17import Control.Monad (join)

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

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

16import Data.Bifunctor (first)

19import Data.Bifunctor (first)

20+import qualified Data.ByteString.Builder as Builder

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

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

22+import Data.ByteString (ByteString)

18import qualified Data.Map as Map

23import qualified Data.Map as Map

19import Data.Maybe (catMaybes, fromMaybe)

24import Data.Maybe (catMaybes, fromMaybe)

20import Data.Functor.Compose

25import Data.Functor.Compose

@@ -24,7 +29,9 @@ import Data.Text (Text)

24import qualified Data.Text as T

29import qualified Data.Text as T

25import qualified Data.Text.Encoding as TE

30import qualified Data.Text.Encoding as TE

26import Data.Traversable (forM)

31import Data.Traversable (forM)

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

33+import qualified Network.URI as N

27−import Reflex.Dom hiding (tag)

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

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

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

29 SupportsServantReflex)

36 SupportsServantReflex)

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

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

@@ -43,7 +50,25 @@ data ReqResult tag a

43 -- a non-successful response code

50 -- a non-successful response code

44 | RequestFailure tag Text

51 | RequestFailure tag Text

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

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

46−

53+ deriving (Functor)

54+

55+data ClientOptions = ClientOptions

56+ { optsRequestFixup :: forall a. Show a => XhrRequest a -> JSM (XhrRequest a)

57+ -- ^ Aribtrarily modify requests just before they are sent.

58+ -- Warning: This escape hatch opens the possibility for your

59+ -- requests to diverge from what the server expects, when the

60+ -- server is also derived from a servant API

61+ }

62+

63+defaultClientOptions :: ClientOptions

64+defaultClientOptions = ClientOptions { optsRequestFixup = return }

65+

66+-- withCredentials :: Lens' (XhrRequest a) Bool

67+withCredentials :: (Show a, Functor f) => (Bool -> f Bool) -> XhrRequest a -> f (XhrRequest a)

68+withCredentials inj r@(XhrRequest _ _ cfg) =

69+ let cfg' = (\b -> cfg { _xhrRequestConfig_withCredentials = b}) <$>

70+ inj (_xhrRequestConfig_withCredentials cfg)

71+ in (\c' -> r {_xhrRequest_config = c' }) <$> cfg'

48------------------------------------------------------------------------------

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

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

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

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

68reqFailure (RequestFailure _ s) = Just s

93reqFailure (RequestFailure _ s) = Just s

69reqFailure _ = Nothing

94reqFailure _ = Nothing

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

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

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

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

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

101+reqFailure' _ = Nothing

102+

103

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

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

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

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

@@ -83,13 +115,6 @@ reqTag (ResponseSuccess tag _ _) = tag

83reqTag (ResponseFailure tag _ _) = tag

115reqTag (ResponseFailure tag _ _) = tag

84reqTag (RequestFailure tag _ ) = tag

116reqTag (RequestFailure tag _ ) = tag

117

86−------------------------------------------------------------------------------

87−instance Functor (ReqResult tag) where

88− fmap f (ResponseSuccess tag a xhr) = ResponseSuccess tag (f a) xhr

89− fmap _ (ResponseFailure tag r x) = ResponseFailure tag r x

90− fmap _ (RequestFailure tag r) = RequestFailure tag r

91−

92−

93-------------------------------------------------------------------------------

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

94-- | You must wrap the parameter of a QueryParam endpoint with 'QParam' to

119-- | You must wrap the parameter of a QueryParam endpoint with 'QParam' to

95-- indicate whether the parameter is valid and present, validly absent, or

120-- indicate whether the parameter is valid and present, validly absent, or

@@ -142,7 +167,7 @@ reqToReflexRequest

142 => Text

167 => Text

143 -> Dynamic t BaseUrl

168 -> Dynamic t BaseUrl

144 -> Req t

169 -> Req t

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

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

146reqToReflexRequest reqMeth reqHost req =

171reqToReflexRequest reqMeth reqHost req =

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

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

148 t = sequence $ reverse $ reqPathParts req

173 t = sequence $ reverse $ reqPathParts req

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

154 urlParts = fmap sequence t

179 urlParts = fmap sequence t

155

180

156 urlPath :: Dynamic t (Either Text Text)

181 urlPath :: Dynamic t (Either Text Text)

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

182+ urlPath = (fmap.fmap)

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

184+ urlParts

158

185

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

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

160 queryPartString (pName, qp) = case qp of

187 queryPartString (pName, qp) = case qp of

161 QueryPartParam p -> ffor p $ \case

188 QueryPartParam p -> ffor p $ \case

162 Left e -> Just (Left e)

189 Left e -> Just (Left e)

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

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

164 Right Nothing -> Nothing

191 Right Nothing -> Nothing

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

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

166 if null pStrings

193 if null pStrings

167 then Nothing

194 then Nothing

195+ else Just . Right

196+ . T.intercalate "&"

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

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

169 QueryPartFlag fl -> ffor fl $ \case

198 QueryPartFlag fl -> ffor fl $ \case

170 True -> Just $ Right pName

199 True -> Just $ Right pName

171 False -> Nothing

200 False -> Nothing

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

200 Right $ XhrRequestConfig

229 Right $ XhrRequestConfig

201 { _xhrRequestConfig_sendData = bytesToPayload bBytes

230 { _xhrRequestConfig_sendData = bytesToPayload bBytes

202 , _xhrRequestConfig_headers =

231 , _xhrRequestConfig_headers =

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

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

204 , _xhrRequestConfig_user = Nothing

233 , _xhrRequestConfig_user = Nothing

205 , _xhrRequestConfig_password = Nothing

234 , _xhrRequestConfig_password = Nothing

206− , _xhrRequestConfig_responseType = Nothing

235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

207 , _xhrRequestConfig_withCredentials = False

236 , _xhrRequestConfig_withCredentials = False

208 , _xhrRequestConfig_responseHeaders = def

237 , _xhrRequestConfig_responseHeaders = def

209 }

238 }

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

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

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

216 , _xhrRequestConfig_user = Nothing

245 , _xhrRequestConfig_user = Nothing

217 , _xhrRequestConfig_password = Nothing

246 , _xhrRequestConfig_password = Nothing

218− , _xhrRequestConfig_responseType = Nothing

247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

219− , _xhrRequestConfig_sendData = ""

248+ , _xhrRequestConfig_sendData = mempty

220 , _xhrRequestConfig_withCredentials = False

249 , _xhrRequestConfig_withCredentials = False

221 }

250 }

222 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

@@ -243,41 +272,57 @@ reqToReflexRequest reqMeth reqHost req =

243displayHttpRequest :: Text -> Text

272displayHttpRequest :: Text -> Text

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

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

245

274

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

275+-- | This function performs the request

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

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

248 => Text

277 => Text

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

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

250 -> Dynamic t BaseUrl

279 -> Dynamic t BaseUrl

280+ -> ClientOptions

251 -> Event t tag

281 -> Event t tag

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

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

253−performRequests reqMeth rs reqHost trigger = do

283+performRequests reqMeth rs reqHost opts trigger = do

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

284+ let xhrReqs =

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

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

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

287+

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

289+ reqs = attachPromptlyDynWith

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

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

291+

257− resps <- performSomeRequestsAsync reqs

292+ resps <- performSomeRequestsAsync opts reqs

258 return $ getCompose <$> resps

293 return $ getCompose <$> resps

259

294

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

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

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

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

261performSomeRequestsAsync

298performSomeRequestsAsync

262 :: (MonadIO (Performable m),

299 :: (MonadIO (Performable m),

300+ MonadJSM (Performable m),

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

263 HasWebView (Performable m),

302 HasWebView (Performable m),

303+#endif

264 PerformEvent t m,

304 PerformEvent t m,

265 TriggerEvent t m,

305 TriggerEvent t m,

266 Traversable f,

306 Traversable f,

267− IsXhrPayload a)

307+ IsXhrPayload a,

308+ Show a

309+ )

310+ => ClientOptions

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

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

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

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

313+performSomeRequestsAsync opts =

270−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return

314+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

271

315

272

316

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

317------------------------------------------------------------------------------

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

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

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

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

276performSomeRequestsAsync'

320performSomeRequestsAsync'

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

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

322+ => ClientOptions

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

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

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

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

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

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

281 rs <- hrs

326 rs <- hrs

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

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

283 Left e -> do

328 Left e -> do

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

285 return resp

330 return resp

286 Right r' -> do

331 Right r' -> do

287 resp <- liftIO newEmptyMVar

332 resp <- liftIO newEmptyMVar

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

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

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

289 return resp

335 return resp

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

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

291 return ()

337 return ()

292

338

293

339

294

340

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

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

297− => Text

298− -> (Req t)

299− -> Dynamic t BaseUrl

300− -> Event t tag

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

302−performRequest reqMeth req reqHost trigger = do

303−

304− let xhrReq = reqToReflexRequest reqMeth reqHost req

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

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

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

308−

309− resps <- performRequestsAsync okReqs

310−

311− return (resps, badReqs)

312−

313−

314−type XhrPayload = T.Text

341+type XhrPayload = ByteString

315bytesToPayload :: BL.ByteString -> XhrPayload

342bytesToPayload :: BL.ByteString -> XhrPayload

316−bytesToPayload = TE.decodeUtf8 . BL.toStrict

343+bytesToPayload = BL.toStrict

317−

318−

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

320−-- => Text

321−-- -> Req t

322−-- -> Dynamic t BaseUrl

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

324−-- performRequestNoBody reqMeth req reqHost trigger = do

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

326−-- let decodeResp = const $ Right NoContent

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

328−-- , fmap (uncurry RequestFailure) badReq

329−-- ]

330−

331−

332−-- performRequestCT

333−-- :: (SupportsServantReflex t m,

334−-- MimeUnrender ct a)

335−-- => Proxy ct

336−-- -> Text

337−-- -> Req t

338−-- -> Dynamic t BaseUrl

339−-- -> Event t tag

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

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

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

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

344−-- mimeUnrender ct .

345−-- BL.fromStrict .

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

347−-- (_xhrResponse_responseText x)

348−

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

350−-- , fmap (uncurry RequestFailure) badReq

351−-- ]

352

344

353

345

354performRequestsCT

346performRequestsCT

@@ -358,19 +350,20 @@ performRequestsCT

358 -> Text

350 -> Text

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

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

360 -> Dynamic t BaseUrl

352 -> Dynamic t BaseUrl

353+ -> ClientOptions

361 -> Event t tag

354 -> Event t tag

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

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

363−performRequestsCT ct reqMeth reqs reqHost trigger = do

356+performRequestsCT ct reqMeth reqs reqHost opts trigger = do

364− resps <- performRequests reqMeth reqs reqHost trigger

357+ resps <- performRequests reqMeth reqs reqHost opts trigger

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

365− let decodeResp x = first T.pack .

359+ first T.pack .

366− mimeUnrender ct .

360+ mimeUnrender ct $

367− BL.fromStrict .

361+ BL.fromStrict x

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

362+ decodeResp _ = Left "No body"

369− (_xhrResponse_responseText x)

370 return $ fmap

363 return $ fmap

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

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

372 Left e -> RequestFailure t e

365 Left e -> RequestFailure t e

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

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

374 )

367 )

375 resps

368 resps

376

369

@@ -381,10 +374,11 @@ performRequestsNoBody

381 => Text

374 => Text

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

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

383 -> Dynamic t BaseUrl

376 -> Dynamic t BaseUrl

377+ -> ClientOptions

384 -> Event t tag

378 -> Event t tag

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

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

386−performRequestsNoBody reqMeth reqs reqHost trigger = do

380+performRequestsNoBody reqMeth reqs reqHost opts trigger = do

387− resps <- performRequests reqMeth reqs reqHost trigger

381+ resps <- performRequests reqMeth reqs reqHost opts trigger

388 let decodeResp = const $ Right NoContent

382 let decodeResp = const $ Right NoContent

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

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

390 Left e -> RequestFailure tag e

384 Left e -> RequestFailure tag e

@@ -397,7 +391,8 @@ evalResponse

397 -> (tag, XhrResponse)

391 -> (tag, XhrResponse)

398 -> ReqResult tag a

392 -> ReqResult tag a

399evalResponse decode (tag, xhr) =

393evalResponse decode (tag, xhr) =

400− let okStatus = _xhrResponse_status xhr < 400

394+ let status = _xhrResponse_status xhr

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

401 errMsg = fromMaybe

396 errMsg = fromMaybe

402 ("Empty response with error code " <>

397 ("Empty response with error code " <>

403 T.pack (show $ _xhrResponse_status xhr))

398 T.pack (show $ _xhrResponse_status xhr))

@@ -410,7 +405,17 @@ evalResponse decode (tag, xhr) =

410 else ResponseFailure tag errMsg xhr

405 else ResponseFailure tag errMsg xhr

411 in respPayld

406 in respPayld

412

407

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

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

410+-- response 'Event's,

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

412+fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess

413

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

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

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

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

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

414

419

415

420

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

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

@@ -419,3 +424,9 @@ note e = maybe (Left e) Right

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

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

420fmapL _ (Right a) = Right a

425fmapL _ (Right a) = Right a

421fmapL f (Left e) = Left (f e)

426fmapL f (Left e) = Left (f e)

427+

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

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

430+

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

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

src/Servant/Reflex.hs+204−106

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

1−{-# LANGUAGE AllowAmbiguousTypes #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

2+{-# LANGUAGE CPP #-}

3−{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE InstanceSigs #-}

7+{-# LANGUAGE InstanceSigs #-}

7−{-# LANGUAGE OverloadedStrings #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TupleSections #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE TypeOperators #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

15−{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE OverloadedStrings #-}

16−{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE Rank2Types #-}

17−{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

18−{-# LANGUAGE TupleSections #-}

13+{-# LANGUAGE TupleSections #-}

19−{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE TypeFamilies #-}

20−{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE TypeOperators #-}

21−{-# LANGUAGE UndecidableInstances #-}

16+{-# LANGUAGE UndecidableInstances #-}

17+

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

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

20+#endif

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

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

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

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

@@ -26,46 +25,57 @@

26-- API.

25-- API.

27module Servant.Reflex

26module Servant.Reflex

28 ( client

27 ( client

28+ , clientWithOpts

29+ , clientWithOptsAndResultHandler

30+ , clientWithRoute

31+ , clientWithRouteAndResultHandler

29 , BuildHeaderKeysTo(..)

32 , BuildHeaderKeysTo(..)

30 , toHeaders

33 , toHeaders

31− , HasClient(..)

34+ , HasClient

35+ , Client

32 , module Servant.Common.Req

36 , module Servant.Common.Req

33 , module Servant.Common.BaseUrl

37 , module Servant.Common.BaseUrl

34 ) where

38 ) where

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

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

37import Control.Applicative

41import Control.Applicative

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

39−import qualified Data.Set as Set

40−import qualified Data.Text.Encoding as E

41−import Data.CaseInsensitive (mk)

42+import qualified Data.CaseInsensitive as CI

42import Data.Functor.Identity

43import Data.Functor.Identity

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

44import qualified Data.Map as Map

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

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

47+import qualified Data.Set as Set

45import Data.Text (Text)

48import Data.Text (Text)

46import qualified Data.Text as T

49import qualified Data.Text as T

50+import qualified Data.Text.Encoding as E

51+import GHC.Exts (Constraint)

47import GHC.TypeLits (KnownSymbol, symbolVal)

52import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

49− BasicAuthData, BuildHeadersTo(..),

54+ BasicAuthData, BuildHeadersTo (..),

50− Capture, contentType, Header,

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

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

56+ HttpVersion, IsSecure,

52− MimeRender(..), MimeUnrender,

57+ MimeRender (..), MimeUnrender,

53− NoContent, QueryFlag, QueryParam,

58+ NoContent, QueryFlag, QueryParam',

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

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

55 RemoteHost, ReqBody,

60 RemoteHost, ReqBody,

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

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

57−

62+ contentType)

63+import Servant.API.Description (Summary)

64+import qualified Servant.Auth as Auth

65+

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

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

59− XhrRequest(..),

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

60− XhrResponseHeaders(..),

68+ XhrResponseHeaders (..),

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

69+ attachPromptlyDynWith, constDyn, ffor,

70+ fmapMaybe, leftmost,

62− leftmost, performRequestsAsync,

71+ performRequestsAsync)

63− )

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

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

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

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

66 showBaseUrl,

74 showBaseUrl,

67 SupportsServantReflex)

75 SupportsServantReflex)

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

77+ defaultClientOptions,

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

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

69 QueryPart(..), addHeader, authData,

79 QueryPart(..), addHeader, authData,

70 defReq, evalResponse, prependToPathParts,

80 defReq, evalResponse, prependToPathParts,

71 -- performRequestCT,

81 -- performRequestCT,

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

75 performSomeRequestsAsync,

85 performSomeRequestsAsync,

76 qParamToQueryPart, reqBody,

86 qParamToQueryPart, reqBody,

77 reqSuccess, reqFailure,

87 reqSuccess, reqFailure,

78− reqMethod, respHeaders, response,

88+ reqMethod, respHeaders,

89+ response,

79 reqTag,

90 reqTag,

80− qParams)

91+ qParams, withCredentials)

83-- * Accessing APIs as a Client

94-- * Accessing APIs as a Client

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

92-- >

103-- >

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

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

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

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

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

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

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

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

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

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

109+client

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

110+ :: (HasClient t m layout tag)

111+ => Proxy layout

112+ -> Proxy m

113+ -> Proxy tag

114+ -> Dynamic t BaseUrl

115+ -> Client t m layout tag

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

117+

118+clientWithOpts

119+ :: (HasClient t m layout tag)

120+ => Proxy layout

121+ -> Proxy m

122+ -> Proxy tag

123+ -> Dynamic t BaseUrl

124+ -> ClientOptions

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

125+ -> Client t m layout tag

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

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

127+

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

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

130+-- across call sites.

131+clientWithOptsAndResultHandler

132+ :: (HasClient t m layout tag)

133+ => Proxy layout

134+ -> Proxy m

135+ -> Proxy tag

136+ -> Dynamic t BaseUrl

137+ -> ClientOptions

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

139+ -> Client t m layout tag

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

101

141

102

142

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

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

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

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

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

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

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

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

107 type Client t m layout tag :: *

147 type Client t m layout tag :: *

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

148+ clientWithRoute

149+ :: Proxy layout

150+ -> Proxy m

151+ -> Proxy tag

152+ -> Req t

153+ -> Dynamic t BaseUrl

154+ -> ClientOptions

155+ -> Client t m layout tag

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

157+

158+ clientWithRouteAndResultHandler

159+ :: Proxy layout

160+ -> Proxy m

161+ -> Proxy tag

162+ -> Req t

163+ -> Dynamic t BaseUrl

164+ -> ClientOptions

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

166+ -> Client t m layout tag

109

167

110

168

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

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

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

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

113

171

114− clientWithRoute Proxy q pTag req baseurl =

172+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =

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

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

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

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

117

175

118

176

119-- Capture. Example:

177-- Capture. Example:

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

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

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

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

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

136

194

137− clientWithRoute Proxy q t req baseurl val =

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

138− clientWithRoute (Proxy :: Proxy sublayout)

196+ clientWithRouteAndResultHandler

139− q t

140− (prependToPathParts p req)

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

141− baseurl

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

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

143

199

144

200

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

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

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

152 -- TODO how to access input types here?

208 -- TODO how to access input types here?

153 -- ExceptT ServantError IO a

209 -- ExceptT ServantError IO a

154− clientWithRoute Proxy _ _ req baseurl trigs =

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

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

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

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

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

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

158 req' = req { reqMethod = method }

213 req' = req { reqMethod = method }

159

214

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

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

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

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

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

168 -- ExceptT ServantError IO NoContent

223 -- ExceptT ServantError IO NoContent

169− clientWithRoute Proxy _ _ req baseurl =

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

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

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

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

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

172

227

173

228

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

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

175toHeaders r =

230toHeaders r =

176− let toBS = E.encodeUtf8

177− hdrs = maybe []

231+ let hdrs = maybe []

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

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

179 (Map.toList $ _xhrResponse_headers xhr))

233 (Map.toList $ _xhrResponse_headers xhr))

180 (response r)

234 (response r)

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

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

182

236

237+

183class BuildHeaderKeysTo hs where

238class BuildHeaderKeysTo hs where

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

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

185

240

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

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

187 where buildHeaderKeysTo _ = []

242 where buildHeaderKeysTo _ = []

188

243

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

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

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

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

246+ buildHeaderKeysTo _ =

247+ let

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

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

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

250+

192

251

193-- HEADERS Verb (Content) --

252-- HEADERS Verb (Content) --

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

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

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

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

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

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

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

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

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

206− clientWithRoute Proxy _ _ req baseurl trigs = do

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

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

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

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

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

209− return $ toHeaders <$> resp

268+ wrap $ toHeaders <$> resp

210 where req' = req { respHeaders =

269 where req' = req { respHeaders =

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

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

212 }

271 }

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

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

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

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

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

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

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

222− clientWithRoute Proxy _ _ req baseurl trigs = do

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

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

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

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

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

225− return $ toHeaders <$> resp

284+ wrap $ toHeaders <$> resp

226 where req' = req {respHeaders =

285 where req' = req {respHeaders =

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

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

228 }

287 }

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

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

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

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

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

251

310

252− clientWithRoute Proxy q t req baseurl eVal =

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

312+ clientWithRouteAndResultHandler

253− clientWithRoute (Proxy :: Proxy sublayout)

313+ (Proxy :: Proxy sublayout) q t

254− q t

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

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

256− baseurl

315+ baseurl opts wrap

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

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

258

317

259

318

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

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

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

268 Client t m sublayout tag

327 Client t m sublayout tag

269

328

270− clientWithRoute Proxy q t =

329+ clientWithRouteAndResultHandler Proxy =

330+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

331+

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

333+-- functions.

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

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

336+

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

338+ Client t m sublayout tag

339+

340+ clientWithRouteAndResultHandler Proxy =

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

341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

342+

343+

272

344

273

345

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

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

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

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

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

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

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

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

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

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

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

302

374

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

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

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

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

305

377

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

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

307− clientWithRoute Proxy q t req baseurl mparam =

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

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

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

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

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

310

382

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

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

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

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

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

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

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

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

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

352

424

353− clientWithRoute Proxy q t req baseurl paramlist =

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

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

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

355

427

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

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

357 pname = symbolVal (Proxy :: Proxy sym)

429 pname = symbolVal (Proxy :: Proxy sym)

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

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

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

391 Dynamic t Bool -> Client t m sublayout tag

463 Dynamic t Bool -> Client t m sublayout tag

392

464

393− clientWithRoute Proxy q t req baseurl flag =

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

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

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

395

467

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

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

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

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

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

405 -> Event t tag

477 -> Event t tag

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

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

407

479

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

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

409

481

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

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

411 Left e -> Left e

483 Left e -> Left e

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

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

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

417

489

418 resps <- performRequestsAsync okReq

490 resps <- performRequestsAsync okReq

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

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

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

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

421 ]

493 ]

422

494

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

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

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

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

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

449

521

450− clientWithRoute Proxy q t req baseurl body =

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

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

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

452 where req' = req { reqBody = bodyBytesCT }

524 where req' = req { reqBody = bodyBytesCT }

453 ctProxy = Proxy :: Proxy ct

525 ctProxy = Proxy :: Proxy ct

454 ctString = T.pack $ show $ contentType ctProxy

526 ctString = T.pack $ show $ contentType ctProxy

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

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

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

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

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

464

536

465− clientWithRoute Proxy q t req baseurl =

537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =

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

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

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

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

468

540

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

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

470

542

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

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

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

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

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

474

546

475− clientWithRoute Proxy q t req baseurl =

547+ clientWithRouteAndResultHandler Proxy =

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

548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

477

549

478

550

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

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

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

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

481

553

482− clientWithRoute Proxy q t req baseurl =

554+ clientWithRouteAndResultHandler Proxy =

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

555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

484

556

485

557

486

558

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

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

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

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

489

561

490− clientWithRoute Proxy q t req baseurl =

562+ clientWithRouteAndResultHandler Proxy =

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

563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

492

564

493

565

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

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

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

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

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

498 -> Client t m api tag

570 -> Client t m api tag

499

571

500− clientWithRoute Proxy q t req baseurl authdata =

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

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

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

502 where

574 where

503 req' = req { authData = Just authdata }

575 req' = req { authData = Just authdata }

504

576

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

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

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

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

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

526-}

598-}

599+

600+

601+-- SUPPORT FOR servant-auth --

602+

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

604+-- way that is inaccessible to JavaScript.

605+--

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

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

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

609+-- directly.

610+

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

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

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

614+

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

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

617+

618+

619+type family HasCookieAuth xs :: Constraint where

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

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

622+ HasCookieAuth '[] = CookieAuthNotEnabled

623+

624+class CookieAuthNotEnabled

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

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

16module Servant.Reflex.Multi (

17 -- * Compute servant client functions

18 clientA

19+ , clientWithOptsA

19 , BaseUrl(..)

20 , BaseUrl(..)

20 , Scheme(..)

21 , Scheme(..)

22 -- * Build QueryParam arguments

23 -- * Build QueryParam arguments

23 , QParam(..)

24 , QParam(..)

26+ -- * Access response data

27+ , withCredentials

26 -- * Access response data

29 -- * Access response data

27 , ReqResult(..)

30 , ReqResult(..)

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

34 ) where

37 ) where

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

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

37−import Control.Applicative (liftA2)

40+import Control.Applicative (liftA2)

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

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

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

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

40−import qualified Data.Set as Set

43+import qualified Data.Set as Set

41−import Data.Text (Text)

44+import Data.Text (Text)

42−import qualified Data.Text as T

45+import qualified Data.Text as T

43−import qualified Data.Text.Encoding as E

46+import qualified Data.Text.Encoding as E

44−import GHC.TypeLits (KnownSymbol, symbolVal)

47+import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

46− BasicAuthData, BuildHeadersTo (..),

49+ BasicAuthData, BuildHeadersTo (..),

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

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

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

51+ HttpVersion, IsSecure,

52+ MimeRender (..), MimeUnrender,

49− MimeUnrender, NoContent, QueryFlag,

53+ NoContent, QueryFlag, QueryParam,

50− QueryParam, QueryParams, Raw,

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

51− ReflectMethod (..), RemoteHost,

55+ RemoteHost, ReqBody,

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

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

53− Verb, contentType)

57+ contentType)

54−

58+import Servant.API.Description (Summary)

59+

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

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

56− XhrRequest (..),

61+ XhrRequest (..),

57− XhrResponseHeaders (..),

62+ XhrResponseHeaders (..),

58− attachPromptlyDynWith, constDyn)

63+ attachPromptlyDynWith, constDyn)

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

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

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

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

61 SupportsServantReflex)

66 SupportsServantReflex)

67+import Servant.Common.Req (ClientOptions,

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

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

63 ReqResult (..), addHeader, authData,

69 ReqResult (..), addHeader, authData,

70+ defReq,

71+ defaultClientOptions,

64− defReq, performRequestsCT,

72+ performRequestsCT,

65 performRequestsNoBody,

73 performRequestsNoBody,

66 performSomeRequestsAsync,

74 performSomeRequestsAsync,

67 prependToPathParts, qParamToQueryPart,

75 prependToPathParts, qParamToQueryPart,

68 qParams, reqBody, reqFailure,

76 qParams, reqBody, reqFailure,

69 reqMethod, reqSuccess, reqSuccess',

77 reqMethod, reqSuccess, reqSuccess',

70− respHeaders, response)

78+ respHeaders, response, withCredentials)

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

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

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

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

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

78clientA p q f tag baseurl =

86clientA p q f tag baseurl =

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

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

88+ defaultClientOptions

89+

91+-- | A version of @client@ that sets the withCredentials flag

92+-- on requests. Use this function for clients of CORS API's

93+clientWithOptsA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)

94+ => Proxy layout -> Proxy m -> Proxy f -> Proxy tag

95+ -> Dynamic t BaseUrl -> ClientOptions -> ClientMulti t m layout f tag

96+clientWithOptsA p q f tag baseurl opts =

97+ clientWithRouteMulti p q f tag

98+ (constDyn (pure defReq)) baseurl opts

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

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

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

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

84 type ClientMulti t m layout f tag :: *

102 type ClientMulti t m layout f tag :: *

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

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

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

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

87− -> ClientMulti t m layout f tag

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

106

107

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

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

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

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

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

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

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

94 ClientMulti t m b f tag

112 ClientMulti t m b f tag

95− clientWithRouteMulti Proxy q f tag reqs baseurl =

113+ clientWithRouteMulti Proxy q f tag reqs baseurl opts =

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

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

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

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

116

117

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

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

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

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

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

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

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

109

127

110− clientWithRouteMulti _ q f tag reqs baseurl vals =

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

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

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

112 where

130 where

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

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

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

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

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

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

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

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

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

130

148

131− clientWithRouteMulti _ _ _ _ reqs baseurl =

149+ clientWithRouteMulti _ _ _ _ reqs baseurl opts =

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

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

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

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

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

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

135

153

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

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

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

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

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

145 -- ExceptT ServantError IO NoContent

163 -- ExceptT ServantError IO NoContent

146− clientWithRouteMulti Proxy _ _ _ req baseurl =

164+ clientWithRouteMulti Proxy _ _ _ req baseurl opts =

147− performRequestsNoBody method req baseurl

165+ performRequestsNoBody method req baseurl opts

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

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

149

167

150

168

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

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

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

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

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

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

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

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

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

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

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

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

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

164 return $ fmap toHeaders <$> resp

182 return $ fmap toHeaders <$> resp

165 where

183 where

166 reqs' = fmap (\r ->

184 reqs' = fmap (\r ->

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

181 cts (Headers ls NoContent)) f tag where

199 cts (Headers ls NoContent)) f tag where

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

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

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

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

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

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

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

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

186− resp <- performRequestsNoBody method reqs' baseurl triggers

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

187 return $ fmap toHeaders <$> resp

205 return $ fmap toHeaders <$> resp

188 where reqs' = fmap (\req ->

206 where reqs' = fmap (\req ->

189 req {respHeaders = OnlyHeaders (Set.fromList

207 req {respHeaders = OnlyHeaders (Set.fromList

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

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

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

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

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

205

223

206− clientWithRouteMulti Proxy f q tag reqs baseurl eVals =

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

207 clientWithRouteMulti (Proxy :: Proxy sublayout) f

225 clientWithRouteMulti (Proxy :: Proxy sublayout) f

208 q tag

226 q tag

209 reqs'

227 reqs'

210− baseurl

228+ baseurl opts

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

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

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

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

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

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

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

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

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

225

243

226

244

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

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

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

248+

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

250+ ClientMulti t m sublayout f tag

251+

252+ clientWithRouteMulti Proxy q f tag =

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

254+

255+

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

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

228instance (KnownSymbol sym,

257instance (KnownSymbol sym,

229 ToHttpApiData a,

258 ToHttpApiData a,

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

237

266

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

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

239 -- TODO: Check the above comment

268 -- TODO: Check the above comment

240− clientWithRouteMulti Proxy q f tag reqs baseurl mparams =

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

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

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

242− reqs' baseurl

271+ reqs' baseurl opts

243

272

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

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

245 p prm = QueryPartParam $ fmap qParamToQueryPart prm

274 p prm = QueryPartParam $ fmap qParamToQueryPart prm

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

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

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

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

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

262

291

263− clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =

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

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

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

265

294

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

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

267 pname = symbolVal (Proxy :: Proxy sym)

296 pname = symbolVal (Proxy :: Proxy sym)

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

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

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

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

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

281

310

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

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

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

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

284

313

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

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

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

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

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

294 -> Event t tag

323 -> Event t tag

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

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

296

325

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

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

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

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

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

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

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

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

301 return resps

330 return resps

302 where

331 where

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

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

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

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

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

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

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

315

344

316− clientWithRouteMulti Proxy q f tag reqs baseurl bodies =

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

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

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

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

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

319 ctProxy = Proxy :: Proxy ct

348 ctProxy = Proxy :: Proxy ct

320 ctString = T.pack $ show $ contentType ctProxy

349 ctString = T.pack $ show $ contentType ctProxy

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

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

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

366 -> ClientMulti t m api f tag

395 -> ClientMulti t m api f tag

367

396

368− clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =

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

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

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

370 where

399 where

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

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

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

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

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

@@ -9,6 +9,7 @@ import qualified Data.Text as T

9import Data.Foldable

10import Test.WebDriver.Commands.Wait

11import Test.Hspec.WebDriver

12+import Test.Hspec.WebDriver (chromeCaps)

14clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()

15clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()

@@ -28,7 +29,7 @@ spec :: Spec

28spec = do

29spec = do

29 describe "servant-reflex tests" $ do

30 describe "servant-reflex tests" $ do

31− session "test page" $ using Chrome $ do

32+ session "test page" $ using [chromeCaps] $ do

33 it "opens the page" $ runWD $

34 it "opens the page" $ runWD $

34 openPage "http://localhost:8000"

35 openPage "http://localhost:8000"

testserver/API.hsmode 120000 → 100644+69−1

@@ -1 +0,0 @@

1−../exec/API.hs

@@ -0,0 +1,69 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeOperators #-}

5+module API where

7+import Data.Aeson

8+import Data.Aeson.Types (typeMismatch)

9+import Data.Text (Text)

10+import Servant.API

11+

12+newtype Question = Question { unQuestion :: Text } deriving (Show)

13+

14+instance ToJSON Question where

15+ toJSON (Question txt) = object ["question" .= txt]

16+

17+instance FromJSON Question where

18+ parseJSON (Object v) = Question <$> v .: "question"

19+ parseJSON x = typeMismatch "Couldn't find key 'question'" x

20+

21+newtype Answer = Answer { unAnswer :: Text } deriving (Show)

22+

23+instance ToJSON Answer where

24+ toJSON (Answer txt) = object ["answer" .= txt]

25+

26+instance FromJSON Answer where

27+ parseJSON (Object v) = Answer <$> v .: "answer"

28+ parseJSON x = typeMismatch "Couldn't find key 'answer'" x

29+

30+

31+-- | API spec for server, client, and docs

32+type API = "getunit" :> Get '[JSON] ()

33+ :<|> "getint" :> Get '[JSON] Int

34+ :<|> "sayhi" :> QueryParam "username" Text

35+ :> QueryParams "greetings" Text

36+ :> QueryFlag "gusto"

37+ :> Get '[JSON] Text

38+ :<|> "double" :> ReqBody '[JSON] Double

39+ :> Post '[JSON] Double

40+ :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text

41+ :<|> "qna" :> ReqBody '[JSON] Question

42+ :> Post '[JSON] Answer

43+ :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int

44+ :<|> Raw

45+

46+type GET = Get '[JSON] ()

47+

48+-- Imported the comprehensive API example for testing.

49+-- https://github.com/haskell-servant/servant/blob/master/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs

50+type ComprehensiveAPI =

51+ GET :<|>

52+ Get '[JSON] Int :<|>

53+ Capture "foo" Int :> GET :<|>

54+ Header "foo" Int :> GET :<|>

55+ HttpVersion :> GET :<|>

56+ IsSecure :> GET :<|>

57+ QueryParam "foo" Int :> GET :<|>

58+ QueryParams "foo" Int :> GET :<|>

59+ QueryFlag "foo" :> GET :<|>

60+-- Raw :<|>

61+ RemoteHost :> GET :<|>

62+ ReqBody '[JSON] Int :> GET :<|>

63+ Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>

64+ "foo" :> GET :<|>

65+ Vault :> GET :<|>

66+ Verb 'POST 204 '[JSON] () :<|>

67+ Verb 'POST 204 '[JSON] Int

68+-- This one isn't in scope

69+-- :<|> WithNamedContext "foo" '[] GET

testserver/Main.hs+20−5

@@ -2,14 +2,17 @@

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE TypeApplications #-}

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeOperators #-}

8import Control.Monad.IO.Class (liftIO)

9import Control.Monad.IO.Class (liftIO)

10+import Control.Monad.Reader (reader)

9import Data.Aeson

11import Data.Aeson

10import Data.Bool

12import Data.Bool

11import Data.Char (toUpper)

13import Data.Char (toUpper)

12import qualified Data.List as L

14import qualified Data.List as L

15+import Data.Maybe (fromMaybe)

13import Data.Monoid

16import Data.Monoid

14import Data.Proxy

17import Data.Proxy

15import Data.Text hiding (head, length, map,

18import Data.Text hiding (head, length, map,

@@ -24,6 +27,7 @@ import Snap.Http.Server

24import Servant

27import Servant

25import Servant.Server

28import Servant.Server

26-- import Snap.Util.FileServe

29-- import Snap.Util.FileServe

30+import System.Environment (lookupEnv)

27import API

31import API

28import Snap

32import Snap

@@ -39,7 +43,7 @@ instance ToJSON Greet

39testApi :: Proxy API

43testApi :: Proxy API

40testApi = Proxy

44testApi = Proxy

42−data App = App

46+data App = App { appStaticDir :: String }

44-- Server-side handlers.

48-- Server-side handlers.

45--

49--

@@ -47,8 +51,10 @@ data App = App

47-- that represents the API, are glued together using :<|>.

51-- that represents the API, are glued together using :<|>.

48--

52--

49-- Each handler runs in the 'ExceptT ServantErr IO' monad.

53-- Each handler runs in the 'ExceptT ServantErr IO' monad.

50−server :: Server API (Handler App App)

54+server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)

55+server = return () :<|> return 100 :<|> sayhi :<|> dbl

56+ :<|> multi :<|> qna :<|> serveSecret

57+ :<|> statics

52 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text

58 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text

53 sayhi nm greetings withGusto = case nm of

59 sayhi nm greetings withGusto = case nm of

54 Nothing -> return ("Sorry, who are you?" :: Text)

60 Nothing -> return ("Sorry, who are you?" :: Text)

@@ -69,18 +75,27 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|>

69 putStrLn $ "qna got: " ++ show q

75 putStrLn $ "qna got: " ++ show q

70 T.putStrLn $ unQuestion q

76 T.putStrLn $ unQuestion q

71 return $ Answer $ unQuestion q

77 return $ Answer $ unQuestion q

78+ serveSecret _ = do

79+ req <- getRequest

80+ liftIO $ putStrLn (show req)

81+ return 101

82+ statics = do

83+ staticDir <- reader appStaticDir

84+ serveDirectory staticDir

73-- Turn the server into a WAI app. 'serve' is provided by servant,

86-- Turn the server into a WAI app. 'serve' is provided by servant,

74-- more precisely by the Servant.Server module.

87-- more precisely by the Servant.Server module.

75test :: Handler App App ()

88test :: Handler App App ()

76−test = serveSnap testApi server

89+test = serveSnapWithContext testApi

90+ (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server

78initApp :: SnapletInit App App

92initApp :: SnapletInit App App

79initApp = makeSnaplet "myapp" "example" Nothing $ do

93initApp = makeSnaplet "myapp" "example" Nothing $ do

94+ staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")

80 addRoutes [("", test)

95 addRoutes [("", test)

81 ,("", serveDirectory "static")

96 ,("", serveDirectory "static")

82 ]

97 ]

83− return App

98+ return (App staticDir)

85-- Put this all to work!

100-- Put this all to work!

86main :: IO ()

101main :: IO ()

testserver/run-wd-tests.shdeleted−5

@@ -1,5 +0,0 @@

1−#!/usr/bin/env bash

2−

3−dist/build/back/back -p 8000 &

4−phantomjs --webdriver=127.0.0.1:4444 &

5−dist/build/spec/spec

testserver/testserver.cabal+8−7

@@ -19,13 +19,14 @@ executable back

19 main-is: Main.hs

20 -- other-modules:

21 -- other-extensions:

22− build-depends: aeson >= 0.9 && < 1.1

22+ build-depends: aeson >= 0.9 && < 1.5

23− , base >=4.8 && <4.10

23+ , base >=4.8 && < 5

24+ , mtl

24− , snap >= 1.0 && < 1.1

25+ , snap >= 1.0 && < 1.2

25− , snap-server >= 1.0 && < 1.1

26+ , snap-server >= 1.0 && < 1.2

26 , snap-core >= 1.0 && < 1.1

27 , snap-core >= 1.0 && < 1.1

27− , servant >= 0.8 && < 0.11

28+ , servant >= 0.16 && < 0.18

28− , servant-snap >= 0.7.2 && < 0.8

29+ , servant-snap >= 0.8 && < 0.9

29− , text >= 1.2 && < 1.3

30+ , text >= 1.0 && < 1.3

30 -- hs-source-dirs:

31 -- hs-source-dirs:

31 default-language: Haskell2010

32 default-language: Haskell2010

testserver/tr.nixdeleted−32

@@ -1,32 +0,0 @@

1−{ reflex-platform, ... }:

2−let

3−

4− dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;

5− cabal2nixResult = reflex-platform.cabal2nixResult;

6− nixpkgs = (import <nixpkgs> {});

7−in

8−reflex-platform.ghc.override {

9− overrides = self: super: {

10− servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});

11− snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap) {});

12− io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});

13− io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});

14− heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});

15− xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});

16− snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});

17− snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});

18− snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});

19− snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});

20− hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});

21−

22− # servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});

23− # servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});

24− # servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});

25− # servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});

26− # servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});

27− # servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});

28− # servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});

29− # servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});

30−

31− };

32−}

travis.nixnew file+70

@@ -0,0 +1,70 @@

1+{

2+ nativeCompiler ? "ghc",

3+ # ^ Choose a GHC for compiling backend components (web server, selenium)

4+ # (ghc, ghc8_0, ghc8_2, ghc8_4 or ghcHEAD)

6+ jsCompiler ? "ghcjs"

7+ # ^ Choose a GHCJS for compiling the frontend

8+ # (ghcjs, ghcjs8_0, ghcjs8_2 or ghcjs8_4)

10+}:

11+

12+let

13+

14+ reflexPlatform = import ./nix/reflex-platform.nix;

15+

16+ lib = reflexPlatform.nixpkgs.haskell.lib;

17+ do = funs: pkg: builtins.foldl' (a: b: b a) pkg funs;

18+

19+ ghcjsPkgs = with lib; reflexPlatform.${jsCompiler}.override {

20+ overrides = self: super: {

21+ http-media = dontCheck super.http-media;

22+ servant = dontCheck super.servant;

23+ lens-aeson = dontCheck super.lens-aeson;

24+ servant-reflex = lib.appendConfigureFlag

25+ (self.callPackage ./default.nix {}) "-fExample";

26+ };

27+ };

28+

29+ ghcPkgs = with lib; reflexPlatform.${nativeCompiler}.override {

30+ overrides = self: super: {

31+ servant-snap = dontCheck ((import ./nix/servant-snap.nix {}) self super);

32+ testdriver = self.callCabal2nix "testdriver" ./testdriver {};

33+ testserver = import nix/testserver.nix ghcjsPkgs.servant-reflex self super;

34+ servant-reflex = self.callPackage ./default.nix {};

35+ };

36+ };

37+

38+ testresults = import ./nix/testresults.nix

39+ { inherit reflexPlatform;

40+ inherit (ghcPkgs) testserver testdriver;

41+ inherit (reflexPlatform.nixpkgs) curl;

42+ phantomjs = reflexPlatform.nixpkgs.phantomjs2;

43+ };

44+

45+in

46+ rec {

47+

48+ inherit reflexPlatform ghcPkgs ghcjsPkgs;

49+

50+ build = ghcjsPkgs.servant-reflex;

51+ buildGhc = ghcPkgs.servant-reflex;

52+ testserver = ghcPkgs.testserver;

53+ testdriver = ghcPkgs.testdriver;

54+ inherit testresults;

55+

56+ cabalBuild = reflexPlatform.${jsCompiler}.shellFor {

57+ name = "servant-reflex-cabal-builder";

58+

59+ packages = p: [

60+ build

61+ ];

62+

63+ shellHook = ''

64+ cabal configure --ghcjs -f Example

65+ cabal build

66+ exec/toSite.sh

67+ exit $?

68+ '';

69+ };

70+ }