master..6636bc2 · servant-reflex

git.iko.soy/servant-reflex

on 6636bc2 help sign in

.gitignore+1−3

since splitsnapshots

unifiedsplit

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

6*.webapp

7*.stats

8out

9−/.stack-work/

9+reflex-platform

10−TAGS

11−dist-newstyle

.gitmodules+15

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

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

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

1−language: nix

1+sudo: required

2−nix: 2.3.6

3−sudo: require

3+before_cache:

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

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

7+addons:

8+ apt:

9+ - phantomjs

10+

11+matrix:

12+ include:

13+ - env: CABALVER=1.24 GHCVER=7.10.3

14+ compiler: ": #GHC 7.10.3"

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

16+ - env: CABALVER=1.24 GHCVER=8.0.1

17+ compiler: ": #GHC 8.0.1"

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

19+

20+

5before_install:

22before_install:

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

23+ - unset CC

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

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

8−before_script:

27+install:

9− - sudo systemctl restart nix-daemon.service

28+ - cabal --version

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

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

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

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

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

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

33+ then

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

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

36+ fi

37+ - travis_retry cabal update -v

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

13script:

47script:

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

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

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

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

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

50+ - ./build.sh

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

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

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"

README.md+28−114

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

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

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

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

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.

16## Example

12## Example

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

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

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

21```haskell

16```haskell

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

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

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

29 :<|> Raw

24 :<|> Raw

30```

25```

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

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

33−an `XhrRequest`.

35```haskell

29```haskell

@@ -39,26 +33,16 @@ an `XhrRequest`.

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

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

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

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

41 (Proxy :: Proxy m)

35 (Proxy :: Proxy m)

42− (Proxy :: Proxy ())

43 (constDyn (BasePath "/"))

36 (constDyn (BasePath "/"))

44```

37```

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

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.

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

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

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

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

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

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

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

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

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

57```haskell

41```haskell

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

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

59 getint :: MonadWidget t m

43 getint :: MonadWidget t m

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

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

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

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

63 sayhi :: MonadWidget t m

47 sayhi :: MonadWidget t m

64 => Dynamic t (QParam Text)

48 => Dynamic t (QParam Text)

@@ -69,21 +53,15 @@ parameter is a trigger event for the XHR request. The return value

69 -- ^ Flag for capitalizing the response

53 -- ^ Flag for capitalizing the response

70 -> Event t ()

54 -> Event t ()

71 -- ^ Trigger the XHR Request

55 -- ^ Trigger the XHR Request

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

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

74 doubleit :: MonadWidget t m

58 doubleit :: MonadWidget t m

75 => Dynamic t (Either Text Double)

59 => Dynamic t (Either Text Double)

76 -> Event t ()

60 -> Event t ()

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

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

78```

62```

80−`ReqResult tag a` is defined in

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

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:

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

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

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

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

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

88```haskell

66```haskell

89 -- ... continued ...

67 -- ... continued ...

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

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

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

102```

80```

103

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

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

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

106

107```haskell

84```haskell

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

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

@@ -125,100 +102,37 @@ trigger the API calls, and text elements to show the results:

125 display =<< holdDyn Nothing outputDouble

102 display =<< holdDyn Nothing outputDouble

126```

103```

127

104

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

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.

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

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

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

132−the respective authors of these fabulous libraries.

133

106

134

107

135## Building the library and test server

108## Building the library and test server

136

109

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

138−ghcjs-compiled frontend

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

140−ghc-compiled backend

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

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:

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

143−manages the frontend build as a dependency.

144

111

145−```

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

147−```

148

112

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

113+First build the library:

150

114

151```

115```

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

116+git submodule update --init --recursive

117+./build.sh

153```

118```

154

119

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

120+Then build the test server:

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

157−under the Network tab.

158−

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

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

161

121

122+```

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

124+```

162

125

163−## Tagging requests

164

126

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

127+## Running the example site

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

128

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

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

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

130

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

200```

131```

201−

132+cd testserver

202−## Simultaneous requests

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

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

134```

217

135

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

136+And simply browse to `localhost:8001`

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

137+

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

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

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

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

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

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

build.shnew file+3

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

1+#!/usr/bin/env bash

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

ChangeLog.md → changelog.mdrenamed−28

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

1−0.3.5

2−-----

3−

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

5− - Require servant >= 0.16

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

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

8−

9−0.3.4

10−-----

11−

12−Add selenium-based test suite

13−

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−

290.3

10.3

30---

2---

default.nixdeleted−21

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

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

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

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

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

5−, transformers

6−}:

7−mkDerivation {

8− pname = "servant-reflex";

9− version = "0.3.6";

10− src = ./.;

11− isLibrary = true;

12− isExecutable = true;

13− libraryHaskellDepends = [

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

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

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

17− text transformers

18− ];

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

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

21−}

deps/http-api-datanew file+1

Submodule changed.

deps/reflexnew file+1

Submodule changed.

deps/reflex-domnew file+1

Submodule changed.

deps/servantnew file+1

Submodule changed.

deps/servant-snapnew file+1

Submodule changed.

exec/API.hs−1

@@ -40,7 +40,6 @@ 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

44 :<|> Raw

43 :<|> Raw

46type GET = Get '[JSON] ()

45type GET = Get '[JSON] ()

exec/Example.hs+21−48

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

1−{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

1{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

4{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

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

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

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

16import Data.Text (Text)

15import Data.Text (Text)

17import qualified Data.Text as T

16import qualified Data.Text as T

18−import qualified Data.Text.Encoding as T

19−import GHC.TypeLits

20import Servant.API

17import Servant.API

21import API

18import API

22import Data.Proxy

19import Data.Proxy

23import Text.Read (readMaybe)

20import Text.Read (readMaybe)

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

21+import Reflex.Dom

25−import Reflex.Dom (mainWidget)

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

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

27import Servant.Reflex

23import Servant.Reflex

28import Servant.Reflex.Multi

24import Servant.Reflex.Multi

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

46runMulti = do

42runMulti = do

47 url <- baseUrlWidget

43 url <- baseUrlWidget

48 el "br" blank

44 el "br" blank

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

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

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

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

51−

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

47 num :: 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

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

54−

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

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

55 b <- button "Run dbl multi"

51 b <- button "Run dbl multi"

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

52+ reqCount <- count b

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

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

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

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

59−

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

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

61 display lastInd

56 display lastInd

63 divClass "demo-group" $ do

58 divClass "demo-group" $ do

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

69 textInput def

64 textInput def

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

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

71 b <- button "Go"

66 b <- button "Go"

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

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

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

74−

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

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

76− fmap reqSuccess <$> r')

77−

78−

79 return ()

69 return ()

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

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

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

97 el "br" (return ())

87 el "br" (return ())

99 -- Name the computed API client functions

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

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

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

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

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

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

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

111

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

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

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

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

114

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

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

116

101

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

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

118− leftmost [fmapMaybe response (unitResponse)

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

119− ,fmapMaybe response (intResponse)

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

120 ]

105 ]

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

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

122 return (unitBtn, intBtn)

107 return (unitBtn, intBtn)

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

144

129

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

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

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

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

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

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

148− , fmapMaybe reqFailure (resp)])

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

149 return sayHiClicks

134 return sayHiClicks

150

135

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

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

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

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

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

157 dblinp) (tag (current reqCount) dblBtn)

142 dblinp) (tag (current reqCount) dblBtn)

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

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

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

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

160 el "br" (return ())

145 el "br" (return ())

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

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

162 holdDyn "No number yet" (fmap tShow $

147 holdDyn "No number yet" (fmap tShow $

163− fmapMaybe reqSuccess (dblResp))

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

164 return dblBtn

149 return dblBtn

165

150

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

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

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

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

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

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

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

172 fmapMaybe reqSuccess $

157 fmapMaybe reqSuccess $

173− (multiResp))

158+ (snd <$> multiResp))

174 return mpGo

159 return mpGo

175

160

176 return ()

161 return ()

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

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

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

181 text "JSON Unicode encoding test"

166 text "JSON Unicode encoding test"

182 txt <- value <$> textInput def

167 txt <- value <$> textInput def

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

168+ ev <- button "Question"

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

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

185 rr <- qna dQ ev

170 rr <- qna dQ ev

186 el "p" $

171 el "p" $

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

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

188

173

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−

201showXhrResponse :: XhrResponse -> Text

174showXhrResponse :: XhrResponse -> Text

202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

175showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

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

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

nix/nix.confdeleted−3

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

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

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

3−trusted-users = travis

nix/reflex-platform.nixdeleted−7

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

1−let

2− rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;

3−in import (builtins.fetchTarball

4− {

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

6− sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;

7− }) {}

nix/servant-snap.nixdeleted−7

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

1−# Servant-snap is marked broken in nixpkgs

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

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

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

5− rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";

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

7−}) {}

nix/testresults.nixdeleted−17

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

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

2−

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

4− echo About to phantom

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

6− sleep 3

7− echo About to Server

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

9− sleep 3

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

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

12− echo About to testdrive

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

14− echo Done

15− trap "exit" INT TERM

16− trap "kill 0" EXIT

17− ''

nix/testserver.nixdeleted−9

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

1−servant-reflex: self: super:

2−

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

4− postInstall = ''

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

6− mkdir $out/static

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

8− '';

9−})

overrides-ghc.nixnew file+19

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

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

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

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

2+let

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

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

6+ cabal2nixResult = reflex-platform.cabal2nixResult;

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

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

1Name: servant-reflex

2−Version: 0.3.6

2+Version: 0.3

3−Synopsis: servant API generator for reflex apps

3+Synopsis: Servant reflex API generator

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

4+Description: Servant reflex API generator

5−License: BSD3

5+License: AllRightsReserved

6License-file: LICENSE.md

7Author: Greg Hale, Doug Beardsley

8Maintainer: imalsogreg@gmail.com

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

11Build-type: Simple

12Cabal-version: >=1.10

14−Flag Example

15− description: Enable example

16− default: False

17−

18library

14library

19 exposed-modules:

15 exposed-modules:

20− Servant.Common.BaseUrl

21− Servant.Common.Req

22 Servant.Reflex

16 Servant.Reflex

23 Servant.Reflex.Multi

17 Servant.Reflex.Multi

19+ other-modules:

20+ Servant.Common.BaseUrl

21+ Servant.Common.Req

22+

25 hs-source-dirs: src

23 hs-source-dirs: src

26 build-depends:

24 build-depends:

27− base >= 4.8 && < 5,

25+ base >= 4.8 && < 4.10,

28 bytestring >= 0.10 && < 0.11,

26 bytestring >= 0.10 && < 0.11,

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

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

30− containers >= 0.5.6 && < 0.7,

28+ containers >= 0.5.6 && < 0.6,

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

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

32− exceptions >= 0.8 && < 0.11,

30+ exceptions >= 0.8 && < 0.9,

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

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

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

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

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

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

36− jsaddle >= 0.8 && < 0.10,

37 mtl >= 2.2.1 && < 2.3,

34 mtl >= 2.2.1 && < 2.3,

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

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

39− reflex >= 0.5 && < 0.9,

36+ reflex >= 0.5 && < 0.6,

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

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

41 safe >= 0.3.9 && < 0.4,

38 safe >= 0.3.9 && < 0.4,

42− servant >= 0.16 && < 0.18,

39+ servant >= 0.8 && < 0.11,

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

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

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

45 text >= 1.2 && < 1.3,

41 text >= 1.2 && < 1.3,

46 transformers >= 0.4 && < 0.6

42 transformers >= 0.4 && < 0.6

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

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

50 default-language: Haskell2010

46 default-language: Haskell2010

52executable example

48executable example

53− if flag(Example)

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

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

67 default-language: Haskell2010

50 default-language: Haskell2010

68 main-is: Example.hs

51 main-is: Example.hs

69 other-modules: API

52 other-modules: API

shell.nixdeleted−1

@@ -1 +0,0 @@

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

src/Servant/Common/BaseUrl.hs+8−8

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

20) where

22import Control.Monad (join)

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

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

24import Control.Monad.Fix (MonadFix)

25import Data.Monoid ((<>))

26import Data.Text (Text)

27import qualified Data.Text as T

28import GHC.Generics

29−import Language.Javascript.JSaddle.Monad (MonadJSM)

30import Reflex

29import Reflex

31−import Reflex.Dom.Core

30+import Reflex.Dom

32import Text.Read

31import Text.Read

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

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

37-- | URI scheme to use

36-- | URI scheme to use

38data Scheme =

37data Scheme =

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

85 where pathWidget :: m (Dynamic t BaseUrl)

84 where pathWidget :: m (Dynamic t BaseUrl)

86 pathWidget = do

85 pathWidget = do

87 text "Url base path"

86 text "Url base path"

88− t <- inputElement def

87+ t <- textInput (def {_textInputConfig_attributes =

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

89 return $ BasePath <$> value t

90 fullUrlWidget :: m (Dynamic t BaseUrl)

91 fullUrlWidget = do

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

93− srv <- inputElement def

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

94 text ":"

95− prt <- inputElement def

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

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

97− path <- inputElement def

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

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

src/Servant/Common/Req.hs+98−114

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

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

5{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE LambdaCase #-}

5{-# LANGUAGE LambdaCase #-}

7−{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TupleSections #-}

7{-# LANGUAGE TupleSections #-}

11module Servant.Common.Req where

9module Servant.Common.Req where

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

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

14−import Control.Applicative (liftA2, liftA3)

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

16import Control.Concurrent

12import Control.Concurrent

13+import Control.Applicative (liftA2, liftA3)

17import Control.Monad (join)

14import Control.Monad (join)

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

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

19import Data.Bifunctor (first)

16import Data.Bifunctor (first)

20−import qualified Data.ByteString.Builder as Builder

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

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

22−import Data.ByteString (ByteString)

23import qualified Data.Map as Map

18import qualified Data.Map as Map

24import Data.Maybe (catMaybes, fromMaybe)

19import Data.Maybe (catMaybes, fromMaybe)

25import Data.Functor.Compose

20import Data.Functor.Compose

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

29import qualified Data.Text as T

24import qualified Data.Text as T

30import qualified Data.Text.Encoding as TE

25import qualified Data.Text.Encoding as TE

31import Data.Traversable (forM)

26import Data.Traversable (forM)

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

33−import qualified Network.URI as N

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

27+import Reflex.Dom hiding (tag)

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

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

36 SupportsServantReflex)

29 SupportsServantReflex)

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

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

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

50 -- a non-successful response code

43 -- a non-successful response code

51 | RequestFailure tag Text

44 | RequestFailure tag Text

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

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

53− deriving (Functor)

46+

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'

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

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

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

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

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

93reqFailure (RequestFailure _ s) = Just s

68reqFailure (RequestFailure _ s) = Just s

94reqFailure _ = Nothing

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

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

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

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

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

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

108response (ResponseFailure _ _ x) = Just x

76response (ResponseFailure _ _ x) = Just x

109response _ = Nothing

77response _ = Nothing

110

79+

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

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

112−-- | Retrieve response tag

113−reqTag :: ReqResult tag a -> tag

81+instance Functor (ReqResult tag) where

114−reqTag (ResponseSuccess tag _ _) = tag

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

115−reqTag (ResponseFailure tag _ _) = tag

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

116−reqTag (RequestFailure tag _ ) = tag

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

85+

117

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

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

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

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

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

167 => Text

136 => Text

168 -> Dynamic t BaseUrl

137 -> Dynamic t BaseUrl

169 -> Req t

138 -> Req t

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

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

171reqToReflexRequest reqMeth reqHost req =

140reqToReflexRequest reqMeth reqHost req =

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

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

173 t = sequence $ reverse $ reqPathParts req

142 t = sequence $ reverse $ reqPathParts req

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

179 urlParts = fmap sequence t

148 urlParts = fmap sequence t

180

149

181 urlPath :: Dynamic t (Either Text Text)

150 urlPath :: Dynamic t (Either Text Text)

182− urlPath = (fmap.fmap)

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

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

184− urlParts

185

152

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

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

187 queryPartString (pName, qp) = case qp of

154 queryPartString (pName, qp) = case qp of

188 QueryPartParam p -> ffor p $ \case

155 QueryPartParam p -> ffor p $ \case

189 Left e -> Just (Left e)

156 Left e -> Just (Left e)

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

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

191 Right Nothing -> Nothing

158 Right Nothing -> Nothing

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

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

193 if null pStrings

160 if null pStrings

194 then Nothing

161 then Nothing

195− else Just . Right

196− . T.intercalate "&"

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

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

198 QueryPartFlag fl -> ffor fl $ \case

163 QueryPartFlag fl -> ffor fl $ \case

199 True -> Just $ Right pName

164 True -> Just $ Right pName

200 False -> Nothing

165 False -> Nothing

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

229 Right $ XhrRequestConfig

194 Right $ XhrRequestConfig

230 { _xhrRequestConfig_sendData = bytesToPayload bBytes

195 { _xhrRequestConfig_sendData = bytesToPayload bBytes

231 , _xhrRequestConfig_headers =

196 , _xhrRequestConfig_headers =

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

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

233 , _xhrRequestConfig_user = Nothing

198 , _xhrRequestConfig_user = Nothing

234 , _xhrRequestConfig_password = Nothing

199 , _xhrRequestConfig_password = Nothing

235− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

200+ , _xhrRequestConfig_responseType = Nothing

236 , _xhrRequestConfig_withCredentials = False

201 , _xhrRequestConfig_withCredentials = False

237 , _xhrRequestConfig_responseHeaders = def

202 , _xhrRequestConfig_responseHeaders = def

238 }

203 }

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

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

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

245 , _xhrRequestConfig_user = Nothing

210 , _xhrRequestConfig_user = Nothing

246 , _xhrRequestConfig_password = Nothing

211 , _xhrRequestConfig_password = Nothing

247− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

212+ , _xhrRequestConfig_responseType = Nothing

248− , _xhrRequestConfig_sendData = mempty

213+ , _xhrRequestConfig_sendData = ""

249 , _xhrRequestConfig_withCredentials = False

214 , _xhrRequestConfig_withCredentials = False

250 }

215 }

251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

216 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

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

272displayHttpRequest :: Text -> Text

237displayHttpRequest :: Text -> Text

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

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

274

239

275−-- | This function performs the request

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

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

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

277 => Text

242 => Text

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

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

279 -> Dynamic t BaseUrl

244 -> Dynamic t BaseUrl

280− -> ClientOptions

281 -> Event t tag

245 -> Event t tag

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

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

283−performRequests reqMeth rs reqHost opts trigger = do

247+performRequests reqMeth rs reqHost trigger = do

284− let xhrReqs =

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

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

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

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

287−

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

289− reqs = attachPromptlyDynWith

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

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

291−

292− resps <- performSomeRequestsAsync opts reqs

251+ resps <- performSomeRequestsAsync reqs

293 return $ getCompose <$> resps

252 return $ getCompose <$> resps

294

253

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

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.

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

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

298performSomeRequestsAsync

255performSomeRequestsAsync

299 :: (MonadIO (Performable m),

256 :: (MonadIO (Performable m),

300− MonadJSM (Performable m),

301 HasWebView (Performable m),

257 HasWebView (Performable m),

302 PerformEvent t m,

258 PerformEvent t m,

303 TriggerEvent t m,

259 TriggerEvent t m,

304 Traversable f,

260 Traversable f,

305− IsXhrPayload a,

261+ IsXhrPayload a)

306− Show a

307− )

308− => ClientOptions

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

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

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

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

311−performSomeRequestsAsync opts =

312− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

264+performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return

313

265

314

266

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

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

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

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

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

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

318performSomeRequestsAsync'

270performSomeRequestsAsync'

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

271+ :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)

320− => ClientOptions

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

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

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

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

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

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

324 rs <- hrs

275 rs <- hrs

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

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

326 Left e -> do

277 Left e -> do

@@ -328,17 +279,70 @@ performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs

328 return resp

279 return resp

329 Right r' -> do

280 Right r' -> do

330 resp <- liftIO newEmptyMVar

281 resp <- liftIO newEmptyMVar

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

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

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

333 return resp

283 return resp

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

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

335 return ()

285 return ()

336

286

337

287

338

288

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+

339−type XhrPayload = ByteString

308+type XhrPayload = T.Text

340bytesToPayload :: BL.ByteString -> XhrPayload

309bytesToPayload :: BL.ByteString -> XhrPayload

341−bytesToPayload = BL.toStrict

310+bytesToPayload = TE.decodeUtf8 . 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+-- ]

342

346

343

347

344performRequestsCT

348performRequestsCT

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

348 -> Text

352 -> Text

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

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

350 -> Dynamic t BaseUrl

354 -> Dynamic t BaseUrl

351− -> ClientOptions

352 -> Event t tag

355 -> Event t tag

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

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

354−performRequestsCT ct reqMeth reqs reqHost opts trigger = do

357+performRequestsCT ct reqMeth reqs reqHost trigger = do

355− resps <- performRequests reqMeth reqs reqHost opts trigger

358+ resps <- performRequests reqMeth reqs reqHost trigger

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

357− first T.pack .

359+ let decodeResp x = first T.pack .

358− mimeUnrender ct $

360+ mimeUnrender ct .

359− BL.fromStrict x

361+ BL.fromStrict .

360− decodeResp _ = Left "No body"

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

363+ (_xhrResponse_responseText x)

361 return $ fmap

364 return $ fmap

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

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

363 Left e -> RequestFailure t e

366 Left e -> RequestFailure t e

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

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

365 )

368 )

366 resps

369 resps

367

370

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

372 => Text

375 => Text

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

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

374 -> Dynamic t BaseUrl

377 -> Dynamic t BaseUrl

375− -> ClientOptions

376 -> Event t tag

378 -> Event t tag

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

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

378−performRequestsNoBody reqMeth reqs reqHost opts trigger = do

380+performRequestsNoBody reqMeth reqs reqHost trigger = do

379− resps <- performRequests reqMeth reqs reqHost opts trigger

381+ resps <- performRequests reqMeth reqs reqHost trigger

380 let decodeResp = const $ Right NoContent

382 let decodeResp = const $ Right NoContent

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

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

382 Left e -> RequestFailure tag e

384 Left e -> RequestFailure tag e

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

389 -> (tag, XhrResponse)

391 -> (tag, XhrResponse)

390 -> ReqResult tag a

392 -> ReqResult tag a

391evalResponse decode (tag, xhr) =

393evalResponse decode (tag, xhr) =

392− let status = _xhrResponse_status xhr

394+ let okStatus = _xhrResponse_status xhr < 400

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

394 errMsg = fromMaybe

395 errMsg = fromMaybe

395 ("Empty response with error code " <>

396 ("Empty response with error code " <>

396 T.pack (show $ _xhrResponse_status xhr))

397 T.pack (show $ _xhrResponse_status xhr))

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

403 else ResponseFailure tag errMsg xhr

404 else ResponseFailure tag errMsg xhr

404 in respPayld

405 in respPayld

405

406

406−------------------------------------------------------------------------------

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

408−-- response 'Event's,

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

410−fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess

411

407

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

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

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

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

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

417

408

418

409

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

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

@@ -422,10 +413,3 @@ note e = maybe (Left e) Right

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

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

423fmapL _ (Right a) = Right a

414fmapL _ (Right a) = Right a

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

415fmapL f (Left e) = Left (f e)

425−

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

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

428−

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

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

431−

src/Servant/Reflex.hs+104−204

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

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

7−{-# LANGUAGE InstanceSigs #-}

6+{-# LANGUAGE InstanceSigs #-}

7+{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TupleSections #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE UndecidableInstances #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

14+{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE OverloadedStrings #-}

15+{-# LANGUAGE OverloadedStrings #-}

10−{-# LANGUAGE PolyKinds #-}

16+{-# LANGUAGE PolyKinds #-}

11−{-# LANGUAGE Rank2Types #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

17+{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE TupleSections #-}

18+{-# LANGUAGE TupleSections #-}

14−{-# LANGUAGE TypeFamilies #-}

19+{-# LANGUAGE TypeFamilies #-}

15−{-# LANGUAGE TypeOperators #-}

20+{-# LANGUAGE TypeOperators #-}

16−{-# LANGUAGE UndecidableInstances #-}

21+{-# LANGUAGE UndecidableInstances #-}

17−

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

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

20−#endif

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

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

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

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

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

25-- API.

26-- API.

26module Servant.Reflex

27module Servant.Reflex

27 ( client

28 ( client

28− , clientWithOpts

29− , clientWithOptsAndResultHandler

30− , clientWithRoute

31− , clientWithRouteAndResultHandler

32 , BuildHeaderKeysTo(..)

29 , BuildHeaderKeysTo(..)

33 , toHeaders

30 , toHeaders

34− , HasClient

31+ , HasClient(..)

35− , Client

36 , module Servant.Common.Req

32 , module Servant.Common.Req

37 , module Servant.Common.BaseUrl

33 , module Servant.Common.BaseUrl

38 ) where

34 ) where

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

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

41import Control.Applicative

37import Control.Applicative

42−import qualified Data.CaseInsensitive as CI

43−import Data.Functor.Identity

44−import qualified Data.Map as Map

45import Data.Monoid ((<>))

38import Data.Monoid ((<>))

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

47import qualified Data.Set as Set

39import qualified Data.Set as Set

40+import qualified Data.Text.Encoding as E

41+import Data.CaseInsensitive (mk)

42+import Data.Functor.Identity

43+import Data.Proxy (Proxy (..))

44+import qualified Data.Map as Map

48import Data.Text (Text)

45import Data.Text (Text)

49import qualified Data.Text as T

46import qualified Data.Text as T

50−import qualified Data.Text.Encoding as E

51−import GHC.Exts (Constraint)

52import GHC.TypeLits (KnownSymbol, symbolVal)

47import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

54− BasicAuthData, BuildHeadersTo (..),

49+ BasicAuthData, BuildHeadersTo(..),

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

50+ Capture, contentType, Header,

56− HttpVersion, IsSecure,

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

57− MimeRender (..), MimeUnrender,

52+ MimeRender(..), MimeUnrender,

58 NoContent, QueryFlag, QueryParam,

53 NoContent, QueryFlag, QueryParam,

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

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

60 RemoteHost, ReqBody,

55 RemoteHost, ReqBody,

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

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

62− contentType)

57+

63−import Servant.API.Description (Summary)

64−import qualified Servant.Auth as Auth

65−

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

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

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

59+ XhrRequest(..),

68− XhrResponseHeaders (..),

60+ XhrResponseHeaders(..),

69− attachPromptlyDynWith, constDyn, ffor,

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

70− fmapMaybe, leftmost,

71− performRequestsAsync)

62+ leftmost, performRequestsAsync,

63+ )

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

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

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

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

74 showBaseUrl,

66 showBaseUrl,

75 SupportsServantReflex)

67 SupportsServantReflex)

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

77− defaultClientOptions,

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

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

79 QueryPart(..), addHeader, authData,

69 QueryPart(..), addHeader, authData,

80 defReq, evalResponse, prependToPathParts,

70 defReq, evalResponse, prependToPathParts,

81 -- performRequestCT,

71 -- performRequestCT,

@@ -85,10 +75,8 @@ import Servant.Common.Req (ClientOptions(..),

85 performSomeRequestsAsync,

75 performSomeRequestsAsync,

86 qParamToQueryPart, reqBody,

76 qParamToQueryPart, reqBody,

87 reqSuccess, reqFailure,

77 reqSuccess, reqFailure,

88− reqMethod, respHeaders,

78+ reqMethod, respHeaders, response,

89− response,

90− reqTag,

91− qParams, withCredentials)

79+ qParams)

94-- * Accessing APIs as a Client

82-- * Accessing APIs as a Client

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

103-- >

91-- >

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

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

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

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

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

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

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

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

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

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

109−client

110− :: (HasClient t m layout tag)

97+client :: (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

125− -> Client t m layout tag

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

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

99+client 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

141

100

142

101

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

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

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

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

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

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

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

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

147 type Client t m layout tag :: *

106 type Client t m layout tag :: *

148− clientWithRoute

107+ clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> Client t m layout tag

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

167

108

168

109

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

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

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

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

171

112

172− clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =

113+ clientWithRoute Proxy q pTag req baseurl =

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

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

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

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

175

116

176

117

177-- Capture. Example:

118-- Capture. Example:

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

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

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

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

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

194

135

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

136+ clientWithRoute Proxy q t req baseurl val =

196− clientWithRouteAndResultHandler

137+ clientWithRoute (Proxy :: Proxy sublayout)

138+ q t

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

139+ (prependToPathParts p req)

140+ baseurl

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

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

199

142

200

143

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

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

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

208 -- TODO how to access input types here?

151 -- TODO how to access input types here?

209 -- ExceptT ServantError IO a

152 -- ExceptT ServantError IO a

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

153+ clientWithRoute Proxy _ _ req baseurl trigs =

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

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

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

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

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

213 req' = req { reqMethod = method }

157 req' = req { reqMethod = method }

214

158

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

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

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

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

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

223 -- ExceptT ServantError IO NoContent

167 -- ExceptT ServantError IO NoContent

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

168+ clientWithRoute Proxy _ _ req baseurl =

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

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

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

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

227

171

228

172

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

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

230toHeaders r =

174toHeaders r =

175+ let toBS = E.encodeUtf8

231− let hdrs = maybe []

176+ hdrs = maybe []

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

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

233 (Map.toList $ _xhrResponse_headers xhr))

178 (Map.toList $ _xhrResponse_headers xhr))

234 (response r)

179 (response r)

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

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

236

181

237−

238class BuildHeaderKeysTo hs where

182class BuildHeaderKeysTo hs where

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

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

240

184

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

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

242 where buildHeaderKeysTo _ = []

186 where buildHeaderKeysTo _ = []

243

187

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

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

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

189+ => BuildHeaderKeysTo '[(Header h v) ': xs] where

246− buildHeaderKeysTo _ =

247− let

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

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

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

250−

251

191

252-- HEADERS Verb (Content) --

192-- HEADERS Verb (Content) --

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

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

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

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

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

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

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

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

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

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

205+ clientWithRoute Proxy _ _ req baseurl trigs = do

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

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

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

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

268− wrap $ toHeaders <$> resp

208+ return $ toHeaders <$> resp

269 where req' = req { respHeaders =

209 where req' = req { respHeaders =

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

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

271 }

211 }

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

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

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

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

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

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

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

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

221+ clientWithRoute Proxy _ _ req baseurl trigs = do

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

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

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

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

284− wrap $ toHeaders <$> resp

224+ return $ toHeaders <$> resp

285 where req' = req {respHeaders =

225 where req' = req {respHeaders =

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

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

287 }

227 }

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

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

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

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

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

310

250

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

251+ clientWithRoute Proxy q t req baseurl eVal =

312− clientWithRouteAndResultHandler

313− (Proxy :: Proxy sublayout) q t

252+ clientWithRoute (Proxy :: Proxy sublayout)

253+ q t

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

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

315− baseurl opts wrap

255+ baseurl

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

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

317

257

318

258

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

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

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

327 Client t m sublayout tag

267 Client t m sublayout tag

328

268

329− clientWithRouteAndResultHandler Proxy =

269+ clientWithRoute Proxy q t =

330− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

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

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 =

341− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

342−

343−

344

271

345

272

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

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

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

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

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

377

304

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

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

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

306+ clientWithRoute Proxy q t req baseurl mparam =

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

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

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

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

382

309

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

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

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

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

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

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

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

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

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

424

351

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

352+ clientWithRoute Proxy q t req baseurl paramlist =

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

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

427

354

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

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

429 pname = symbolVal (Proxy :: Proxy sym)

356 pname = symbolVal (Proxy :: Proxy sym)

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

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

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

463 Dynamic t Bool -> Client t m sublayout tag

390 Dynamic t Bool -> Client t m sublayout tag

464

391

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

392+ clientWithRoute Proxy q t req baseurl flag =

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

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

467

394

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

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

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

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

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

477 -> Event t tag

404 -> Event t tag

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

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

479

406

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

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

481

408

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

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

483 Left e -> Left e

410 Left e -> Left e

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

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

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

489

416

490 resps <- performRequestsAsync okReq

417 resps <- performRequestsAsync okReq

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

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

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

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

493 ]

420 ]

494

421

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

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

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

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

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

521

448

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

449+ clientWithRoute Proxy q t req baseurl body =

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

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

524 where req' = req { reqBody = bodyBytesCT }

451 where req' = req { reqBody = bodyBytesCT }

525 ctProxy = Proxy :: Proxy ct

452 ctProxy = Proxy :: Proxy ct

526 ctString = T.pack $ show $ contentType ctProxy

453 ctString = T.pack $ show $ contentType ctProxy

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

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

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

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

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

536

463

537− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =

464+ clientWithRoute Proxy q t req baseurl =

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

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

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

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

540

467

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

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

542

469

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

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

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

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

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

546

473

547− clientWithRouteAndResultHandler Proxy =

474+ clientWithRoute Proxy q t req baseurl =

548− clientWithRouteAndResultHandler (Proxy :: Proxy api)

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

549

476

550

477

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

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

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

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

553

480

554− clientWithRouteAndResultHandler Proxy =

481+ clientWithRoute Proxy q t req baseurl =

555− clientWithRouteAndResultHandler (Proxy :: Proxy api)

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

556

483

557

484

558

485

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

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

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

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

561

488

562− clientWithRouteAndResultHandler Proxy =

489+ clientWithRoute Proxy q t req baseurl =

563− clientWithRouteAndResultHandler (Proxy :: Proxy api)

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

564

491

565

492

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

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

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

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

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

570 -> Client t m api tag

497 -> Client t m api tag

571

498

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

499+ clientWithRoute Proxy q t req baseurl authdata =

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

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

574 where

501 where

575 req' = req { authData = Just authdata }

502 req' = req { authData = Just authdata }

576

503

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

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

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

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

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

598-}

525-}

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

625−

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

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

16module Servant.Reflex.Multi (

17 -- * Compute servant client functions

18 clientA

19− , clientWithOptsA

20 , BaseUrl(..)

19 , BaseUrl(..)

21 , Scheme(..)

20 , Scheme(..)

23 -- * Build QueryParam arguments

22 -- * Build QueryParam arguments

24 , QParam(..)

23 , QParam(..)

26− -- * Access response data

27− , withCredentials

29 -- * Access response data

26 -- * Access response data

30 , ReqResult(..)

27 , ReqResult(..)

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

37 ) where

34 ) where

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

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

40−import Control.Applicative (liftA2)

37+import Control.Applicative (liftA2)

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

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

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

39+import Data.Proxy (Proxy (..))

43−import qualified Data.Set as Set

40+import qualified Data.Set as Set

44−import Data.Text (Text)

41+import Data.Text (Text)

45−import qualified Data.Text as T

42+import qualified Data.Text as T

46−import qualified Data.Text.Encoding as E

43+import qualified Data.Text.Encoding as E

47−import GHC.TypeLits (KnownSymbol, symbolVal)

44+import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

49− BasicAuthData, BuildHeadersTo (..),

46+ BasicAuthData, BuildHeadersTo (..),

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

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

51− HttpVersion, IsSecure,

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

52− MimeRender (..), MimeUnrender,

53− NoContent, QueryFlag, QueryParam,

49+ MimeUnrender, NoContent, QueryFlag,

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

50+ QueryParam, QueryParams, Raw,

55− RemoteHost, ReqBody,

51+ ReflectMethod (..), RemoteHost,

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

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

57− contentType)

53+ Verb, contentType)

58−import Servant.API.Description (Summary)

54+

59−

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

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

61− XhrRequest (..),

56+ XhrRequest (..),

62− XhrResponseHeaders (..),

57+ XhrResponseHeaders (..),

63− attachPromptlyDynWith, constDyn)

58+ attachPromptlyDynWith, constDyn)

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

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

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

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

66 SupportsServantReflex)

61 SupportsServantReflex)

67−import Servant.Common.Req (ClientOptions,

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

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

69 ReqResult (..), addHeader, authData,

63 ReqResult (..), addHeader, authData,

70− defReq,

71− defaultClientOptions,

72− performRequestsCT,

64+ defReq, performRequestsCT,

73 performRequestsNoBody,

65 performRequestsNoBody,

74 performSomeRequestsAsync,

66 performSomeRequestsAsync,

75 prependToPathParts, qParamToQueryPart,

67 prependToPathParts, qParamToQueryPart,

76 qParams, reqBody, reqFailure,

68 qParams, reqBody, reqFailure,

77 reqMethod, reqSuccess, reqSuccess',

69 reqMethod, reqSuccess, reqSuccess',

78− respHeaders, response, withCredentials)

70+ respHeaders, response)

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

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

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

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

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

86clientA p q f tag baseurl =

78clientA p q f tag baseurl =

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

79 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

100------------------------------------------------------------------------------

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

101class HasClientMulti t m layout f (tag :: *) where

83class HasClientMulti t m layout f (tag :: *) where

102 type ClientMulti t m layout f tag :: *

84 type ClientMulti t m layout f tag :: *

103 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag

85 clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag

104 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl

86 -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl

105− -> ClientOptions -> ClientMulti t m layout f tag

87+ -> ClientMulti t m layout f tag

106

107

108------------------------------------------------------------------------------

90------------------------------------------------------------------------------

@@ -110,9 +92,9 @@ instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>

110 HasClientMulti t m (a :<|> b) f tag where

92 HasClientMulti t m (a :<|> b) f tag where

111 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>

93 type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>

112 ClientMulti t m b f tag

94 ClientMulti t m b f tag

113− clientWithRouteMulti Proxy q f tag reqs baseurl opts =

95+ clientWithRouteMulti Proxy q f tag reqs baseurl =

114− clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>

96+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl :<|>

115− clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts

97+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl

116

117

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

100------------------------------------------------------------------------------

@@ -125,8 +107,8 @@ instance (SupportsServantReflex t m,

125 type ClientMulti t m (Capture capture a :> sublayout) f tag =

107 type ClientMulti t m (Capture capture a :> sublayout) f tag =

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

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

127

109

128− clientWithRouteMulti _ q f tag reqs baseurl opts vals =

110+ clientWithRouteMulti _ q f tag reqs baseurl vals =

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

111+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

130 where

112 where

131 reqs' = (prependToPathParts <$> ps <*>) <$> reqs

113 reqs' = (prependToPathParts <$> ps <*>) <$> reqs

132 ps = (fmap . fmap . fmap) toUrlPiece vals

114 ps = (fmap . fmap . fmap) toUrlPiece vals

@@ -146,8 +128,8 @@ instance {-# OVERLAPPABLE #-}

146 type ClientMulti t m (Verb method status cts' a) f tag =

128 type ClientMulti t m (Verb method status cts' a) f tag =

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

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

148

130

149− clientWithRouteMulti _ _ _ _ reqs baseurl opts =

131+ clientWithRouteMulti _ _ _ _ reqs baseurl =

150− performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts

132+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl

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

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

152 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs

134 reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs

153

135

@@ -161,8 +143,8 @@ instance {-# OVERLAPPING #-}

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

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

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

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

163 -- ExceptT ServantError IO NoContent

145 -- ExceptT ServantError IO NoContent

164− clientWithRouteMulti Proxy _ _ _ req baseurl opts =

146+ clientWithRouteMulti Proxy _ _ _ req baseurl =

165− performRequestsNoBody method req baseurl opts

147+ performRequestsNoBody method req baseurl

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

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

167

149

168

150

@@ -176,9 +158,9 @@ instance {-# OVERLAPPABLE #-}

176 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where

158 ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where

177 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =

159 type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =

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

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

179− clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do

161+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do

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

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

181− resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))

163+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl triggers :: m (Event t (f (ReqResult tag a)))

182 return $ fmap toHeaders <$> resp

164 return $ fmap toHeaders <$> resp

183 where

165 where

184 reqs' = fmap (\r ->

166 reqs' = fmap (\r ->

@@ -199,9 +181,9 @@ instance {-# OVERLAPPABLE #-}

199 cts (Headers ls NoContent)) f tag where

181 cts (Headers ls NoContent)) f tag where

200 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag

182 type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag

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

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

202− clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do

184+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do

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

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

204− resp <- performRequestsNoBody method reqs' baseurl opts triggers

186+ resp <- performRequestsNoBody method reqs' baseurl triggers

205 return $ fmap toHeaders <$> resp

187 return $ fmap toHeaders <$> resp

206 where reqs' = fmap (\req ->

188 where reqs' = fmap (\req ->

207 req {respHeaders = OnlyHeaders (Set.fromList

189 req {respHeaders = OnlyHeaders (Set.fromList

@@ -221,11 +203,11 @@ instance (KnownSymbol sym,

221 type ClientMulti t m (Header sym a :> sublayout) f tag =

203 type ClientMulti t m (Header sym a :> sublayout) f tag =

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

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

223

205

224− clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =

206+ clientWithRouteMulti Proxy f q tag reqs baseurl eVals =

225 clientWithRouteMulti (Proxy :: Proxy sublayout) f

207 clientWithRouteMulti (Proxy :: Proxy sublayout) f

226 q tag

208 q tag

227 reqs'

209 reqs'

228− baseurl opts

210+ baseurl

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

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

230 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)

212 reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)

231 <$> eVals <*>) <$> reqs

213 <$> eVals <*>) <$> reqs

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

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

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

243

225

244

226

245−------------------------------------------------------------------------------

246−instance (HasClientMulti t m sublayout f tag, KnownSymbol sym)

247− => HasClientMulti t m (Summary sym :> sublayout) f tag where

248−

249− type ClientMulti t m (Summary sym :> sublayout) f tag =

250− ClientMulti t m sublayout f tag

251−

252− clientWithRouteMulti Proxy q f tag =

253− clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

254−

255−

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

227------------------------------------------------------------------------------

257instance (KnownSymbol sym,

228instance (KnownSymbol sym,

258 ToHttpApiData a,

229 ToHttpApiData a,

@@ -266,9 +237,9 @@ instance (KnownSymbol sym,

266

237

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

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

268 -- TODO: Check the above comment

239 -- TODO: Check the above comment

269− clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =

240+ clientWithRouteMulti Proxy q f tag reqs baseurl mparams =

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

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

271− reqs' baseurl opts

242+ reqs' baseurl

272

243

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

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

274 p prm = QueryPartParam $ fmap qParamToQueryPart prm

245 p prm = QueryPartParam $ fmap qParamToQueryPart prm

@@ -289,8 +260,8 @@ instance (KnownSymbol sym,

289 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =

260 type ClientMulti t m (QueryParams sym a :> sublayout) f tag =

290 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag

261 Dynamic t (f [a]) -> ClientMulti t m sublayout f tag

291

262

292− clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =

263+ clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =

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

264+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

294

265

295 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }

266 where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }

296 pname = symbolVal (Proxy :: Proxy sym)

267 pname = symbolVal (Proxy :: Proxy sym)

@@ -308,8 +279,8 @@ instance (KnownSymbol sym,

308 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =

279 type ClientMulti t m (QueryFlag sym :> sublayout) f tag =

309 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag

280 Dynamic t (f Bool) -> ClientMulti t m sublayout f tag

310

281

311− clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =

282+ clientWithRouteMulti Proxy q f' tag reqs baseurl flags =

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

283+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl

313

284

314 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }

285 where req' f req = req { qParams = thisPair (constDyn f) : qParams req }

315 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)

286 thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)

@@ -323,10 +294,10 @@ instance (SupportsServantReflex t m,

323 -> Event t tag

294 -> Event t tag

324 -> m (Event t (f (ReqResult tag ())))

295 -> m (Event t (f (ReqResult tag ())))

325

296

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

297+ clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do

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

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

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

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

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

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

330 return resps

301 return resps

331 where

302 where

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

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

@@ -342,8 +313,8 @@ instance (MimeRender ct a,

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

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

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

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

344

315

345− clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

316+ clientWithRouteMulti Proxy q f tag reqs baseurl bodies =

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

317+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl

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

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

348 ctProxy = Proxy :: Proxy ct

319 ctProxy = Proxy :: Proxy ct

349 ctString = T.pack $ show $ contentType ctProxy

320 ctString = T.pack $ show $ contentType ctProxy

@@ -394,8 +365,8 @@ instance (HasClientMulti t m api f tag, Reflex t, Applicative f)

394 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))

365 type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))

395 -> ClientMulti t m api f tag

366 -> ClientMulti t m api f tag

396

367

397− clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =

368+ clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =

398− clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts

369+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl

399 where

370 where

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

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

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

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

stack.yamldeleted−56

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

1−flags: {}

2−extra-package-dbs: []

3−packages:

4−- '.'

5−

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+1−2

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

9import Data.Foldable

10import Test.WebDriver.Commands.Wait

11import Test.Hspec.WebDriver

12−import Test.Hspec.WebDriver (chromeCaps)

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

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

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

29spec = do

28spec = do

30 describe "servant-reflex tests" $ do

29 describe "servant-reflex tests" $ do

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

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

34 it "opens the page" $ runWD $

33 it "opens the page" $ runWD $

35 openPage "http://localhost:8000"

34 openPage "http://localhost:8000"

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

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

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE TypeOperators #-}

4−

5−module API where

6−

7−import Data.Aeson

8−import Data.Aeson.Types (typeMismatch)

9−import Data.Text (Text)

10−import Servant.API

11−

12−newtype Question = Question { unQuestion :: Text } deriving (Show)

13−

14−instance ToJSON Question where

15− toJSON (Question txt) = object ["question" .= txt]

16−

17−instance FromJSON Question where

18− parseJSON (Object v) = Question <$> v .: "question"

19− parseJSON x = typeMismatch "Couldn't find key 'question'" x

20−

21−newtype Answer = Answer { unAnswer :: Text } deriving (Show)

22−

23−instance ToJSON Answer where

24− toJSON (Answer txt) = object ["answer" .= txt]

25−

26−instance FromJSON Answer where

27− parseJSON (Object v) = Answer <$> v .: "answer"

28− parseJSON x = typeMismatch "Couldn't find key 'answer'" x

29−

30−

31−-- | API spec for server, client, and docs

32−type API = "getunit" :> Get '[JSON] ()

33− :<|> "getint" :> Get '[JSON] Int

34− :<|> "sayhi" :> QueryParam "username" Text

35− :> QueryParams "greetings" Text

36− :> QueryFlag "gusto"

37− :> Get '[JSON] Text

38− :<|> "double" :> ReqBody '[JSON] Double

39− :> Post '[JSON] Double

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

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

42− :> Post '[JSON] Answer

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

44− :<|> Raw

45−

46−type GET = Get '[JSON] ()

47−

48−-- Imported the comprehensive API example for testing.

49−-- https://github.com/haskell-servant/servant/blob/master/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs

50−type ComprehensiveAPI =

51− GET :<|>

52− Get '[JSON] Int :<|>

53− Capture "foo" Int :> GET :<|>

54− Header "foo" Int :> GET :<|>

55− HttpVersion :> GET :<|>

56− IsSecure :> GET :<|>

57− QueryParam "foo" Int :> GET :<|>

58− QueryParams "foo" Int :> GET :<|>

59− QueryFlag "foo" :> GET :<|>

60−-- Raw :<|>

61− RemoteHost :> GET :<|>

62− ReqBody '[JSON] Int :> GET :<|>

63− Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>

64− "foo" :> GET :<|>

65− Vault :> GET :<|>

66− Verb 'POST 204 '[JSON] () :<|>

67− Verb 'POST 204 '[JSON] Int

68−-- This one isn't in scope

69−-- :<|> WithNamedContext "foo" '[] GET

@@ -0,0 +1 @@

1+../exec/API.hs

testserver/Main.hs+5−20

@@ -2,17 +2,14 @@

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PolyKinds #-}

5−{-# LANGUAGE TypeApplications #-}

6{-# LANGUAGE TypeFamilies #-}

5{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeOperators #-}

6{-# LANGUAGE TypeOperators #-}

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

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

10−import Control.Monad.Reader (reader)

11import Data.Aeson

9import Data.Aeson

12import Data.Bool

10import Data.Bool

13import Data.Char (toUpper)

11import Data.Char (toUpper)

14import qualified Data.List as L

12import qualified Data.List as L

15−import Data.Maybe (fromMaybe)

16import Data.Monoid

13import Data.Monoid

17import Data.Proxy

14import Data.Proxy

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

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

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

27import Servant

24import Servant

28import Servant.Server

25import Servant.Server

29-- import Snap.Util.FileServe

26-- import Snap.Util.FileServe

30−import System.Environment (lookupEnv)

31import API

27import API

32import Snap

28import Snap

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

43testApi :: Proxy API

39testApi :: Proxy API

44testApi = Proxy

40testApi = Proxy

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

42+data App = App

48-- Server-side handlers.

44-- Server-side handlers.

49--

45--

@@ -51,10 +47,8 @@ data App = App { appStaticDir :: String }

51-- that represents the API, are glued together using :<|>.

47-- that represents the API, are glued together using :<|>.

52--

48--

53-- Each handler runs in the 'ExceptT ServantErr IO' monad.

49-- Each handler runs in the 'ExceptT ServantErr IO' monad.

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

50+server :: Server API (Handler App App)

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

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

57− :<|> statics

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

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

59 sayhi nm greetings withGusto = case nm of

53 sayhi nm greetings withGusto = case nm of

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

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

@@ -75,27 +69,18 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl

75 putStrLn $ "qna got: " ++ show q

69 putStrLn $ "qna got: " ++ show q

76 T.putStrLn $ unQuestion q

70 T.putStrLn $ unQuestion q

77 return $ Answer $ unQuestion q

71 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

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

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

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

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

88test :: Handler App App ()

75test :: Handler App App ()

89−test = serveSnapWithContext testApi

76+test = serveSnap testApi server

90− (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server

92initApp :: SnapletInit App App

78initApp :: SnapletInit App App

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

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

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

95 addRoutes [("", test)

80 addRoutes [("", test)

96 ,("", serveDirectory "static")

81 ,("", serveDirectory "static")

97 ]

82 ]

98− return (App staticDir)

83+ return App

100-- Put this all to work!

85-- Put this all to work!

101main :: IO ()

86main :: IO ()

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

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

1+#!/usr/bin/env bash

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

4+phantomjs --webdriver=127.0.0.1:4444 &

5+dist/build/spec/spec

testserver/testserver.cabal+7−8

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

19 main-is: Main.hs

20 -- other-modules:

21 -- other-extensions:

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

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

23− , base >=4.8 && < 5

23+ , base >=4.8 && <4.10

24− , mtl

25− , snap >= 1.0 && < 1.2

24+ , snap >= 1.0 && < 1.1

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

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

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

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

28− , servant >= 0.16 && < 0.18

27+ , servant >= 0.8 && < 0.11

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

28+ , servant-snap >= 0.7.2 && < 0.8

30− , text >= 1.0 && < 1.3

29+ , text >= 1.2 && < 1.3

31 -- hs-source-dirs:

30 -- hs-source-dirs:

32 default-language: Haskell2010

31 default-language: Haskell2010

testserver/tr.nixnew file+32

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

1+{ reflex-platform, ... }:

2+let

4+ dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;

5+ cabal2nixResult = reflex-platform.cabal2nixResult;

6+ nixpkgs = (import <nixpkgs> {});

7+in

8+reflex-platform.ghc.override {

9+ overrides = self: super: {

10+ servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});

11+ snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap) {});

12+ io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});

13+ io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});

14+ heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});

15+ xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});

16+ snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});

17+ snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});

18+ snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});

19+ snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});

20+ hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});

21+

22+ # servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});

23+ # servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});

24+ # servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});

25+ # servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});

26+ # servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});

27+ # servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});

28+ # servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});

29+ # servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});

30+

31+ };

32+}

travis.nixdeleted−70

@@ -1,70 +0,0 @@

1−{

2− nativeCompiler ? "ghc",

3− # ^ Choose a GHC for compiling backend components (web server, selenium)

4− # (ghc, ghc8_0, ghc8_2, ghc8_4 or ghcHEAD)

5−

6− jsCompiler ? "ghcjs"

7− # ^ Choose a GHCJS for compiling the frontend

8− # (ghcjs, ghcjs8_0, ghcjs8_2 or ghcjs8_4)

9−

10−}:

11−

12−let

13−

14− reflexPlatform = import ./nix/reflex-platform.nix;

15−

16− lib = reflexPlatform.nixpkgs.haskell.lib;

17− do = funs: pkg: builtins.foldl' (a: b: b a) pkg funs;

18−

19− ghcjsPkgs = with lib; reflexPlatform.${jsCompiler}.override {

20− overrides = self: super: {

21− http-media = dontCheck super.http-media;

22− servant = dontCheck super.servant;

23− lens-aeson = dontCheck super.lens-aeson;

24− servant-reflex = lib.appendConfigureFlag

25− (self.callPackage ./default.nix {}) "-fExample";

26− };

27− };

28−

29− ghcPkgs = with lib; reflexPlatform.${nativeCompiler}.override {

30− overrides = self: super: {

31− servant-snap = dontCheck ((import ./nix/servant-snap.nix {}) self super);

32− testdriver = self.callCabal2nix "testdriver" ./testdriver {};

33− testserver = import nix/testserver.nix ghcjsPkgs.servant-reflex self super;

34− servant-reflex = self.callPackage ./default.nix {};

35− };

36− };

37−

38− testresults = import ./nix/testresults.nix

39− { inherit reflexPlatform;

40− inherit (ghcPkgs) testserver testdriver;

41− inherit (reflexPlatform.nixpkgs) curl;

42− phantomjs = reflexPlatform.nixpkgs.phantomjs2;

43− };

44−

45−in

46− rec {

47−

48− inherit reflexPlatform ghcPkgs ghcjsPkgs;

49−

50− build = ghcjsPkgs.servant-reflex;

51− buildGhc = ghcPkgs.servant-reflex;

52− testserver = ghcPkgs.testserver;

53− testdriver = ghcPkgs.testdriver;

54− inherit testresults;

55−

56− cabalBuild = reflexPlatform.${jsCompiler}.shellFor {

57− name = "servant-reflex-cabal-builder";

58−

59− packages = p: [

60− build

61− ];

62−

63− shellHook = ''

64− cabal configure --ghcjs -f Example

65− cabal build

66− exec/toSite.sh

67− exit $?

68− '';

69− };

70− }