6636bc2...master · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

on master help sign in

.gitignore+3−1

since splitsnapshots

unifiedsplit

@@ -6,4 +6,6 @@ log

6*.webapp

7*.stats

8out

9−reflex-platform

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 ghc ./testdriver --command "cd testdriver && cabal configure && cabal build"

41− - reflex-platform/work-on ./overrides-ghc.nix ./testserver --command "cd testserver && 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+114−28

@@ -2,16 +2,21 @@

3[![Build Status](https://travis-ci.org/imalsogreg/servant-reflex.svg?branch=master)](https://travis-ci.org/imalsogreg/servant-reflex)

5−## The problem `servant-reflex` solves

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

6−

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

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

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.

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

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

@@ -33,16 +39,26 @@ type API = "getint" :> Get '[JSON] Int

33 -- servant-reflex computes FRP functions for each API endpoint

39 -- servant-reflex computes FRP functions for each API endpoint

34 let (getint :<|> sayhi :<|> doubleit :<|> _) = client (Proxy :: Proxy API)

40 let (getint :<|> sayhi :<|> doubleit :<|> _) = client (Proxy :: Proxy API)

35 (Proxy :: Proxy m)

41 (Proxy :: Proxy m)

42+ (Proxy :: Proxy ())

36 (constDyn (BasePath "/"))

43 (constDyn (BasePath "/"))

37```

44```

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

41```haskell

57```haskell

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

43 getint :: MonadWidget t m

59 getint :: MonadWidget t m

44 => Event t () -- ^ Trigger the XHR Request

60 => Event t () -- ^ Trigger the XHR Request

45− -> m (Event t (ReqResult Int)) -- ^ Consume the answer

61+ -> m (Event t (ReqResult () Int)) -- ^ Consume the answer

47 sayhi :: MonadWidget t m

63 sayhi :: MonadWidget t m

48 => Dynamic t (QParam Text)

64 => Dynamic t (QParam Text)

@@ -53,15 +69,21 @@ These client functions are computed from your API type. They manage serializatio

53 -- ^ Flag for capitalizing the response

69 -- ^ Flag for capitalizing the response

54 -> Event t ()

70 -> Event t ()

55 -- ^ Trigger the XHR Request

71 -- ^ Trigger the XHR Request

56− -> m (Event t (ReqResult Text))

72+ -> m (Event t (ReqResult () Text))

58 doubleit :: MonadWidget t m

74 doubleit :: MonadWidget t m

59 => Dynamic t (Either Text Double)

75 => Dynamic t (Either Text Double)

60 -> Event t ()

76 -> Event t ()

61− -> m (Event t (ReqResult Double))

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

62```

78```

80+`ReqResult tag a` is defined in

64−`ReqResult 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:

66```haskell

88```haskell

67 -- ... continued ...

89 -- ... continued ...

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

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

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

80```

102```

103

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

84```haskell

107```haskell

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

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

@@ -102,37 +125,100 @@ This example builds some input fields to enter API parameters, buttons to trigge

102 display =<< holdDyn Nothing outputDouble

125 display =<< holdDyn Nothing outputDouble

103```

126```

104

127

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

106

133

107

134

108## Building the library and test server

135## Building the library and test server

109

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

110−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).

111−

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

112−

143+manages the frontend build as a dependency.

113−First build the library:

114

144

115```

145```

116−git submodule update --init --recursive

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

117−./build.sh

118```

147```

119

148

120−Then build the test server:

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

121

150

122```

151```

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

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

124```

153```

125

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.

126

158

127−## Running the example site

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

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

128

161

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

130

162

163+## Tagging requests

164+

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

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

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

168+relationship by tagging the requests.

169+

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:

175+

176+```haskell

177+ ...

178+ inp <- textInput def

179+

180+ -- Convert the raw text into an `Either Text Double`

181+ let inpNum = maybe (Left "No Parse") Right . readMaybe . T.unpack <$> value inp

182+ go <- button "Double It"

183+

184+ -- Call 'doubleIt' with triggers that coincide with good input parses

185+ rs <- doubleIt inpNum (fforMaybe (tagPromptlyDyn inpNum go) $ \case

186+ Left _ -> Nothing

187+ Right a -> Just a

188+ )

189+

190+ -- Accumulate good responses in a map

191+ doubleTable <- foldDyn (<>) mempty $ ffor rs $ \case

192+ ResponseSuccess tag v _ -> tag =: v

193+ _ -> mempty

194+

195+ el "table" $ do

196+ listWithKey doubleTable $ \k dv -> el "tr" $ do

197+ el "td" $ text (T.pack $ show k)

198+ el "td" $ dynText (T.pack . show <$> dv)

199+ ...

131```

200```

132−cd testserver

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

134−```

135

201

136−And simply browse to `localhost:8001`

202+## Simultaneous requests

203+

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:

208+

209+```haskell

210+sayHi

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

212+ -> Dynamic t (f [Text])

213+ -> Dynamic t (f Bool)

214+ -> Event t tag

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

216+```

137

217

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

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+48−21

@@ -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,11 +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

19+import GHC.TypeLits

17import Servant.API

20import Servant.API

18import API

21import API

19import Data.Proxy

22import Data.Proxy

20import Text.Read (readMaybe)

23import Text.Read (readMaybe)

21−import Reflex.Dom

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

25+import Reflex.Dom (mainWidget)

22------------------------------------------------------------------------------

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

23import Servant.Reflex

27import Servant.Reflex

24import Servant.Reflex.Multi

28import Servant.Reflex.Multi

@@ -42,17 +46,18 @@ runMulti :: forall t m. (SupportsServantReflex t m,

42runMulti = do

46runMulti = do

43 url <- baseUrlWidget

47 url <- baseUrlWidget

44 el "br" blank

48 el "br" blank

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

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

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

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

51+

47 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

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

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

49− -- dynText =<< holdDyn "waiting" (T.pack . show <$> num)

54+

50− -- numLabeled :: Event t (First Int, Double) <- zipListWithEvent (,) (First . Just <$> [0..]) num

51 b <- button "Run dbl multi"

55 b <- button "Run dbl multi"

52− reqCount <- count b

56+ reqCount :: Dynamic t Int <- count b

53 r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)

57 r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)

54− dynText =<< holdDyn "Waiting" (T.pack . show . fmapMaybe reqSuccess .snd <$> r)

58+ dynText =<< holdDyn "Waiting" (T.pack . show . fmap reqSuccess <$> r)

59+

55− lastInd <- holdDyn Nothing (Just . fst <$> r)

60+ lastInd <- holdDyn [] $ fmap reqTag <$> r

56 display lastInd

61 display lastInd

58 divClass "demo-group" $ do

63 divClass "demo-group" $ do

@@ -64,8 +69,13 @@ runMulti = do

64 textInput def

69 textInput def

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

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

66 b <- button "Go"

71 b <- button "Go"

67− 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+

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

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

76+ fmap reqSuccess <$> r')

77+

78+

69 return ()

79 return ()

71run :: forall t m. (SupportsServantReflex t m,

81run :: forall t m. (SupportsServantReflex t m,

@@ -87,21 +97,26 @@ run = mdo

87 el "br" (return ())

97 el "br" (return ())

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

91− client api (Proxy :: Proxy m) url

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

105+

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

107

93 (unitBtn, intBtn) <- elClass "div" "demo-group" $ do

108 (unitBtn, intBtn) <- elClass "div" "demo-group" $ do

94 unitBtn <- divClass "unit-button" $ button "Get unit"

109 unitBtn <- divClass "unit-button" $ button "Get unit"

95 intBtn <- divClass "int-button" $ button "Get int"

110 intBtn <- divClass "int-button" $ button "Get int"

111

97 unitResponse <- getUnit $ tag (current reqCount) unitBtn

112 unitResponse <- getUnit $ tag (current reqCount) unitBtn

98− intResponse :: Event t (Int, ReqResult Int) <- getInt $ tag (current reqCount) intBtn

113+ intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn

114

100− score <- foldDyn (+) 0 (fmapMaybe reqSuccess (snd <$> intResponse))

115+ score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))

101

116

102 r <- holdDyn "Waiting" $ fmap showXhrResponse $

117 r <- holdDyn "Waiting" $ fmap showXhrResponse $

103− leftmost [fmapMaybe response (snd <$> unitResponse)

118+ leftmost [fmapMaybe response (unitResponse)

104− ,fmapMaybe response (snd <$> intResponse)

119+ ,fmapMaybe response (intResponse)

105 ]

120 ]

106 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score

121 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score

107 return (unitBtn, intBtn)

122 return (unitBtn, intBtn)

@@ -129,8 +144,8 @@ run = mdo

129

144

130 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)

145 resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)

131 divClass "greeting-response" $ dynText =<<

146 divClass "greeting-response" $ dynText =<<

132− holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (snd <$> resp)

147+ holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)

133− , fmapMaybe reqFailure (snd <$> resp)])

148+ , fmapMaybe reqFailure (resp)])

134 return sayHiClicks

149 return sayHiClicks

135

150

136 dblBtn <- elClass "div" "demo-group" $ do

151 dblBtn <- elClass "div" "demo-group" $ do

@@ -141,11 +156,11 @@ run = mdo

141 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $

156 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $

142 dblinp) (tag (current reqCount) dblBtn)

157 dblinp) (tag (current reqCount) dblBtn)

143 divClass "double-errors" $ dynText =<<

158 divClass "double-errors" $ dynText =<<

144− holdDyn "(no errors)" (fmapMaybe reqFailure (snd <$> dblResp))

159+ holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))

145 el "br" (return ())

160 el "br" (return ())

146 divClass "double-result" $ el "p" $ dynText =<<

161 divClass "double-result" $ el "p" $ dynText =<<

147 holdDyn "No number yet" (fmap tShow $

162 holdDyn "No number yet" (fmap tShow $

148− fmapMaybe reqSuccess (snd <$> dblResp))

163+ fmapMaybe reqSuccess (dblResp))

149 return dblBtn

164 return dblBtn

150

165

151 mpGo <- elClass "div" "demo-group" $ do

166 mpGo <- elClass "div" "demo-group" $ do

@@ -155,7 +170,7 @@ run = mdo

155 multiResp <- multi b (tag (current reqCount) mpGo)

170 multiResp <- multi b (tag (current reqCount) mpGo)

156 dynText =<< holdDyn "No res yet" (fmap tShow $

171 dynText =<< holdDyn "No res yet" (fmap tShow $

157 fmapMaybe reqSuccess $

172 fmapMaybe reqSuccess $

158− (snd <$> multiResp))

173+ (multiResp))

159 return mpGo

174 return mpGo

160

175

161 return ()

176 return ()

@@ -165,12 +180,24 @@ run = mdo

165 elClass "div" "demo-group" $ do

180 elClass "div" "demo-group" $ do

166 text "JSON Unicode encoding test"

181 text "JSON Unicode encoding test"

167 txt <- value <$> textInput def

182 txt <- value <$> textInput def

168− ev <- button "Question"

183+ ev <- fmap (1 <$) $ button "Question"

169 let dQ = Right . Question <$> traceDyn "will send: " txt

184 let dQ = Right . Question <$> traceDyn "will send: " txt

170 rr <- qna dQ ev

185 rr <- qna dQ ev

171 el "p" $

186 el "p" $

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

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

173

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+

174showXhrResponse :: XhrResponse -> Text

201showXhrResponse :: XhrResponse -> Text

175showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

176 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+36−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

@@ -11,42 +11,59 @@ Category: Web

11Build-type: Simple

12Cabal-version: >=1.10

14+Flag Example

15+ description: Enable example

16+ default: False

17+

14library

18library

15 exposed-modules:

19 exposed-modules:

16− Servant.Reflex

17− Servant.Reflex.Multi

18−

19− other-modules:

20 Servant.Common.BaseUrl

21 Servant.Common.Req

22+ Servant.Reflex

23+ Servant.Reflex.Multi

23 hs-source-dirs: src

25 hs-source-dirs: src

24 build-depends:

26 build-depends:

25− base >= 4.8 && < 4.10,

27+ base >= 4.8 && < 5,

26 bytestring >= 0.10 && < 0.11,

28 bytestring >= 0.10 && < 0.11,

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

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

28− containers >= 0.5.6 && < 0.6,

30+ containers >= 0.5.6 && < 0.7,

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

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

30− exceptions >= 0.8 && < 0.9,

32+ exceptions >= 0.8 && < 0.11,

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

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

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

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

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

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

36+ jsaddle >= 0.8 && < 0.10,

34 mtl >= 2.2.1 && < 2.3,

37 mtl >= 2.2.1 && < 2.3,

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

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

36− reflex >= 0.5 && < 0.6,

39+ reflex >= 0.5 && < 0.9,

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

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

38 safe >= 0.3.9 && < 0.4,

41 safe >= 0.3.9 && < 0.4,

39− servant >= 0.8 && < 0.11,

42+ servant >= 0.16 && < 0.19,

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

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

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

41 text >= 1.2 && < 1.3,

45 text >= 1.2 && < 1.3,

42 transformers >= 0.4 && < 0.6

46 transformers >= 0.4 && < 0.6

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

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

46 default-language: Haskell2010

50 default-language: Haskell2010

48executable example

52executable example

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

53+ if flag(Example)

54+ buildable: True

55+ else

56+ buildable: False

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

50 default-language: Haskell2010

67 default-language: Haskell2010

51 main-is: Example.hs

68 main-is: Example.hs

52 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+115−98

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

@@ -76,13 +108,12 @@ response (ResponseSuccess _ _ x) = Just x

76response (ResponseFailure _ _ x) = Just x

108response (ResponseFailure _ _ x) = Just x

77response _ = Nothing

109response _ = Nothing

110

79−

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

111------------------------------------------------------------------------------

112+-- | Retrieve response tag

81−instance Functor (ReqResult tag) where

113+reqTag :: ReqResult tag a -> tag

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

114+reqTag (ResponseSuccess tag _ _) = tag

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

115+reqTag (ResponseFailure tag _ _) = tag

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

116+reqTag (RequestFailure tag _ ) = tag

85−

117

87-------------------------------------------------------------------------------

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

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

@@ -136,7 +167,7 @@ reqToReflexRequest

136 => Text

167 => Text

137 -> Dynamic t BaseUrl

168 -> Dynamic t BaseUrl

138 -> Req t

169 -> Req t

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

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

140reqToReflexRequest reqMeth reqHost req =

171reqToReflexRequest reqMeth reqHost req =

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

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

142 t = sequence $ reverse $ reqPathParts req

173 t = sequence $ reverse $ reqPathParts req

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

148 urlParts = fmap sequence t

179 urlParts = fmap sequence t

149

180

150 urlPath :: Dynamic t (Either Text Text)

181 urlPath :: Dynamic t (Either Text Text)

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

182+ urlPath = (fmap.fmap)

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

184+ urlParts

152

185

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

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

154 queryPartString (pName, qp) = case qp of

187 queryPartString (pName, qp) = case qp of

155 QueryPartParam p -> ffor p $ \case

188 QueryPartParam p -> ffor p $ \case

156 Left e -> Just (Left e)

189 Left e -> Just (Left e)

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

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

158 Right Nothing -> Nothing

191 Right Nothing -> Nothing

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

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

160 if null pStrings

193 if null pStrings

161 then Nothing

194 then Nothing

195+ else Just . Right

196+ . T.intercalate "&"

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

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

163 QueryPartFlag fl -> ffor fl $ \case

198 QueryPartFlag fl -> ffor fl $ \case

164 True -> Just $ Right pName

199 True -> Just $ Right pName

165 False -> Nothing

200 False -> Nothing

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

194 Right $ XhrRequestConfig

229 Right $ XhrRequestConfig

195 { _xhrRequestConfig_sendData = bytesToPayload bBytes

230 { _xhrRequestConfig_sendData = bytesToPayload bBytes

196 , _xhrRequestConfig_headers =

231 , _xhrRequestConfig_headers =

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

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

198 , _xhrRequestConfig_user = Nothing

233 , _xhrRequestConfig_user = Nothing

199 , _xhrRequestConfig_password = Nothing

234 , _xhrRequestConfig_password = Nothing

200− , _xhrRequestConfig_responseType = Nothing

235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

201 , _xhrRequestConfig_withCredentials = False

236 , _xhrRequestConfig_withCredentials = False

202 , _xhrRequestConfig_responseHeaders = def

237 , _xhrRequestConfig_responseHeaders = def

203 }

238 }

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

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

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

210 , _xhrRequestConfig_user = Nothing

245 , _xhrRequestConfig_user = Nothing

211 , _xhrRequestConfig_password = Nothing

246 , _xhrRequestConfig_password = Nothing

212− , _xhrRequestConfig_responseType = Nothing

247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

213− , _xhrRequestConfig_sendData = ""

248+ , _xhrRequestConfig_sendData = mempty

214 , _xhrRequestConfig_withCredentials = False

249 , _xhrRequestConfig_withCredentials = False

215 }

250 }

216 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

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

237displayHttpRequest :: Text -> Text

272displayHttpRequest :: Text -> Text

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

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

239

274

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

275+-- | This function performs the request

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

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

242 => Text

277 => Text

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

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

244 -> Dynamic t BaseUrl

279 -> Dynamic t BaseUrl

280+ -> ClientOptions

245 -> Event t tag

281 -> Event t tag

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

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

247−performRequests reqMeth rs reqHost trigger = do

283+performRequests reqMeth rs reqHost opts trigger = do

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

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

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

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

291+

251− resps <- performSomeRequestsAsync reqs

292+ resps <- performSomeRequestsAsync opts reqs

252 return $ getCompose <$> resps

293 return $ getCompose <$> resps

253

294

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

255performSomeRequestsAsync

298performSomeRequestsAsync

256 :: (MonadIO (Performable m),

299 :: (MonadIO (Performable m),

300+ MonadJSM (Performable m),

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

257 HasWebView (Performable m),

302 HasWebView (Performable m),

303+#endif

258 PerformEvent t m,

304 PerformEvent t m,

259 TriggerEvent t m,

305 TriggerEvent t m,

260 Traversable f,

306 Traversable f,

261− IsXhrPayload a)

307+ IsXhrPayload a,

308+ Show a

309+ )

310+ => ClientOptions

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

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

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

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

313+performSomeRequestsAsync opts =

264−performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return

314+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

265

315

266

316

267------------------------------------------------------------------------------

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

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

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

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

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

270performSomeRequestsAsync'

320performSomeRequestsAsync'

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

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

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

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

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

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

275 rs <- hrs

326 rs <- hrs

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

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

277 Left e -> do

328 Left e -> do

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

279 return resp

330 return resp

280 Right r' -> do

331 Right r' -> do

281 resp <- liftIO newEmptyMVar

332 resp <- liftIO newEmptyMVar

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

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

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

283 return resp

335 return resp

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

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

285 return ()

337 return ()

286

338

287

339

288

340

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

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

291− => Text

292− -> (Req t)

293− -> Dynamic t BaseUrl

294− -> Event t tag

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

296−performRequest reqMeth req reqHost trigger = do

297−

298− let xhrReq = reqToReflexRequest reqMeth reqHost req

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

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

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

302−

303− resps <- performRequestsAsync okReqs

304−

305− return (resps, badReqs)

306−

307−

308−type XhrPayload = T.Text

341+type XhrPayload = ByteString

309bytesToPayload :: BL.ByteString -> XhrPayload

342bytesToPayload :: BL.ByteString -> XhrPayload

310−bytesToPayload = TE.decodeUtf8 . BL.toStrict

343+bytesToPayload = BL.toStrict

311−

312−

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

314−-- => Text

315−-- -> Req t

316−-- -> Dynamic t BaseUrl

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

318−-- performRequestNoBody reqMeth req reqHost trigger = do

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

320−-- let decodeResp = const $ Right NoContent

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

322−-- , fmap (uncurry RequestFailure) badReq

323−-- ]

324−

325−

326−-- performRequestCT

327−-- :: (SupportsServantReflex t m,

328−-- MimeUnrender ct a)

329−-- => Proxy ct

330−-- -> Text

331−-- -> Req t

332−-- -> Dynamic t BaseUrl

333−-- -> Event t tag

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

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

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

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

338−-- mimeUnrender ct .

339−-- BL.fromStrict .

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

341−-- (_xhrResponse_responseText x)

342−

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

344−-- , fmap (uncurry RequestFailure) badReq

345−-- ]

346

344

347

345

348performRequestsCT

346performRequestsCT

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

352 -> Text

350 -> Text

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

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

354 -> Dynamic t BaseUrl

352 -> Dynamic t BaseUrl

353+ -> ClientOptions

355 -> Event t tag

354 -> Event t tag

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

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

357−performRequestsCT ct reqMeth reqs reqHost trigger = do

356+performRequestsCT ct reqMeth reqs reqHost opts trigger = do

358− resps <- performRequests reqMeth reqs reqHost trigger

357+ resps <- performRequests reqMeth reqs reqHost opts trigger

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

359− let decodeResp x = first T.pack .

359+ first T.pack .

360− mimeUnrender ct .

360+ mimeUnrender ct $

361− BL.fromStrict .

361+ BL.fromStrict x

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

362+ decodeResp _ = Left "No body"

363− (_xhrResponse_responseText x)

364 return $ fmap

363 return $ fmap

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

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

366 Left e -> RequestFailure t e

365 Left e -> RequestFailure t e

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

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

368 )

367 )

369 resps

368 resps

370

369

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

375 => Text

374 => Text

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

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

377 -> Dynamic t BaseUrl

376 -> Dynamic t BaseUrl

377+ -> ClientOptions

378 -> Event t tag

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

380−performRequestsNoBody reqMeth reqs reqHost trigger = do

380+performRequestsNoBody reqMeth reqs reqHost opts trigger = do

381− resps <- performRequests reqMeth reqs reqHost trigger

381+ resps <- performRequests reqMeth reqs reqHost opts trigger

382 let decodeResp = const $ Right NoContent

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

384 Left e -> RequestFailure tag e

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

391 -> (tag, XhrResponse)

392 -> ReqResult tag a

393evalResponse decode (tag, xhr) =

394− let okStatus = _xhrResponse_status xhr < 400

394+ let status = _xhrResponse_status xhr

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

395 errMsg = fromMaybe

396 errMsg = fromMaybe

396 ("Empty response with error code " <>

397 ("Empty response with error code " <>

397 T.pack (show $ _xhrResponse_status xhr))

398 T.pack (show $ _xhrResponse_status xhr))

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

404 else ResponseFailure tag errMsg xhr

405 else ResponseFailure tag errMsg xhr

405 in respPayld

406 in respPayld

406

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

407

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'

408

419

409

420

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

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

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

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

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

414fmapL _ (Right a) = Right a

425fmapL _ (Right a) = Right a

415fmapL 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+206−107

@@ -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,8 +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,

90+ reqTag,

79− qParams)

91+ qParams, withCredentials)

82-- * Accessing APIs as a Client

94-- * Accessing APIs as a Client

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

91-- >

103-- >

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

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

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

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

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

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

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

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

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

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

109+client

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

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

125+ -> Client t m layout tag

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

100

141

101

142

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

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

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

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

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

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

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

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

106 type Client t m layout tag :: *

147 type Client t m layout tag :: *

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

108

167

109

168

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

111 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

112

171

113− clientWithRoute Proxy q pTag req baseurl =

172+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =

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

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

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

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

116

175

117

176

118-- Capture. Example:

177-- Capture. Example:

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

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

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

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

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

135

194

136− clientWithRoute Proxy q t req baseurl val =

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

137− clientWithRoute (Proxy :: Proxy sublayout)

196+ clientWithRouteAndResultHandler

138− q t

139− (prependToPathParts p req)

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

140− baseurl

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

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

142

199

143

200

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

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

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

151 -- TODO how to access input types here?

208 -- TODO how to access input types here?

152 -- ExceptT ServantError IO a

209 -- ExceptT ServantError IO a

153− clientWithRoute Proxy _ _ req baseurl trigs =

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

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

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

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

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

157 req' = req { reqMethod = method }

213 req' = req { reqMethod = method }

158

214

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

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

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

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

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

167 -- ExceptT ServantError IO NoContent

223 -- ExceptT ServantError IO NoContent

168− clientWithRoute Proxy _ _ req baseurl =

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

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

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

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

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

171

227

172

228

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

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

174toHeaders r =

230toHeaders r =

175− let toBS = E.encodeUtf8

176− hdrs = maybe []

231+ let hdrs = maybe []

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

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

178 (Map.toList $ _xhrResponse_headers xhr))

233 (Map.toList $ _xhrResponse_headers xhr))

179 (response r)

234 (response r)

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

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

181

236

237+

182class BuildHeaderKeysTo hs where

238class BuildHeaderKeysTo hs where

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

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

184

240

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

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

186 where buildHeaderKeysTo _ = []

242 where buildHeaderKeysTo _ = []

187

243

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

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

189− => 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))

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

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

250+

191

251

192-- HEADERS Verb (Content) --

252-- HEADERS Verb (Content) --

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

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

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

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

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

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

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

205− clientWithRoute Proxy _ _ req baseurl trigs = do

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

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

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

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

208− return $ toHeaders <$> resp

268+ wrap $ toHeaders <$> resp

209 where req' = req { respHeaders =

269 where req' = req { respHeaders =

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

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

211 }

271 }

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

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

219 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

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

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

221− clientWithRoute Proxy _ _ req baseurl trigs = do

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

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

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

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

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

224− return $ toHeaders <$> resp

284+ wrap $ toHeaders <$> resp

225 where req' = req {respHeaders =

285 where req' = req {respHeaders =

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

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

227 }

287 }

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

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

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

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

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

250

310

251− clientWithRoute Proxy q t req baseurl eVal =

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

312+ clientWithRouteAndResultHandler

252− clientWithRoute (Proxy :: Proxy sublayout)

313+ (Proxy :: Proxy sublayout) q t

253− q t

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

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

255− baseurl

315+ baseurl opts wrap

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

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

257

317

258

318

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

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

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

267 Client t m sublayout tag

327 Client t m sublayout tag

268

328

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

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

341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

342+

343+

271

344

272

345

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

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

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

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

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

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

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

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

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

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

301

374

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

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

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

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

304

377

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

306− clientWithRoute Proxy q t req baseurl mparam =

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

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

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

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

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

309

382

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

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

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

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

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

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

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

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

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

351

424

352− clientWithRoute Proxy q t req baseurl paramlist =

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

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

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

354

427

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

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

356 pname = symbolVal (Proxy :: Proxy sym)

429 pname = symbolVal (Proxy :: Proxy sym)

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

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

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

390 Dynamic t Bool -> Client t m sublayout tag

463 Dynamic t Bool -> Client t m sublayout tag

391

464

392− clientWithRoute Proxy q t req baseurl flag =

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

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

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

394

467

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

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

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

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

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

404 -> Event t tag

477 -> Event t tag

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

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

406

479

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

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

408

481

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

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

410 Left e -> Left e

483 Left e -> Left e

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

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

416

489

417 resps <- performRequestsAsync okReq

490 resps <- performRequestsAsync okReq

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

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

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

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

420 ]

493 ]

421

494

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

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

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

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

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

448

521

449− clientWithRoute Proxy q t req baseurl body =

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

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

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

451 where req' = req { reqBody = bodyBytesCT }

524 where req' = req { reqBody = bodyBytesCT }

452 ctProxy = Proxy :: Proxy ct

525 ctProxy = Proxy :: Proxy ct

453 ctString = T.pack $ show $ contentType ctProxy

526 ctString = T.pack $ show $ contentType ctProxy

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

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

462 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

463

536

464− clientWithRoute Proxy q t req baseurl =

537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =

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

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

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

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

467

540

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

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

469

542

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

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

472 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

473

546

474− clientWithRoute Proxy q t req baseurl =

547+ clientWithRouteAndResultHandler Proxy =

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

548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

476

549

477

550

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

479 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

480

553

481− clientWithRoute Proxy q t req baseurl =

554+ clientWithRouteAndResultHandler Proxy =

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

555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

483

556

484

557

485

558

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

487 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

488

561

489− clientWithRoute Proxy q t req baseurl =

562+ clientWithRouteAndResultHandler Proxy =

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

563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

491

564

492

565

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

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

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

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

497 -> Client t m api tag

570 -> Client t m api tag

498

571

499− clientWithRoute Proxy q t req baseurl authdata =

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

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

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

501 where

574 where

502 req' = req { authData = Just authdata }

575 req' = req { authData = Just authdata }

503

576

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

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

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

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

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

525-}

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

stack.yamlnew file+56

@@ -0,0 +1,56 @@

1+flags: {}

2+extra-package-dbs: []

3+packages:

4+- '.'

6+- location:

7+ git: https://github.com/reflex-frp/reflex

8+ commit: d78ba4318c425ca9b942dc387d7c5c7ab2d2e095

9+ extra-dep: true

10+

11+- location:

12+ git: https://github.com/mokus0/dependent-sum.git

13+ commit: bbc8ad3a81ea7f2b07ce7d036efd56f2e0f7c6ff

14+ extra-dep: true

15+

16+- location:

17+ git: https://github.com/gtk2hs/gtk2hs.git

18+ commit: 21d3a12a82756d04066e5e4198b35097012ee65b

19+ subdirs:

20+ - cairo

21+ - gio

22+ - glib

23+ - gtk

24+ - pango

25+ - tools

26+ extra-dep: true

27+

28+- location:

29+ git: https://github.com/byorgey/hashtables.git

30+ commit: 47d9ed261a5aba66a13d3c4da0e391d338b57fc5

31+ extra-dep: true

32+

33+- location:

34+ git: https://github.com/afcady/reflex-dom.git

35+ commit: 39b5ff23f3ae95d77c909ab3ed4bc4bd9e61f600

36+ extra-dep: true

37+

38+- location:

39+ git: https://github.com/afcady/dependent-sum-template.git

40+ commit: 68fc1a90580ea8f20775491cf651eefea422212a

41+ extra-dep: true

42+

43+extra-deps:

44+- cpphs-1.20.4

45+- directory-1.2.7.1

46+- ghcjs-dom-0.2.4.0

47+- haskell-src-exts-1.17.1

48+- haskell-src-meta-0.6.0.14

49+- hlint-1.9.35

50+- prim-uniq-0.1.0.1

51+- primitive-0.6.2.0

52+- ref-tf-0.4.0.1

53+- vector-0.12.0.0

54+- webkitgtk3-javascriptcore-0.13.2.0

55+- zenc-0.1.1

56+resolver: lts-8.3

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