183d8db..master · typeable/servant-reflex

git.iko.soy/typeable/servant-reflex

on master help sign in

.gitignore+3

since splitsnapshots

unifiedsplit

@@ -6,3 +6,6 @@ log

6*.webapp

7*.stats

8out

9+/.stack-work/

10+TAGS

11+dist-newstyle

.gitmodules−15

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

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

2− path = deps/reflex-dom

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

4−[submodule "deps/reflex"]

5− path = deps/reflex

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

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

8− path = deps/http-api-data

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

10−[submodule "deps/servant"]

11− path = deps/servant

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

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

14− path = deps/servant-snap

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

.travis.yml+12−58

@@ -1,63 +1,17 @@

1−sudo: required

1+language: nix

2−

2+nix: 2.3.6

3−before_cache:

3+sudo: require

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

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

6−

7−addons:

8− apt:

9− - phantomjs

10−

11−matrix:

12− include:

13− - env: CABALVER=1.24 GHCVER=7.10.3

14− compiler: ": #GHC 7.10.3"

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

16− - env: CABALVER=1.24 GHCVER=8.0.1

17− compiler: ": #GHC 8.0.1"

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

19−

20−

22before_install:

5before_install:

23− - openssl aes-256-cbc -K $encrypted_3c89d919c82e_key -iv $encrypted_3c89d919c82e_iv -in deploy_key.enc -out deploy_key -d

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

24− - unset CC

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

26− - git submodule update --init --recursive

28−install:

8+before_script:

29− - cabal --version

9+ - sudo systemctl restart nix-daemon.service

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

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

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

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

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

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

34− then

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

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

37− fi

38− - travis_retry cabal update -v

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

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

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

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

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

44− - sleep 3

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

46− - sleep 3

48script:

13script:

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

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

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

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

51− - ./build.sh

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

52− - testdriver/dist/build/spec/spec

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

53−

54−cache:

55− directories:

56− - /nix

57− - $HOME/.cabal/packages

58− - $HOME/.cabal/store

59−

60−env:

61− global:

62− - ENCRYPTION_LABEL: "3c89d919c82e"

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

ChangeLog.mdnew file+60

@@ -0,0 +1,60 @@

1+0.3.5

2+-----

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

5+ - Require servant >= 0.16

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

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

9+0.3.4

10+-----

11+

12+Add selenium-based test suite

13+

14+0.3.3

15+-----

16+

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

18+

19+

20+0.3.2

21+-----

22+

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

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

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

26+or print the Request to the console for debugging

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

28+

29+0.3

30+---

31+

32+- **Addition of the 'Servant.Reflex.Multi' module** which allows the user

33+to choose some '(Applicative f, Traversable f) => f' for collecting

34+endpoint parameters. The traversable instance is used for passing

35+multiple 'XhrRequest's in response to a single event trigger. The

36+Applicative instance is used to combine parameters. For example,

37+'Capture "id" Name :> QueryParam "greeting" Text :> Get '[JSON] Text'

38+will generate a client function:

39+`Dynamic t (f Name) -> Dynamic t (f greeting) -> Event t tag ->

40+ m (Event t (f (ReqResult tag Text)))`

41+Calling that function with 'f' chosen to be list ('[]'), this call

42+`clientFun

43+(constDyn ["Greg", "Bernie"])

44+(constDyn ["Greetings", "Hey"])

45+trigger`

46+would produce four XhrRequests per 'trigger' event, one for each

47+combination of possible parameters, and one response event

48+would carry a list of the four responses.

49+A 'zip-wise' combination of the parameters can be chosen with

50+a different applicative wrapper: 'ZipList'

51+

52+- **Event tags**. A new type parameter lets users choose a payload

53+value to attach to outgoing requests at the point of triggering,

54+and which is embedded in the response, allowing individual

55+request-response pairs to be followed. The response's tag has been

56+added to each constructor `ReqResult tag a` type.

57+

58+- **Improved Unicode support** Thanks to Schell Scivally

59+(https://github.com/schell) for identifying and fixing a UTF-8

60+encoding bug!

README.md+114−28

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

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

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

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

6−

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

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

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

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

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

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

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

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

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

12## Example

16## Example

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

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

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

16```haskell

21```haskell

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

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

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

24 :<|> Raw

29 :<|> Raw

25```

30```

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

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

33+an `XhrRequest`.

29```haskell

35```haskell

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

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

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

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

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

35 (Proxy :: Proxy m)

41 (Proxy :: Proxy m)

42+ (Proxy :: Proxy ())

36 (constDyn (BasePath "/"))

43 (constDyn (BasePath "/"))

37```

44```

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

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

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

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

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

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

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

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

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

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

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

41```haskell

57```haskell

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

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

43 getint :: MonadWidget t m

59 getint :: MonadWidget t m

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

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

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

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

47 sayhi :: MonadWidget t m

63 sayhi :: MonadWidget t m

48 => Dynamic t (QParam Text)

64 => Dynamic t (QParam Text)

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

53 -- ^ Flag for capitalizing the response

69 -- ^ Flag for capitalizing the response

54 -> Event t ()

70 -> Event t ()

55 -- ^ Trigger the XHR Request

71 -- ^ Trigger the XHR Request

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

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

58 doubleit :: MonadWidget t m

74 doubleit :: MonadWidget t m

59 => Dynamic t (Either Text Double)

75 => Dynamic t (Either Text Double)

60 -> Event t ()

76 -> Event t ()

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

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

62```

78```

80+`ReqResult tag a` is defined in

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

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

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

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

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

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

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

66```haskell

88```haskell

67 -- ... continued ...

89 -- ... continued ...

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

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

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

80```

102```

103

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

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

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

106

84```haskell

107```haskell

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

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

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

102 display =<< holdDyn Nothing outputDouble

125 display =<< holdDyn Nothing outputDouble

103```

126```

104

127

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

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

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

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

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

132+the respective authors of these fabulous libraries.

106

133

107

134

108## Building the library and test server

135## Building the library and test server

109

136

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

138+ghcjs-compiled frontend

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

140+ghc-compiled backend

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

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

111−

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

112−

143+manages the frontend build as a dependency.

113−First build the library:

114

144

115```

145```

116−git submodule update --init --recursive

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

117−./build.sh

118```

147```

119

148

120−Then build the test server:

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

121

150

122```

151```

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

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

124```

153```

125

154

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

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

157+under the Network tab.

126

158

127−## Running the example site

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

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

128

161

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

130

162

163+## Tagging requests

164+

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

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

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

168+relationship by tagging the requests.

169+

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

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

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

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

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

175+

176+```haskell

177+ ...

178+ inp <- textInput def

179+

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

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

182+ go <- button "Double It"

183+

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

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

186+ Left _ -> Nothing

187+ Right a -> Just a

188+ )

189+

190+ -- Accumulate good responses in a map

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

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

193+ _ -> mempty

194+

195+ el "table" $ do

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

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

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

199+ ...

131```

200```

132−cd testserver

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

134−```

135

201

136−And simply browse to `localhost:8001`

202+## Simultaneous requests

203+

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

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

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

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

208+

209+```haskell

210+sayHi

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

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

213+ -> Dynamic t (f Bool)

214+ -> Event t tag

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

216+```

137

217

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

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

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

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

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

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

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

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

build.shdeleted−3

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

1−#!/usr/bin/env bash

2−

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

default.nixnew file+21

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

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

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

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

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

5+, transformers

6+}:

7+mkDerivation {

8+ pname = "servant-reflex";

9+ version = "0.3.6";

10+ src = ./.;

11+ isLibrary = true;

12+ isExecutable = true;

13+ libraryHaskellDepends = [

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

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

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

17+ text transformers

18+ ];

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

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

21+}

deps/http-api-datadeleted−1

Submodule changed.

deps/reflexdeleted−1

Submodule changed.

deps/reflex-domdeleted−1

Submodule changed.

deps/servantdeleted−1

Submodule changed.

deps/servant-snapdeleted−1

Submodule changed.

exec/API.hs+29−4

@@ -1,10 +1,32 @@

1−{-# LANGUAGE DataKinds #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE TypeOperators #-}

3+{-# LANGUAGE TypeOperators #-}

4module API where

5module API where

7+import Data.Aeson

8+import Data.Aeson.Types (typeMismatch)

6−import Data.Text (Text)

9+import Data.Text (Text)

7−import Servant.API

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+

9-- | API spec for server, client, and docs

31-- | API spec for server, client, and docs

10type API = "getunit" :> Get '[JSON] ()

32type API = "getunit" :> Get '[JSON] ()

@@ -16,6 +38,9 @@ type API = "getunit" :> Get '[JSON] ()

16 :<|> "double" :> ReqBody '[JSON] Double

38 :<|> "double" :> ReqBody '[JSON] Double

17 :> Post '[JSON] Double

39 :> Post '[JSON] Double

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

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

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

42+ :> Post '[JSON] Answer

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

19 :<|> Raw

44 :<|> Raw

21type GET = Get '[JSON] ()

46type GET = Get '[JSON] ()

exec/Example.hs+118−29

@@ -1,30 +1,82 @@

1+{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GADTs #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE RankNTypes #-}

5{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE RecursiveDo #-}

5{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

7module Main where

9module Main where

11+------------------------------------------------------------------------------

9import Data.Bool

12import Data.Bool

10import Data.Maybe

13import Data.Maybe

11import Control.Monad.Fix (MonadFix)

14import Control.Monad.Fix (MonadFix)

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

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

13import Data.Text (Text)

16import Data.Text (Text)

14import qualified Data.Text as T

17import qualified Data.Text as T

18+import qualified Data.Text.Encoding as T

19+import GHC.TypeLits

15import Servant.API

20import Servant.API

16−import Servant.Reflex

17import API

21import API

18import Data.Proxy

22import Data.Proxy

19import Text.Read (readMaybe)

23import Text.Read (readMaybe)

20−import Reflex.Dom

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

25+import Reflex.Dom (mainWidget)

26+------------------------------------------------------------------------------

27+import Servant.Reflex

28+import Servant.Reflex.Multi

29+

22api :: Proxy API

31api :: Proxy API

23api = Proxy

32api = Proxy

25main :: IO ()

34main :: IO ()

26−main = mainWidget run

35+main = mainWidget $ do

27−

36+ divClass "example-base" run

37+ divClass "example-multi" runMulti

38+

39+

40+runMulti :: forall t m. (SupportsServantReflex t m,

41+ DomBuilder t m,

42+ DomBuilderSpace m ~ GhcjsDomSpace,

43+ MonadFix m,

44+ PostBuild t m,

45+ MonadHold t m) => m ()

46+runMulti = do

47+ url <- baseUrlWidget

48+ el "br" blank

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

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

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

54+

55+ b <- button "Run dbl multi"

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

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

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

59+

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

61+ display lastInd

62+

63+ divClass "demo-group" $ do

64+ nms <- fmap (fmap T.words . value) $ divClass "" $ do

65+ text "Names"

66+ textInput def

67+ grts <- fmap (fmap T.words . value) $ divClass "" $ do

68+ text "Greetings"

69+ textInput def

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

71+ b <- button "Go"

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

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

74+

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

76+ fmap reqSuccess <$> r')

77+

78+

79+ return ()

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

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

30 DomBuilder t m,

82 DomBuilder t m,

@@ -32,35 +84,44 @@ run :: forall t m. (SupportsServantReflex t m,

32 MonadFix m,

84 MonadFix m,

33 PostBuild t m,

85 PostBuild t m,

34 MonadHold t m) => m ()

86 MonadHold t m) => m ()

35−run = do

87+run = mdo

89+ reqCount <- count $ leftmost

90+ [() <$ unitBtn, () <$ intBtn, () <$ sayHiClicks, () <$ dblBtn, () <$ mpGo]

37 -- Allow user to choose the url target for the request

91 -- Allow user to choose the url target for the request

38 -- (alternatively we could just `let url = constDyn (BasePath "/")`)

92 -- (alternatively we could just `let url = constDyn (BasePath "/")`)

39 url <- baseUrlWidget

93 url <- baseUrlWidget

40 el "br" (return ())

94 el "br" (return ())

41 dynText $ showBaseUrl <$> url

95 dynText $ showBaseUrl <$> url

96+

42 el "br" (return ())

97 el "br" (return ())

44 -- Name the computed API client functions

99 -- Name the computed API client functions

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

101+ return $ r & withCredentials .~ True

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

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

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

48− elClass "div" "demo-group" $ do

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

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

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

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

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

111

52− unitResponse <- getUnit unitBtn

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

53− intResponse :: Event t (ReqResult Int) <- getInt intBtn

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

114

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

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

116

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

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

58− leftmost [fmapMaybe response unitResponse

118+ leftmost [fmapMaybe response (unitResponse)

59− ,fmapMaybe response intResponse

119+ ,fmapMaybe response (intResponse)

60 ]

120 ]

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

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

122+ return (unitBtn, intBtn)

123

63− elClass "div" "demo-group" $ do

124+ sayHiClicks <- elClass "div" "demo-group" $ do

125

65 text "Name"

126 text "Name"

66 el "br" $ return ()

127 el "br" $ return ()

@@ -78,36 +139,64 @@ run = do

78 gusto <- fmap value $ divClass "gusto-input" $ checkbox False def

139 gusto <- fmap value $ divClass "gusto-input" $ checkbox False def

140

80 el "br" $ return ()

141 el "br" $ return ()

81− sayhiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"

142+ sayHiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"

82− let triggers = leftmost [sayhiClicks, () <$ updated inp]

143+ let triggers = leftmost [sayHiClicks, () <$ updated inp]

144

84− resp <- sayhi checkedName greetings gusto triggers

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

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

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

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

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

87− , fmapMaybe reqFailure resp])

148+ , fmapMaybe reqFailure (resp)])

149+ return sayHiClicks

150

89− elClass "div" "demo-group" $ do

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

90 text "A Double to double"

152 text "A Double to double"

91 el "br" $ return ()

153 el "br" $ return ()

92 dblinp <- fmap value $ divClass "double-input" $ textInput def

154 dblinp <- fmap value $ divClass "double-input" $ textInput def

93− dblBtn <- divClass "double-button" $ button "Double it"

155+ (dblBtn) <- divClass "double-button" $ button "Double it"

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

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

95− dblinp) dblBtn

157+ dblinp) (tag (current reqCount) dblBtn)

96− divClass "double-errors" $ dynText =<<

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

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

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

98 el "br" (return ())

160 el "br" (return ())

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

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

100 holdDyn "No number yet" (fmap tShow $

162 holdDyn "No number yet" (fmap tShow $

101− fmapMaybe reqSuccess dblResp)

163+ fmapMaybe reqSuccess (dblResp))

164+ return dblBtn

102

165

103− elClass "div" "demo-group" $ do

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

104 text "Multi-part path"

167 text "Multi-part path"

105 b <- value <$> checkbox False def

168 b <- value <$> checkbox False def

106 mpGo <- button "Test"

169 mpGo <- button "Test"

107− multiResp <- multi b mpGo

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

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

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

109 fmapMaybe reqSuccess $

172 fmapMaybe reqSuccess $

110− multiResp)

173+ (multiResp))

174+ return mpGo

175+

176+ return ()

177+

178+ el "br" $ return ()

179+

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

181+ text "JSON Unicode encoding test"

182+ txt <- value <$> textInput def

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

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

185+ rr <- qna dQ ev

186+ el "p" $

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

188+

189+ divClass "demo-group" $ do

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

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

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

193+ <$> fmap T.encodeUtf8 un

194+ <*> fmap T.encodeUtf8 pw

195+ b <- button "Get secret"

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

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

198+ display res

199+

111

200

112showXhrResponse :: XhrResponse -> Text

201showXhrResponse :: XhrResponse -> Text

113showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

202showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =

nix/nix.confnew file+3

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

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

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

3+trusted-users = travis

nix/reflex-platform.nixnew file+7

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

1+let

2+ rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;

3+in import (builtins.fetchTarball

4+ {

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

6+ sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;

7+ }) {}

nix/servant-snap.nixnew file+7

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

1+# Servant-snap is marked broken in nixpkgs

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

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

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

5+ rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";

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

7+}) {}

nix/testresults.nixnew file+17

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

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

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

4+ echo About to phantom

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

6+ sleep 3

7+ echo About to Server

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

9+ sleep 3

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

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

12+ echo About to testdrive

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

14+ echo Done

15+ trap "exit" INT TERM

16+ trap "kill 0" EXIT

17+ ''

nix/testserver.nixnew file+9

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

1+servant-reflex: self: super:

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

4+ postInstall = ''

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

6+ mkdir $out/static

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

8+ '';

9+})

overrides-ghc.nixdeleted−18

@@ -1,18 +0,0 @@

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

2−let

3− pkgs = import <nixpkgs> {};

4− c2n = reflex-platform.cabal2nixResult;

5−in reflex-platform.ghc.override {

6− overrides = self: super: {

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

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

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

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

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

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

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

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

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

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

17− };

18−}

overrides.nixdeleted−14

@@ -1,14 +0,0 @@

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

2−let

3−

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

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

6− cabal2nixResult = reflex-platform.cabal2nixResult;

7−

8−in

9−reflex-platform.ghcjs.override {

10− overrides = self: super: {

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

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

13− };

14−}

servant-reflex.cabal+36−18

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

1Name: servant-reflex

2−Version: 0.2

2+Version: 0.3.6

3−Synopsis: Servant reflex API generator

3+Synopsis: servant API generator for reflex apps

4−Description: Servant reflex API generator

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

5−License: AllRightsReserved

5+License: BSD3

6License-file: LICENSE.md

7Author: Greg Hale, Doug Beardsley

8Maintainer: imalsogreg@gmail.com

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

11Build-type: Simple

12Cabal-version: >=1.10

14+Flag Example

15+ description: Enable example

16+ default: False

17+

14library

18library

15 exposed-modules:

19 exposed-modules:

16− Servant.Reflex

17−

18− other-modules:

19 Servant.Common.BaseUrl

20 Servant.Common.BaseUrl

20 Servant.Common.Req

21 Servant.Common.Req

22+ Servant.Reflex

23+ Servant.Reflex.Multi

22 hs-source-dirs: src

25 hs-source-dirs: src

23 build-depends:

26 build-depends:

24− base >= 4.8 && < 4.10,

27+ base >= 4.8 && < 5,

25 bytestring >= 0.10 && < 0.11,

28 bytestring >= 0.10 && < 0.11,

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

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

27− containers >= 0.5.6 && < 0.6,

30+ containers >= 0.5.6 && < 0.7,

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

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

29− exceptions >= 0.8 && < 0.9,

32+ exceptions >= 0.8 && < 0.11,

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

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

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

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

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

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

36+ jsaddle >= 0.8 && < 0.10,

33 mtl >= 2.2.1 && < 2.3,

37 mtl >= 2.2.1 && < 2.3,

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

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

35− reflex >= 0.5 && < 0.6,

39+ reflex >= 0.5 && < 0.9,

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

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

37 safe >= 0.3.9 && < 0.4,

41 safe >= 0.3.9 && < 0.4,

38− servant >= 0.5 && < 0.9,

42+ servant >= 0.16 && < 0.19,

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

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

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

40 text >= 1.2 && < 1.3,

45 text >= 1.2 && < 1.3,

41 transformers >= 0.4 && < 0.6

46 transformers >= 0.4 && < 0.6

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

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

45 default-language: Haskell2010

50 default-language: Haskell2010

47executable example

52executable example

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

53+ if flag(Example)

54+ buildable: True

55+ else

56+ buildable: False

57+ build-depends:

58+ aeson,

59+ reflex,

60+ servant-reflex,

61+ base,

62+ scientific,

63+ servant,

64+ reflex-dom,

65+ reflex-dom-core,

66+ text

49 default-language: Haskell2010

67 default-language: Haskell2010

50 main-is: Example.hs

68 main-is: Example.hs

51 other-modules: API

69 other-modules: API

shell.nixnew file+1

@@ -0,0 +1 @@

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

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

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

1{-# LANGUAGE ConstraintKinds #-}

2+{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleContexts #-}

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

20) where

21) where

22import Control.Monad (join)

23import Control.Monad (join)

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

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

24import Control.Monad.Fix (MonadFix)

25import Control.Monad.Fix (MonadFix)

25import Data.Monoid ((<>))

26import Data.Monoid ((<>))

26import Data.Text (Text)

27import Data.Text (Text)

27import qualified Data.Text as T

28import qualified Data.Text as T

28import GHC.Generics

29import GHC.Generics

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

29import Reflex

31import Reflex

30−import Reflex.Dom

32+import Reflex.Dom.Core

31import Text.Read

33import Text.Read

33−

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

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

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

37+#else

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

39+#endif

36-- | URI scheme to use

41-- | URI scheme to use

37data Scheme =

42data Scheme =

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

84 where pathWidget :: m (Dynamic t BaseUrl)

89 where pathWidget :: m (Dynamic t BaseUrl)

85 pathWidget = do

90 pathWidget = do

86 text "Url base path"

91 text "Url base path"

87− t <- textInput (def {_textInputConfig_attributes =

92+ t <- inputElement def

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

89 return $ BasePath <$> value t

93 return $ BasePath <$> value t

90 fullUrlWidget :: m (Dynamic t BaseUrl)

94 fullUrlWidget :: m (Dynamic t BaseUrl)

91 fullUrlWidget = do

95 fullUrlWidget = do

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

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

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

97+ srv <- inputElement def

94 text ":"

98 text ":"

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

99+ prt <- inputElement def

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

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

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

101+ path <- inputElement def

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

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

src/Servant/Common/Req.hs+271−87

@@ -1,55 +1,119 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE CPP #-}

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TupleSections #-}

9{-# LANGUAGE TupleSections #-}

10+

9module Servant.Common.Req where

11module Servant.Common.Req where

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

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

12import Control.Applicative (liftA2, liftA3)

14import Control.Applicative (liftA2, liftA3)

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

16+import Control.Concurrent

17+import Control.Monad (join)

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

19+import Data.Bifunctor (first)

20+import qualified Data.ByteString.Builder as Builder

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

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

22+import Data.ByteString (ByteString)

14import qualified Data.Map as Map

23import qualified Data.Map as Map

15−import Data.Maybe (catMaybes)

24+import Data.Maybe (catMaybes, fromMaybe)

25+import Data.Functor.Compose

16import Data.Monoid ((<>))

26import Data.Monoid ((<>))

17import Data.Proxy (Proxy(..))

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

18import Data.Text (Text)

28import Data.Text (Text)

19import qualified Data.Text as T

29import qualified Data.Text as T

20import qualified Data.Text.Encoding as TE

30import qualified Data.Text.Encoding as TE

31+import Data.Traversable (forM)

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

33+import qualified Network.URI as N

21−import Reflex.Dom

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

22−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl, SupportsServantReflex)

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

36+ SupportsServantReflex)

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

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

24import Web.HttpApiData (ToHttpApiData(..))

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

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

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

26import Servant.API.BasicAuth

40import Servant.API.BasicAuth

29−

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

44+-- | The result of a request event

45+data ReqResult tag a

30−data ReqResult a = ResponseSuccess a XhrResponse

46+ = ResponseSuccess tag a XhrResponse

47+ -- ^ The succesfully decoded response from a request tagged with 'tag'

31− | ResponseFailure Text XhrResponse

48+ | ResponseFailure tag Text XhrResponse

49+ -- ^ The failure response, which may have failed decoding or had

50+ -- a non-successful response code

32− | RequestFailure Text

51+ | RequestFailure tag Text

33−

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

34−instance Functor ReqResult where

53+ deriving (Functor)

35− fmap f (ResponseSuccess a xhr) = ResponseSuccess (f a) xhr

54+

36− fmap _ (ResponseFailure r x) = ResponseFailure r x

55+data ClientOptions = ClientOptions

37− fmap _ (RequestFailure r) = RequestFailure r

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

38−

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'

72+

73+------------------------------------------------------------------------------

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

75+-- ignore the error case. For example:

76+-- >> goodResponses <- fmapMaybe reqSuccess <$> clientFun triggers

77+reqSuccess :: ReqResult tag a -> Maybe a

78+reqSuccess (ResponseSuccess _ x _) = Just x

79+reqSuccess _ = Nothing

80+

81+

82+------------------------------------------------------------------------------

83+-- | Simple filter/accessor like 'reqSuccess', but keeping the request tag

84+reqSuccess' :: ReqResult tag a -> Maybe (tag,a)

85+reqSuccess' (ResponseSuccess tag x _) = Just (tag,x)

86+reqSuccess' _ = Nothing

87+

88+

89+------------------------------------------------------------------------------

90+-- | Simple filter/accessor for any failure case

39−reqSuccess :: ReqResult a -> Maybe a

91+reqFailure :: ReqResult tag a -> Maybe Text

40−reqSuccess (ResponseSuccess x _) = Just x

92+reqFailure (ResponseFailure _ s _) = Just s

93+reqFailure (RequestFailure _ s) = Just s

41−reqSuccess _ = Nothing

94+reqFailure _ = Nothing

42−

95+

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

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

43−reqFailure :: ReqResult a -> Maybe Text

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

44−reqFailure (ResponseFailure s _) = Just s

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

45−reqFailure (RequestFailure s) = Just s

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

46−reqFailure _ = Nothing

101+reqFailure' _ = Nothing

47−

102+

103+

104+------------------------------------------------------------------------------

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

48−response :: ReqResult a -> Maybe XhrResponse

106+response :: ReqResult tag a -> Maybe XhrResponse

49−response (ResponseSuccess _ x) = Just x

107+response (ResponseSuccess _ _ x) = Just x

50−response (ResponseFailure _ x) = Just x

108+response (ResponseFailure _ _ x) = Just x

51−response _ = Nothing

109+response _ = Nothing

52−

110+

111+------------------------------------------------------------------------------

112+-- | Retrieve response tag

113+reqTag :: ReqResult tag a -> tag

114+reqTag (ResponseSuccess tag _ _) = tag

115+reqTag (ResponseFailure tag _ _) = tag

116+reqTag (RequestFailure tag _ ) = tag

117

54-------------------------------------------------------------------------------

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

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

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

@@ -62,11 +126,13 @@ data QParam a = QParamSome a

62 | QParamInvalid Text

126 | QParamInvalid Text

63 -- ^ Indication that your validation failed (the request isn't valid)

127 -- ^ Indication that your validation failed (the request isn't valid)

128

129+

65qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)

130qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)

66qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)

131qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)

67qParamToQueryPart QNone = Right Nothing

132qParamToQueryPart QNone = Right Nothing

68qParamToQueryPart (QParamInvalid e) = Left e

133qParamToQueryPart (QParamInvalid e) = Left e

134

135+

70data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))

136data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))

71 | QueryPartParams (Dynamic t [Text])

137 | QueryPartParams (Dynamic t [Text])

72 | QueryPartFlag (Dynamic t Bool)

138 | QueryPartFlag (Dynamic t Bool)

@@ -96,20 +162,13 @@ addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) ->

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

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

163

164

99−-- * performing requests

165+reqToReflexRequest

100−

166+ :: forall t. Reflex t

101−displayHttpRequest :: Text -> Text

102−displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"

103−

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

105−performRequest :: forall t m.(SupportsServantReflex t m)

106− => Text

167+ => Text

107− -> Req t

108− -> Dynamic t BaseUrl

168+ -> Dynamic t BaseUrl

109− -> Event t ()

169+ -> Req t

110− -> m (Event t XhrResponse, Event t Text)

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

111−performRequest reqMeth req reqHost trigger = do

171+reqToReflexRequest reqMeth reqHost req =

112−

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

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

114 t = sequence $ reverse $ reqPathParts req

173 t = sequence $ reverse $ reqPathParts req

115

174

@@ -120,18 +179,22 @@ performRequest reqMeth req reqHost trigger = do

120 urlParts = fmap sequence t

179 urlParts = fmap sequence t

121

180

122 urlPath :: Dynamic t (Either Text Text)

181 urlPath :: Dynamic t (Either Text Text)

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

182+ urlPath = (fmap.fmap)

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

184+ urlParts

124

185

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

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

126 queryPartString (pName, qp) = case qp of

187 queryPartString (pName, qp) = case qp of

127 QueryPartParam p -> ffor p $ \case

188 QueryPartParam p -> ffor p $ \case

128 Left e -> Just (Left e)

189 Left e -> Just (Left e)

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

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

130 Right Nothing -> Nothing

191 Right Nothing -> Nothing

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

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

132 if null pStrings

193 if null pStrings

133 then Nothing

194 then Nothing

195+ else Just . Right

196+ . T.intercalate "&"

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

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

135 QueryPartFlag fl -> ffor fl $ \case

198 QueryPartFlag fl -> ffor fl $ \case

136 True -> Just $ Right pName

199 True -> Just $ Right pName

137 False -> Nothing

200 False -> Nothing

@@ -142,8 +205,8 @@ performRequest reqMeth req reqHost trigger = do

142 queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Dynamic t (Either Text [Text])

205 queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Dynamic t (Either Text [Text])

143 queryString :: Dynamic t (Either Text Text) =

206 queryString :: Dynamic t (Either Text Text) =

144 ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs

207 ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs

145−-- ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") (sequence qs)

146− xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q) baseUrl urlPath queryString

208+ xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q)

209+ baseUrl urlPath queryString

147 where

210 where

148 (</>) :: Text -> Text -> Text

211 (</>) :: Text -> Text -> Text

149 x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y

212 x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y

@@ -166,10 +229,10 @@ performRequest reqMeth req reqHost trigger = do

166 Right $ XhrRequestConfig

229 Right $ XhrRequestConfig

167 { _xhrRequestConfig_sendData = bytesToPayload bBytes

230 { _xhrRequestConfig_sendData = bytesToPayload bBytes

168 , _xhrRequestConfig_headers =

231 , _xhrRequestConfig_headers =

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

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

170 , _xhrRequestConfig_user = Nothing

233 , _xhrRequestConfig_user = Nothing

171 , _xhrRequestConfig_password = Nothing

234 , _xhrRequestConfig_password = Nothing

172− , _xhrRequestConfig_responseType = Nothing

235+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

173 , _xhrRequestConfig_withCredentials = False

236 , _xhrRequestConfig_withCredentials = False

174 , _xhrRequestConfig_responseHeaders = def

237 , _xhrRequestConfig_responseHeaders = def

175 }

238 }

@@ -181,8 +244,8 @@ performRequest reqMeth req reqHost trigger = do

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

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

182 , _xhrRequestConfig_user = Nothing

245 , _xhrRequestConfig_user = Nothing

183 , _xhrRequestConfig_password = Nothing

246 , _xhrRequestConfig_password = Nothing

184− , _xhrRequestConfig_responseType = Nothing

247+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer

185− , _xhrRequestConfig_sendData = ""

248+ , _xhrRequestConfig_sendData = mempty

186 , _xhrRequestConfig_withCredentials = False

249 , _xhrRequestConfig_withCredentials = False

187 }

250 }

188 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

251 Just rBody -> liftA2 mkConfigBody xhrHeaders rBody

@@ -202,47 +265,168 @@ performRequest reqMeth req reqHost trigger = do

202

265

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

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

204

267

205− let reqs = tagPromptlyDyn xhrReq trigger

268+ in xhrReq

206− okReqs = fmapMaybe (either (const Nothing) Just) reqs

207− badReqs = fmapMaybe (either Just (const Nothing)) reqs

208

269

209− resps <- performRequestAsync okReqs

270+-- * performing requests

210

271

211− return (resps, badReqs)

272+displayHttpRequest :: Text -> Text

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

212

274

213−#ifdef ghcjs_HOST_OS

275+-- | This function performs the request

214−type XhrPayload = String

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

215−bytesToPayload :: BL.ByteString -> XhrPayload

277+ => Text

216−bytesToPayload = BL.unpack

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

217−#else

279+ -> Dynamic t BaseUrl

218−type XhrPayload = T.Text

280+ -> ClientOptions

219−bytesToPayload :: BL.ByteString -> XhrPayload

281+ -> Event t tag

220−bytesToPayload = T.pack . BL.unpack

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

283+performRequests reqMeth rs reqHost opts trigger = do

284+ let xhrReqs =

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

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

287+

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

289+ reqs = attachPromptlyDynWith

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

291+

292+ resps <- performSomeRequestsAsync opts reqs

293+ return $ getCompose <$> resps

294+

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

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

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

298+performSomeRequestsAsync

299+ :: (MonadIO (Performable m),

300+ MonadJSM (Performable m),

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

302+ HasWebView (Performable m),

221#endif

303#endif

304+ PerformEvent t m,

305+ TriggerEvent t m,

306+ Traversable f,

307+ IsXhrPayload a,

308+ Show a

309+ )

310+ => ClientOptions

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

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

313+performSomeRequestsAsync opts =

314+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return

315+

316+

317+------------------------------------------------------------------------------

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

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

320+performSomeRequestsAsync'

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

322+ => ClientOptions

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

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

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

326+ rs <- hrs

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

328+ Left e -> do

329+ resp <- liftIO $ newMVar (Left e)

330+ return resp

331+ Right r' -> do

332+ resp <- liftIO newEmptyMVar

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

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

335+ return resp

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

337+ return ()

338+

339+

340+

341+type XhrPayload = ByteString

342+bytesToPayload :: BL.ByteString -> XhrPayload

343+bytesToPayload = BL.toStrict

344+

345+

346+performRequestsCT

347+ :: (SupportsServantReflex t m,

348+ MimeUnrender ct a, Traversable f)

349+ => Proxy ct

350+ -> Text

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

352+ -> Dynamic t BaseUrl

353+ -> ClientOptions

354+ -> Event t tag

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

356+performRequestsCT ct reqMeth reqs reqHost opts trigger = do

357+ resps <- performRequests reqMeth reqs reqHost opts trigger

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

359+ first T.pack .

360+ mimeUnrender ct $

361+ BL.fromStrict x

362+ decodeResp _ = Left "No body"

363+ return $ fmap

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

365+ Left e -> RequestFailure t e

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

367+ )

368+ resps

369+

370+

371+performRequestsNoBody

372+ :: (SupportsServantReflex t m,

373+ Traversable f)

374+ => Text

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

376+ -> Dynamic t BaseUrl

377+ -> ClientOptions

378+ -> Event t tag

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

380+performRequestsNoBody reqMeth reqs reqHost opts trigger = do

381+ resps <- performRequests reqMeth reqs reqHost opts trigger

382+ let decodeResp = const $ Right NoContent

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

384+ Left e -> RequestFailure tag e

385+ Right g -> evalResponse decodeResp (tag,g)

386+

387+

388+------------------------------------------------------------------------------

389+evalResponse

390+ :: (XhrResponse -> Either Text a)

391+ -> (tag, XhrResponse)

392+ -> ReqResult tag a

393+evalResponse decode (tag, xhr) =

394+ let status = _xhrResponse_status xhr

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

396+ errMsg = fromMaybe

397+ ("Empty response with error code " <>

398+ T.pack (show $ _xhrResponse_status xhr))

399+ (_xhrResponse_responseText xhr)

400+ respPayld = if okStatus

401+ then either

402+ (\e -> ResponseFailure tag e xhr)

403+ (\v -> ResponseSuccess tag v xhr)

404+ (decode xhr)

405+ else ResponseFailure tag errMsg xhr

406+ in respPayld

407+

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

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

410+-- response 'Event's,

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

412+fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess

413+

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

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

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

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

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

222

419

223−performRequestNoBody :: forall t m .(SupportsServantReflex t m)

224− => Text

225− -> Req t

226− -> Dynamic t BaseUrl

227− -> Event t () -> m (Event t (ReqResult NoContent))

228−performRequestNoBody reqMeth req reqHost trigger = do

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

230− return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]

231−

232−

233−performRequestCT :: (SupportsServantReflex t m,

234− MimeUnrender ct a)

235− => Proxy ct -> Text -> Req t -> Dynamic t BaseUrl

236− -> Event t () -> m (Event t (ReqResult a))

237−performRequestCT ct reqMeth req reqHost trigger = do

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

239− let decodes = ffor resp $ \xhr ->

240− ((mimeUnrender ct . BL.fromStrict . TE.encodeUtf8)

241− =<< note "No body text" (_xhrResponse_responseText xhr), xhr)

242− reqs = ffor decodes $ \case

243− (Right a, r) -> ResponseSuccess a r

244− (Left e, r) -> ResponseFailure (T.pack e) r

245− return $ leftmost [reqs, fmap RequestFailure badReq]

246

420

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

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

248note e = maybe (Left e) Right

422note e = maybe (Left e) Right

423+

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

425+fmapL _ (Right a) = Right a

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

427+

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

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

430+

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

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

src/Servant/Reflex.hs+318−188

@@ -1,16 +1,23 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE InstanceSigs #-}

7+{-# LANGUAGE InstanceSigs #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

6−{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE OverloadedStrings #-}

7−{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE Rank2Types #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TupleSections #-}

13+{-# LANGUAGE TupleSections #-}

10−{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE TypeFamilies #-}

11−{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE TypeOperators #-}

12−{-# LANGUAGE UndecidableInstances #-}

16+{-# LANGUAGE UndecidableInstances #-}

13−{-# LANGUAGE MultiParamTypeClasses #-}

17+

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

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

20+#endif

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

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

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

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

@@ -18,49 +25,71 @@

18-- API.

25-- API.

19module Servant.Reflex

26module Servant.Reflex

20 ( client

27 ( client

21− , HasClient(..)

28+ , clientWithOpts

29+ , clientWithOptsAndResultHandler

30+ , clientWithRoute

31+ , clientWithRouteAndResultHandler

32+ , BuildHeaderKeysTo(..)

33+ , toHeaders

34+ , HasClient

35+ , Client

22 , module Servant.Common.Req

36 , module Servant.Common.Req

23 , module Servant.Common.BaseUrl

37 , module Servant.Common.BaseUrl

24 ) where

38 ) where

26−-------------------------------------------------------------------------------

40+------------------------------------------------------------------------------

27import Control.Applicative

41import Control.Applicative

42+import qualified Data.CaseInsensitive as CI

43+import Data.Functor.Identity

44+import qualified Data.Map as Map

28import Data.Monoid ((<>))

45import Data.Monoid ((<>))

29−import qualified Data.Set as Set

30−import qualified Data.Text.Encoding as E

31−import Data.CaseInsensitive (mk)

32import Data.Proxy (Proxy (..))

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

33−import qualified Data.Map as Map

47+import qualified Data.Set as Set

34import Data.Text (Text)

48import Data.Text (Text)

35import qualified Data.Text as T

49import qualified Data.Text as T

50+import qualified Data.Text.Encoding as E

51+import GHC.Exts (Constraint)

36import GHC.TypeLits (KnownSymbol, symbolVal)

52import GHC.TypeLits (KnownSymbol, symbolVal)

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

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

38− BasicAuthData, BuildHeadersTo(..),

54+ BasicAuthData, BuildHeadersTo (..),

39− Capture, contentType, Header,

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

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

56+ HttpVersion, IsSecure,

41− MimeRender(..), MimeUnrender,

57+ MimeRender (..), MimeUnrender,

42− NoContent, QueryFlag, QueryParam,

58+ NoContent, QueryFlag, QueryParam',

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

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

44 RemoteHost, ReqBody,

60 RemoteHost, ReqBody,

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

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

62+ contentType)

63+import Servant.API.Description (Summary)

64+import qualified Servant.Auth as Auth

65+

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

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

68+ XhrResponseHeaders (..),

69+ attachPromptlyDynWith, constDyn, ffor,

70+ fmapMaybe, leftmost,

71+ performRequestsAsync)

72+------------------------------------------------------------------------------

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

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

47 showBaseUrl,

74 showBaseUrl,

48 SupportsServantReflex)

75 SupportsServantReflex)

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

77+ defaultClientOptions,

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

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

50 QueryPart(..), addHeader, authData,

79 QueryPart(..), addHeader, authData,

51− defReq, prependToPathParts,

80+ defReq, evalResponse, prependToPathParts,

52− performRequestCT,

81+ -- performRequestCT,

82+ performRequestsCT,

53− performRequestNoBody,

83+ -- performRequestNoBody,

84+ performRequestsNoBody,

85+ performSomeRequestsAsync,

54 qParamToQueryPart, reqBody,

86 qParamToQueryPart, reqBody,

55 reqSuccess, reqFailure,

87 reqSuccess, reqFailure,

56− reqMethod, respHeaders, response,

88+ reqMethod, respHeaders,

89+ response,

90+ reqTag,

57− qParams)

91+ qParams, withCredentials)

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

92+

59− XhrRequest(..),

60− XhrResponseHeaders(..),

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

62− leftmost, performRequestAsync,

63− tagPromptlyDyn )

65-- * Accessing APIs as a Client

94-- * Accessing APIs as a Client

@@ -72,28 +101,78 @@ import Reflex.Dom (Dynamic, Event, Reflex,

72-- > myApi :: Proxy MyApi

101-- > myApi :: Proxy MyApi

73-- > myApi = Proxy

102-- > myApi = Proxy

74-- >

103-- >

75−-- > getAllBooks :: Event t () -> m (Event t (Either XhrError ((),[Book])))

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

76−-- > postNewBook :: Dynamic t (Maybe Book) -> Event t ()

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

77−-- -> m (Event t (Either XhrError (Book,Book)))

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

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

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

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

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

109+client

110+ :: (HasClient t m layout tag)

111+ => Proxy layout

112+ -> Proxy m

113+ -> Proxy tag

114+ -> Dynamic t BaseUrl

115+ -> Client t m layout tag

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

117+

118+clientWithOpts

80−client :: (HasClient t m layout)

119+ :: (HasClient t m layout tag)

120+ => Proxy layout

121+ -> Proxy m

122+ -> Proxy tag

81− => Proxy layout -> Proxy m -> Dynamic t BaseUrl -> Client t m layout

123+ -> Dynamic t BaseUrl

124+ -> ClientOptions

125+ -> Client t m layout tag

82−client p q baseurl = clientWithRoute p q defReq baseurl

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

127+

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

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

130+-- across call sites.

131+clientWithOptsAndResultHandler

132+ :: (HasClient t m layout tag)

133+ => Proxy layout

134+ -> Proxy m

135+ -> Proxy tag

136+ -> Dynamic t BaseUrl

137+ -> ClientOptions

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

139+ -> Client t m layout tag

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

141+

142

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

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

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

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

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

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

87−class HasClient t m layout where

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

88− type Client t m layout :: *

147+ type Client t m layout tag :: *

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

148+ clientWithRoute

90−

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+

168+

169+instance (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

171+

172+ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =

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

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

175

92−instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where

93− type Client t m (a :<|> b) = Client t m a :<|> Client t m b

94− clientWithRoute Proxy q req baseurl =

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

96− clientWithRoute (Proxy :: Proxy b) q req baseurl

176

98-- Capture. Example:

177-- Capture. Example:

99-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book

178-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book

@@ -103,67 +182,72 @@ instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where

103-- > getBook :: SupportsServantReflex t m

182-- > getBook :: SupportsServantReflex t m

104-- => Dynamic t BaseUrl

183-- => Dynamic t BaseUrl

105-- -> Dynamic t (Maybe Text)

184-- -> Dynamic t (Maybe Text)

106−-- -> Event t ()

185+-- -> Event t l

107−-- -> m (Event t (Either XhrError (Text, Book)))

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

108-- > getBook = client myApi (constDyn host)

187-- > getBook = client myApi (constDyn host)

109−instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout)

110− => HasClient t m (Capture capture a :> sublayout) where

111

188

189+instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout tag)

112− type Client t m (Capture capture a :> sublayout) =

190+ => HasClient t m (Capture capture a :> sublayout) tag where

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

114

191

115− clientWithRoute Proxy q req baseurl val =

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

116− clientWithRoute (Proxy :: Proxy sublayout)

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

117− q

118− (prependToPathParts p req)

119− baseurl

120

194

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

196+ clientWithRouteAndResultHandler

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

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

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

122

199

200+

123-- VERB (Returning content) --

201-- VERB (Returning content) --

124instance {-# OVERLAPPABLE #-}

202instance {-# OVERLAPPABLE #-}

125 -- Note [Non-Empty Content Types]

203 -- Note [Non-Empty Content Types]

126 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m

204 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m

127− ) => HasClient t m (Verb method status cts' a) where

205+ ) => HasClient t m (Verb method status cts' a) tag where

128− type Client t m (Verb method status cts' a) =

206+ type Client t m (Verb method status cts' a) tag =

129− Event t () -> m (Event t (ReqResult a))

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

130 -- TODO how to access input types here?

208 -- TODO how to access input types here?

131 -- ExceptT ServantError IO a

209 -- ExceptT ServantError IO a

132− clientWithRoute Proxy _ req baseurl =

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

133− performRequestCT (Proxy :: Proxy ct) method req' baseurl

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

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

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

135 req' = req { reqMethod = method }

213 req' = req { reqMethod = method }

136

214

215+

137-- -- VERB (No content) --

216-- -- VERB (No content) --

138instance {-# OVERLAPPING #-}

217instance {-# OVERLAPPING #-}

139 (ReflectMethod method, SupportsServantReflex t m) =>

218 (ReflectMethod method, SupportsServantReflex t m) =>

140− HasClient t m (Verb method status cts NoContent) where

219+ HasClient t m (Verb method status cts NoContent) tag where

141− type Client t m (Verb method status cts NoContent) =

220+ type Client t m (Verb method status cts NoContent) tag =

142− Event t () -> m (Event t (ReqResult NoContent))

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

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

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

144 -- ExceptT ServantError IO NoContent

223 -- ExceptT ServantError IO NoContent

145− clientWithRoute Proxy _ req baseurl =

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

146− performRequestNoBody method req baseurl

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

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

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

148

227

228+

149−toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)

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

150toHeaders r =

230toHeaders r =

151− let toBS = E.encodeUtf8

152− hdrs = maybe []

231+ let hdrs = maybe []

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

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

154 (Map.toList $ _xhrResponse_headers xhr))

233 (Map.toList $ _xhrResponse_headers xhr))

155 (response r)

234 (response r)

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

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

157

236

237+

158class BuildHeaderKeysTo hs where

238class BuildHeaderKeysTo hs where

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

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

160

240

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

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

162 where buildHeaderKeysTo _ = []

242 where buildHeaderKeysTo _ = []

163

243

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

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

165− => BuildHeaderKeysTo '[(Header h v) ': xs] where

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

246+ buildHeaderKeysTo _ =

247+ let

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

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

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

250+

167

251

168-- HEADERS Verb (Content) --

252-- HEADERS Verb (Content) --

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

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

@@ -175,33 +259,35 @@ instance {-# OVERLAPPABLE #-}

175 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

259 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

176 ReflectMethod method, cts' ~ (ct ': cts),

260 ReflectMethod method, cts' ~ (ct ': cts),

177 SupportsServantReflex t m

261 SupportsServantReflex t m

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

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

179− type Client t m (Verb method status cts' (Headers ls a)) =

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

180− Event t () -> m (Event t (ReqResult (Headers ls a)))

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

181− clientWithRoute Proxy _ req baseurl = do

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

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

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

183− resp <- performRequestCT (Proxy :: Proxy ct) method req' baseurl

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

184− return $ (fmap . fmap) toHeaders resp

268+ wrap $ toHeaders <$> resp

185 where req' = req { respHeaders =

269 where req' = req { respHeaders =

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

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

187 }

271 }

188

272

273+

189-- HEADERS Verb (No content) --

274-- HEADERS Verb (No content) --

190instance {-# OVERLAPPABLE #-}

275instance {-# OVERLAPPABLE #-}

191 ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,

276 ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,

192 SupportsServantReflex t m

277 SupportsServantReflex t m

193− ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where

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

194− type Client t m (Verb method status cts (Headers ls NoContent))

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

195− = Event t () -> m (Event t (ReqResult (Headers ls NoContent)))

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

196− clientWithRoute Proxy _ req baseurl = do

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

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

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

198− resp <- performRequestNoBody method req' baseurl

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

199− return $ (fmap . fmap) toHeaders resp

284+ wrap $ toHeaders <$> resp

200 where req' = req {respHeaders =

285 where req' = req {respHeaders =

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

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

202 }

287 }

203

288

204

289

290+

205-- HEADER

291-- HEADER

206-- > newtype Referer = Referer { referrer :: Text }

292-- > newtype Referer = Referer { referrer :: Text }

207-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)

293-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)

@@ -216,29 +302,45 @@ instance {-# OVERLAPPABLE #-}

216-- > -- then you can just use "viewRefer" to query that endpoint

302-- > -- then you can just use "viewRefer" to query that endpoint

217-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments

303-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments

218instance (KnownSymbol sym, ToHttpApiData a,

304instance (KnownSymbol sym, ToHttpApiData a,

219− HasClient t m sublayout, SupportsServantReflex t m)

305+ HasClient t m sublayout tag, SupportsServantReflex t m)

220− => HasClient t m (Header sym a :> sublayout) where

306+ => HasClient t m (Header sym a :> sublayout) tag where

221

307

222− type Client t m (Header sym a :> sublayout) =

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

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

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

224

310

225− clientWithRoute Proxy q req baseurl eVal =

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

312+ clientWithRouteAndResultHandler

226− clientWithRoute (Proxy :: Proxy sublayout)

313+ (Proxy :: Proxy sublayout) q t

227− q

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

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

229− baseurl

315+ baseurl opts wrap

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

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

231

317

318+

319+

320+

232-- | Using a 'HttpVersion' combinator in your API doesn't affect the client

321-- | Using a 'HttpVersion' combinator in your API doesn't affect the client

233-- functions.

322-- functions.

234−instance HasClient t m sublayout

323+instance HasClient t m sublayout tag

235− => HasClient t m (HttpVersion :> sublayout) where

324+ => HasClient t m (HttpVersion :> sublayout) tag where

325+

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

327+ Client t m sublayout tag

328+

329+ clientWithRouteAndResultHandler Proxy =

330+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

331+

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

333+-- functions.

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

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

336+

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

338+ Client t m sublayout tag

339+

340+ clientWithRouteAndResultHandler Proxy =

341+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)

236

342

237− type Client t m (HttpVersion :> sublayout) =

238− Client t m sublayout

239

343

240− clientWithRoute Proxy q =

241− clientWithRoute (Proxy :: Proxy sublayout) q

242

344

243

345

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

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

@@ -267,16 +369,16 @@ instance HasClient t m sublayout

267-- > -- then you can just use "getBooksBy" to query that endpoint.

369-- > -- then you can just use "getBooksBy" to query that endpoint.

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

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

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

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

270−instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

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

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

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

272

374

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

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

274− Dynamic t (QParam a) -> Client t m sublayout

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

275

377

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

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

277− clientWithRoute Proxy q req baseurl mparam =

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

278− clientWithRoute (Proxy :: Proxy sublayout) q

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

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

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

280

382

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

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

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

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

@@ -284,6 +386,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

284 p prm = QueryPartParam $ fmap qParamToQueryPart prm -- (fmap . fmap) (unpack . toQueryParam) prm

386 p prm = QueryPartParam $ fmap qParamToQueryPart prm -- (fmap . fmap) (unpack . toQueryParam) prm

285 paramPair = (T.pack pname, p mparam)

387 paramPair = (T.pack pname, p mparam)

286

388

389+

390+

287-- | If you use a 'QueryParams' in one of your endpoints in your API,

391-- | If you use a 'QueryParams' in one of your endpoints in your API,

288-- the corresponding querying function will automatically take

392-- the corresponding querying function will automatically take

289-- an additional argument, a list of values of the type specified

393-- an additional argument, a list of values of the type specified

@@ -312,21 +416,22 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

312-- > -- 'getBooksBy []' for all books

416-- > -- 'getBooksBy []' for all books

313-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'

417-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'

314-- > -- to get all books by Asimov and Heinlein

418-- > -- to get all books by Asimov and Heinlein

315−instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

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

316− => HasClient t m (QueryParams sym a :> sublayout) where

420+ => HasClient t m (QueryParams sym a :> sublayout) tag where

317

421

318− type Client t m (QueryParams sym a :> sublayout) =

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

319− Dynamic t [a] -> Client t m sublayout

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

320

424

321− clientWithRoute Proxy q req baseurl paramlist =

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

322− clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl

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

323

427

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

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

325 pname = symbolVal (Proxy :: Proxy sym)

429 pname = symbolVal (Proxy :: Proxy sym)

326− params' = QueryPartParams $ (fmap . fmap) (toQueryParam)

430+ params' = QueryPartParams $ (fmap . fmap) toQueryParam

327 paramlist

431 paramlist

328

432

329

433

434+

330-- | If you use a 'QueryFlag' in one of your endpoints in your API,

435-- | If you use a 'QueryFlag' in one of your endpoints in your API,

331-- the corresponding querying function will automatically take

436-- the corresponding querying function will automatically take

332-- an additional 'Bool' argument.

437-- an additional 'Bool' argument.

@@ -351,49 +456,42 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)

351-- > -- 'getBooksBy True' to only get _already published_ books

456-- > -- 'getBooksBy True' to only get _already published_ books

352

457

353-- TODO Bring back

458-- TODO Bring back

354−instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)

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

355− => HasClient t m (QueryFlag sym :> sublayout) where

460+ => HasClient t m (QueryFlag sym :> sublayout) tag where

356

461

357− type Client t m (QueryFlag sym :> sublayout) =

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

358− Dynamic t Bool -> Client t m sublayout

463+ Dynamic t Bool -> Client t m sublayout tag

359

464

360− clientWithRoute Proxy q req baseurl flag =

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

361− clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl

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

362

467

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

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

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

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

365 pName = symbolVal (Proxy :: Proxy sym)

470 pName = symbolVal (Proxy :: Proxy sym)

366

471

367

472

368−-- | Pick a 'Method' and specify where the server you want to query is. You get

473+

369−-- back the full `Response`.

474+-- | Send a raw 'XhrRequest ()' directly to 'baseurl'

370−-- TODO redo

371−instance SupportsServantReflex t m => HasClient t m Raw where

475+instance SupportsServantReflex t m => HasClient t m Raw tag where

372− type Client t m Raw = Dynamic t (Either Text (XhrRequest ()))

476+ type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))

373− -> Event t ()

477+ -> Event t tag

374− -> m (Event t (ReqResult ()))

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

375−

479+

376− -- clientWithRoute :: Proxy Raw -> Proxy m -> Req -> BaseUrl -> Client t m Raw

377− clientWithRoute _ _ _ baseurl xhrs triggers = do

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

481+

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

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

379− Left e -> Left e

483+ Left e -> Left e

380− Right jx -> Right $ jx {_xhrRequest_url = path

484+ Right jx -> Right $ jx { _xhrRequest_url = path <> _xhrRequest_url jx }

381− <> _xhrRequest_url jx})

382− xhrs

383− (showBaseUrl <$> baseurl)

485+ ) xhrs (showBaseUrl <$> baseurl)

384− reqs = tagPromptlyDyn xhrs' triggers

486+ xhrs'' = attachPromptlyDynWith (flip (,)) xhrs' triggers :: Event t (tag, Either Text (XhrRequest ()))

385− okReq = fmapMaybe hush reqs

487+ badReq = fmapMaybe (\(t,x) -> either (Just . (t,)) (const Nothing) x) xhrs'' :: Event t (tag, Text)

386− badReq = fmapMaybe tattle reqs

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

387− resps <- performRequestAsync okReq

489+

388− return $ leftmost [fmap (ResponseSuccess () ) resps

490+ resps <- performRequestsAsync okReq

389− ,fmap RequestFailure badReq]

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

390−

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

391−

493+ ]

392−hush :: Either e a -> Maybe a

494+

393−hush = either (const Nothing) Just

394−

395−tattle :: Either e a -> Maybe e

396−tattle = either Just (const Nothing)

397

495

398-- | If you use a 'ReqBody' in one of your endpoints in your API,

496-- | If you use a 'ReqBody' in one of your endpoints in your API,

399-- the corresponding querying function will automatically take

497-- the corresponding querying function will automatically take

@@ -415,14 +513,14 @@ tattle = either Just (const Nothing)

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

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

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

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

417

515

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

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

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

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

420

518

421− type Client t m (ReqBody (ct ': cts) a :> sublayout) =

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

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

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

423

521

424− clientWithRoute Proxy q req baseurl body =

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

425− clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl

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

426 where req' = req { reqBody = bodyBytesCT }

524 where req' = req { reqBody = bodyBytesCT }

427 ctProxy = Proxy :: Proxy ct

525 ctProxy = Proxy :: Proxy ct

428 ctString = T.pack $ show $ contentType ctProxy

526 ctString = T.pack $ show $ contentType ctProxy

@@ -430,43 +528,49 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)

430 (\b -> (mimeRender ctProxy b, ctString))

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

431 body

529 body

432

530

531+

532+

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

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

434−instance (KnownSymbol path, HasClient t m sublayout, Reflex t) => HasClient t m (path :> sublayout) where

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

435− type Client t m (path :> sublayout) = Client t m sublayout

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

436

536

437− clientWithRoute Proxy q req baseurl =

537+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =

438− clientWithRoute (Proxy :: Proxy sublayout) q

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

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

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

440− baseurl

441

540

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

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

443

542

444−instance HasClient t m api => HasClient t m (Vault :> api) where

445− type Client t m (Vault :> api) = Client t m api

446

543

447− clientWithRoute Proxy q req baseurl =

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

448− clientWithRoute (Proxy :: Proxy api) q req baseurl

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

546+

547+ clientWithRouteAndResultHandler Proxy =

548+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

549+

449

550

450−instance HasClient t m api => HasClient t m (RemoteHost :> api) where

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

451− type Client t m (RemoteHost :> api) = Client t m api

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

452

553

453− clientWithRoute Proxy q req baseurl =

554+ clientWithRouteAndResultHandler Proxy =

454− clientWithRoute (Proxy :: Proxy api) q req baseurl

555+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

455

556

456−instance HasClient t m api => HasClient t m (IsSecure :> api) where

457− type Client t m (IsSecure :> api) = Client t m api

458

557

459− clientWithRoute Proxy q req baseurl =

460− clientWithRoute (Proxy :: Proxy api) q req baseurl

461

558

462−instance (HasClient t m api, Reflex t)

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

463− => HasClient t m (BasicAuth realm usr :> api) where

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

464

561

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

562+ clientWithRouteAndResultHandler Proxy =

466− -> Client t m api

563+ clientWithRouteAndResultHandler (Proxy :: Proxy api)

467

564

565+

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

567+ => HasClient t m (BasicAuth realm usr :> api) tag where

568+

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

570+ -> Client t m api tag

571+

468− clientWithRoute Proxy q req baseurl authdata =

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

469− clientWithRoute (Proxy :: Proxy api) q req' baseurl

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

470 where

574 where

471 req' = req { authData = Just authdata }

575 req' = req { authData = Just authdata }

472

576

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

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

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

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

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

494-}

598-}

599+

600+

601+-- SUPPORT FOR servant-auth --

602+

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

604+-- way that is inaccessible to JavaScript.

605+--

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

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

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

609+-- directly.

610+

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

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

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

614+

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

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

617+

618+

619+type family HasCookieAuth xs :: Constraint where

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

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

622+ HasCookieAuth '[] = CookieAuthNotEnabled

623+

624+class CookieAuthNotEnabled

src/Servant/Reflex/Multi.hsnew file+401

@@ -0,0 +1,401 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE CPP #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE InstanceSigs #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TupleSections #-}

12+{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE TypeOperators #-}

14+{-# LANGUAGE UndecidableInstances #-}

15+

16+module Servant.Reflex.Multi (

17+ -- * Compute servant client functions

18+ clientA

19+ , clientWithOptsA

20+ , BaseUrl(..)

21+ , Scheme(..)

22+

23+ -- * Build QueryParam arguments

24+ , QParam(..)

25+

26+ -- * Access response data

27+ , withCredentials

28+

29+ -- * Access response data

30+ , ReqResult(..)

31+ , reqSuccess

32+ , reqSuccess'

33+ , reqFailure

34+ , response

35+

36+ , HasClientMulti(..)

37+ ) where

38+

39+------------------------------------------------------------------------------

40+import Control.Applicative (liftA2)

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

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

43+import qualified Data.Set as Set

44+import Data.Text (Text)

45+import qualified Data.Text as T

46+import qualified Data.Text.Encoding as E

47+import GHC.TypeLits (KnownSymbol, symbolVal)

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

49+ BasicAuthData, BuildHeadersTo (..),

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

51+ HttpVersion, IsSecure,

52+ MimeRender (..), MimeUnrender,

53+ NoContent, QueryFlag, QueryParam,

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

55+ RemoteHost, ReqBody,

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

57+ contentType)

58+import Servant.API.Description (Summary)

59+

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

61+ XhrRequest (..),

62+ XhrResponseHeaders (..),

63+ attachPromptlyDynWith, constDyn)

64+------------------------------------------------------------------------------

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

66+ SupportsServantReflex)

67+import Servant.Common.Req (ClientOptions,

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

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

70+ defReq,

71+ defaultClientOptions,

72+ performRequestsCT,

73+ performRequestsNoBody,

74+ performSomeRequestsAsync,

75+ prependToPathParts, qParamToQueryPart,

76+ qParams, reqBody, reqFailure,

77+ reqMethod, reqSuccess, reqSuccess',

78+ respHeaders, response, withCredentials)

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

80+

81+

82+------------------------------------------------------------------------------

83+clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)

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

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

86+clientA p q f tag baseurl =

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

88+ defaultClientOptions

89+

90+

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

99+

100+------------------------------------------------------------------------------

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

102+ type ClientMulti t m layout f tag :: *

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

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

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

106+

107+

108+------------------------------------------------------------------------------

109+instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>

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

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

112+ ClientMulti t m b f tag

113+ clientWithRouteMulti Proxy q f tag reqs baseurl opts =

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

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

116+

117+

118+------------------------------------------------------------------------------

119+instance (SupportsServantReflex t m,

120+ ToHttpApiData a,

121+ HasClientMulti t m sublayout f tag,

122+ Applicative f)

123+ => HasClientMulti t m (Capture capture a :> sublayout) f tag where

124+

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

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

127+

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

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

130+ where

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

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

133+

134+

135+------------------------------------------------------------------------------

136+-- VERB (Returning content) --

137+instance {-# OVERLAPPABLE #-}

138+ -- Note [Non-Empty Content Types]

139+ (MimeUnrender ct a,

140+ ReflectMethod method, cts' ~ (ct ': cts),

141+ SupportsServantReflex t m,

142+ Applicative f,

143+ Traversable f

144+ ) => HasClientMulti t m (Verb method status cts' a) f tag where

145+

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

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

148+

149+ clientWithRouteMulti _ _ _ _ reqs baseurl opts =

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

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

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

153+

154+

155+------------------------------------------------------------------------------

156+-- -- VERB (No content) --

157+instance {-# OVERLAPPING #-}

158+ (ReflectMethod method, SupportsServantReflex t m, Traversable f) =>

159+ HasClientMulti t m (Verb method status cts NoContent) f tag where

160+ type ClientMulti t m (Verb method status cts NoContent) f tag =

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

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

163+ -- ExceptT ServantError IO NoContent

164+ clientWithRouteMulti Proxy _ _ _ req baseurl opts =

165+ performRequestsNoBody method req baseurl opts

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

167+

168+

169+------------------------------------------------------------------------------

170+instance {-# OVERLAPPABLE #-}

171+ -- Note [Non-Empty Content Types]

172+ ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,

173+ ReflectMethod method, cts' ~ (ct ': cts),

174+ SupportsServantReflex t m,

175+ Traversable f

176+ ) => 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 =

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

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

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

182+ return $ fmap toHeaders <$> resp

183+ where

184+ reqs' = fmap (\r ->

185+ r { respHeaders =

186+ OnlyHeaders (Set.fromList

187+ (buildHeaderKeysTo (Proxy :: Proxy ls)))

188+ }) <$> reqs

189+

190+

191+------------------------------------------------------------------------------

192+instance {-# OVERLAPPABLE #-}

193+ ( BuildHeadersTo ls,

194+ BuildHeaderKeysTo ls,

195+ ReflectMethod method,

196+ SupportsServantReflex t m,

197+ Traversable f

198+ ) => HasClientMulti t m (Verb method status

199+ cts (Headers ls NoContent)) f tag where

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

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

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

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

205+ return $ fmap toHeaders <$> resp

206+ where reqs' = fmap (\req ->

207+ req {respHeaders = OnlyHeaders (Set.fromList

208+ (buildHeaderKeysTo (Proxy :: Proxy ls)))

209+ }) <$> reqs

210+

211+

212+------------------------------------------------------------------------------

213+instance (KnownSymbol sym,

214+ ToHttpApiData a,

215+ HasClientMulti t m sublayout f tag,

216+ SupportsServantReflex t m,

217+ Traversable f,

218+ Applicative f)

219+ => HasClientMulti t m (Header sym a :> sublayout) f tag where

220+

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

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

223+

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

225+ clientWithRouteMulti (Proxy :: Proxy sublayout) f

226+ q tag

227+ reqs'

228+ baseurl opts

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

230+ reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)

231+ <$> eVals <*>) <$> reqs

232+

233+

234+------------------------------------------------------------------------------

235+instance HasClientMulti t m sublayout f tag

236+ => HasClientMulti t m (HttpVersion :> sublayout) f tag where

237+

238+ type ClientMulti t m (HttpVersion :> sublayout) f tag =

239+ ClientMulti t m sublayout f tag

240+

241+ clientWithRouteMulti Proxy q f tag =

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

243+

244+

245+------------------------------------------------------------------------------

246+instance (HasClientMulti t m sublayout f tag, KnownSymbol sym)

247+ => HasClientMulti t m (Summary sym :> sublayout) f tag where

248+

249+ type ClientMulti t m (Summary sym :> sublayout) f tag =

250+ ClientMulti t m sublayout f tag

251+

252+ clientWithRouteMulti Proxy q f tag =

253+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

254+

255+

256+------------------------------------------------------------------------------

257+instance (KnownSymbol sym,

258+ ToHttpApiData a,

259+ HasClientMulti t m sublayout f tag,

260+ Reflex t,

261+ Applicative f)

262+ => HasClientMulti t m (QueryParam sym a :> sublayout) f tag where

263+

264+ type ClientMulti t m (QueryParam sym a :> sublayout) f tag =

265+ Dynamic t (f (QParam a)) -> ClientMulti t m sublayout f tag

266+

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

268+ -- TODO: Check the above comment

269+ clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =

270+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

271+ reqs' baseurl opts

272+

273+ where pname = symbolVal (Proxy :: Proxy sym)

274+ p prm = QueryPartParam $ fmap qParamToQueryPart prm

275+ paramPair mp = (T.pack pname, p mp)

276+ -- reqs' = (\params reqs -> (\req param -> req {qParams = paramPair param : qParams req}) <$> reqs <*> params)

277+ -- <$> mparams <*> reqs

278+ reqs' = liftA2 (\(pr :: QParam a) (r :: Req t) -> r { qParams = paramPair (constDyn pr) : qParams r })

279+ <$> mparams <*> reqs

280+

281+

282+instance (KnownSymbol sym,

283+ ToHttpApiData a,

284+ HasClientMulti t m sublayout f tag,

285+ Reflex t,

286+ Applicative f)

287+ => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where

288+

289+ type ClientMulti t m (QueryParams sym a :> sublayout) f tag =

290+ Dynamic t (f [a]) -> ClientMulti t m sublayout f tag

291+

292+ clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =

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

294+

295+ where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }

296+ pname = symbolVal (Proxy :: Proxy sym)

297+ params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)

298+ l

299+ reqs' = liftA2 req' <$> paramlists <*> reqs

300+

301+

302+instance (KnownSymbol sym,

303+ HasClientMulti t m sublayout f tag,

304+ Reflex t,

305+ Applicative f)

306+ => HasClientMulti t m (QueryFlag sym :> sublayout) f tag where

307+

308+ type ClientMulti t m (QueryFlag sym :> sublayout) f tag =

309+ Dynamic t (f Bool) -> ClientMulti t m sublayout f tag

310+

311+ clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =

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

313+

314+ where req' f req = req { qParams = thisPair (constDyn f) : qParams req }

315+ thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)

316+ pName = symbolVal (Proxy :: Proxy sym)

317+ reqs' = liftA2 req' <$> flags <*> reqs

318+

319+

320+instance (SupportsServantReflex t m,

321+ Traversable f, Applicative f) => HasClientMulti t m Raw f tag where

322+ type ClientMulti t m Raw f tag = f (Dynamic t (Either Text (XhrRequest ())))

323+ -> Event t tag

324+ -> m (Event t (f (ReqResult tag ())))

325+

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

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

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

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

330+ return resps

331+ where

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

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

334+

335+

336+instance (MimeRender ct a,

337+ HasClientMulti t m sublayout f tag,

338+ Reflex t,

339+ Applicative f)

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

341+

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

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

344+

345+ clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =

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

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

348+ ctProxy = Proxy :: Proxy ct

349+ ctString = T.pack $ show $ contentType ctProxy

350+ bodyBytesCT b = Just $ (fmap . fmap)

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

352+ b

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

354+

355+

356+instance (KnownSymbol path,

357+ HasClientMulti t m sublayout f tag,

358+ Reflex t,

359+ Functor f) => HasClientMulti t m (path :> sublayout) f tag where

360+ type ClientMulti t m (path :> sublayout) f tag = ClientMulti t m sublayout f tag

361+

362+ clientWithRouteMulti Proxy q f tag reqs baseurl =

363+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag

364+ (fmap (prependToPathParts (pure (Right $ T.pack p))) <$> reqs)

365+ baseurl

366+

367+ where p = symbolVal (Proxy :: Proxy path)

368+

369+

370+instance HasClientMulti t m api f tag => HasClientMulti t m (Vault :> api) f tag where

371+ type ClientMulti t m (Vault :> api) f tag = ClientMulti t m api f tag

372+

373+ clientWithRouteMulti Proxy q f tag reqs baseurl =

374+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

375+

376+

377+instance HasClientMulti t m api f tag => HasClientMulti t m (RemoteHost :> api) f tag where

378+ type ClientMulti t m (RemoteHost :> api) f tag = ClientMulti t m api f tag

379+

380+ clientWithRouteMulti Proxy q f tag reqs baseurl =

381+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

382+

383+

384+instance HasClientMulti t m api f tag => HasClientMulti t m (IsSecure :> api) f tag where

385+ type ClientMulti t m (IsSecure :> api) f tag = ClientMulti t m api f tag

386+

387+ clientWithRouteMulti Proxy q f tag reqs baseurl =

388+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl

389+

390+

391+instance (HasClientMulti t m api f tag, Reflex t, Applicative f)

392+ => HasClientMulti t m (BasicAuth realm usr :> api) f tag where

393+

394+ type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))

395+ -> ClientMulti t m api f tag

396+

397+ clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =

398+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts

399+ where

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

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

stack.yamlnew file+56

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

1+flags: {}

2+extra-package-dbs: []

3+packages:

4+- '.'

6+- location:

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

8+ commit: d78ba4318c425ca9b942dc387d7c5c7ab2d2e095

9+ extra-dep: true

10+

11+- location:

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

13+ commit: bbc8ad3a81ea7f2b07ce7d036efd56f2e0f7c6ff

14+ extra-dep: true

15+

16+- location:

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

18+ commit: 21d3a12a82756d04066e5e4198b35097012ee65b

19+ subdirs:

20+ - cairo

21+ - gio

22+ - glib

23+ - gtk

24+ - pango

25+ - tools

26+ extra-dep: true

27+

28+- location:

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

30+ commit: 47d9ed261a5aba66a13d3c4da0e391d338b57fc5

31+ extra-dep: true

32+

33+- location:

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

35+ commit: 39b5ff23f3ae95d77c909ab3ed4bc4bd9e61f600

36+ extra-dep: true

37+

38+- location:

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

40+ commit: 68fc1a90580ea8f20775491cf651eefea422212a

41+ extra-dep: true

42+

43+extra-deps:

44+- cpphs-1.20.4

45+- directory-1.2.7.1

46+- ghcjs-dom-0.2.4.0

47+- haskell-src-exts-1.17.1

48+- haskell-src-meta-0.6.0.14

49+- hlint-1.9.35

50+- prim-uniq-0.1.0.1

51+- primitive-0.6.2.0

52+- ref-tf-0.4.0.1

53+- vector-0.12.0.0

54+- webkitgtk3-javascriptcore-0.13.2.0

55+- zenc-0.1.1

56+resolver: lts-8.3

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

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

9import Data.Foldable

10import Test.WebDriver.Commands.Wait

11import Test.Hspec.WebDriver

12+import Test.Hspec.WebDriver (chromeCaps)

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

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

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

28spec = do

29spec = do

29 describe "servant-reflex tests" $ do

30 describe "servant-reflex tests" $ do

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

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

33 it "opens the page" $ runWD $

34 it "opens the page" $ runWD $

34 openPage "http://localhost:8000"

35 openPage "http://localhost:8000"

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

@@ -1 +0,0 @@

1−../exec/API.hs

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE TypeOperators #-}

5+module API where

7+import Data.Aeson

8+import Data.Aeson.Types (typeMismatch)

9+import Data.Text (Text)

10+import Servant.API

11+

12+newtype Question = Question { unQuestion :: Text } deriving (Show)

13+

14+instance ToJSON Question where

15+ toJSON (Question txt) = object ["question" .= txt]

16+

17+instance FromJSON Question where

18+ parseJSON (Object v) = Question <$> v .: "question"

19+ parseJSON x = typeMismatch "Couldn't find key 'question'" x

20+

21+newtype Answer = Answer { unAnswer :: Text } deriving (Show)

22+

23+instance ToJSON Answer where

24+ toJSON (Answer txt) = object ["answer" .= txt]

25+

26+instance FromJSON Answer where

27+ parseJSON (Object v) = Answer <$> v .: "answer"

28+ parseJSON x = typeMismatch "Couldn't find key 'answer'" x

29+

30+

31+-- | API spec for server, client, and docs

32+type API = "getunit" :> Get '[JSON] ()

33+ :<|> "getint" :> Get '[JSON] Int

34+ :<|> "sayhi" :> QueryParam "username" Text

35+ :> QueryParams "greetings" Text

36+ :> QueryFlag "gusto"

37+ :> Get '[JSON] Text

38+ :<|> "double" :> ReqBody '[JSON] Double

39+ :> Post '[JSON] Double

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

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

42+ :> Post '[JSON] Answer

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

44+ :<|> Raw

45+

46+type GET = Get '[JSON] ()

47+

48+-- Imported the comprehensive API example for testing.

49+-- https://github.com/haskell-servant/servant/blob/master/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs

50+type ComprehensiveAPI =

51+ GET :<|>

52+ Get '[JSON] Int :<|>

53+ Capture "foo" Int :> GET :<|>

54+ Header "foo" Int :> GET :<|>

55+ HttpVersion :> GET :<|>

56+ IsSecure :> GET :<|>

57+ QueryParam "foo" Int :> GET :<|>

58+ QueryParams "foo" Int :> GET :<|>

59+ QueryFlag "foo" :> GET :<|>

60+-- Raw :<|>

61+ RemoteHost :> GET :<|>

62+ ReqBody '[JSON] Int :> GET :<|>

63+ Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>

64+ "foo" :> GET :<|>

65+ Vault :> GET :<|>

66+ Verb 'POST 204 '[JSON] () :<|>

67+ Verb 'POST 204 '[JSON] Int

68+-- This one isn't in scope

69+-- :<|> WithNamedContext "foo" '[] GET

testserver/Main.hs+39−14

@@ -2,27 +2,34 @@

2{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PolyKinds #-}

5+{-# LANGUAGE TypeApplications #-}

5{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeOperators #-}

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

10+import Control.Monad.Reader (reader)

8import Data.Aeson

11import Data.Aeson

9import Data.Bool

12import Data.Bool

10−import Data.Char (toUpper)

13+import Data.Char (toUpper)

11−import qualified Data.List as L

14+import qualified Data.List as L

15+import Data.Maybe (fromMaybe)

12import Data.Monoid

16import Data.Monoid

13import Data.Proxy

17import Data.Proxy

14−import Data.Text hiding (length, null, map, head, toUpper)

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

19+ null, toUpper)

15−import qualified Data.Text as T

20+import qualified Data.Text as T

21+import qualified Data.Text.IO as T

16import GHC.Generics

22import GHC.Generics

17−import Snap.Http.Server

18−import Snap.Core

19import Servant.Server.Internal.SnapShims

23import Servant.Server.Internal.SnapShims

24+import Snap.Core

25+import Snap.Http.Server

21−import Servant -- hiding (serveDirectory)

27+import Servant

22import Servant.Server

28import Servant.Server

23-- import Snap.Util.FileServe

29-- import Snap.Util.FileServe

30+import System.Environment (lookupEnv)

24import API

31import API

25−import Snap

32+import Snap

27-- * Example

34-- * Example

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

36testApi :: Proxy API

43testApi :: Proxy API

37testApi = Proxy

44testApi = Proxy

39−data App = App

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

41-- Server-side handlers.

48-- Server-side handlers.

42--

49--

@@ -44,8 +51,10 @@ data App = App

44-- that represents the API, are glued together using :<|>.

51-- that represents the API, are glued together using :<|>.

45--

52--

46-- Each handler runs in the 'ExceptT ServantErr IO' monad.

53-- Each handler runs in the 'ExceptT ServantErr IO' monad.

47−server :: Server API (Handler App App)

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

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

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

57+ :<|> statics

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

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

50 sayhi nm greetings withGusto = case nm of

59 sayhi nm greetings withGusto = case nm of

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

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

57 | otherwise = T.intercalate ", " (L.init greetings)

66 | otherwise = T.intercalate ", " (L.init greetings)

58 <> ", and " <> L.last greetings <> ", "

67 <> ", and " <> L.last greetings <> ", "

59 return . modifier $ greetPart <> n

68 return . modifier $ greetPart <> n

69+ dbl x = if x `elem` [4,13]

70+ then throwError $ err500 { errBody = "No unlucky numbers please" }

60− dbl x = return $ x * 2

71+ else return $ x * 2

61 multi = return . bool "Box unchecked" "Box Checked"

72 multi = return . bool "Box unchecked" "Box Checked"

73+ qna q = do

74+ liftIO $ do

75+ putStrLn $ "qna got: " ++ show q

76+ T.putStrLn $ unQuestion q

77+ return $ Answer $ unQuestion q

78+ serveSecret _ = do

79+ req <- getRequest

80+ liftIO $ putStrLn (show req)

81+ return 101

82+ statics = do

83+ staticDir <- reader appStaticDir

84+ serveDirectory staticDir

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

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

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

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

65test :: Handler App App ()

88test :: Handler App App ()

66−test = serveSnap testApi server

89+test = serveSnapWithContext testApi

90+ (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server

68initApp :: SnapletInit App App

92initApp :: SnapletInit App App

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

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

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

70 addRoutes [("", test)

95 addRoutes [("", test)

71 ,("", serveDirectory "static")

96 ,("", serveDirectory "static")

72 ]

97 ]

73− return App

98+ return (App staticDir)

75-- Put this all to work!

100-- Put this all to work!

76main :: IO ()

101main :: IO ()

testserver/run-wd-tests.shdeleted−5

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

1−#!/usr/bin/env bash

2−

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

4−phantomjs --webdriver=127.0.0.1:4444 &

5−dist/build/spec/spec

testserver/testserver.cabal+17−16

@@ -1,31 +1,32 @@

1−-- Initial back.cabal generated by cabal init. For further documentation,

1+-- Initial back.cabal generated by cabal init. For further documentation,

2-- see http://haskell.org/cabal/users-guide/

4name: testserver

5version: 0.1.0.0

6−-- synopsis:

6+-- synopsis:

7−-- description:

7+-- description:

8license: BSD3

9license-file: LICENSE

10author: Greg Hale

11maintainer: imalsogreg@gmail.com

12−-- copyright:

12+-- copyright:

13−-- category:

13+-- category:

14build-type: Simple

15−-- extra-source-files:

15+-- extra-source-files:

16cabal-version: >=1.10

18executable back

19 main-is: Main.hs

20− -- other-modules:

20+ -- other-modules:

21− -- other-extensions:

21+ -- other-extensions:

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

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

23− , base >=4.8 && <4.10

23+ , base >=4.8 && < 5

24+ , mtl

24− , snap >= 1.0 && < 1.1

25+ , snap >= 1.0 && < 1.2

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

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

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

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

27− , servant >= 0.7.1 && < 0.9

28+ , servant >= 0.16 && < 0.18

28− , servant-snap >= 0.7 && < 0.8

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

29− , text >= 1.2 && < 1.3

30+ , text >= 1.0 && < 1.3

30− -- hs-source-dirs:

31+ -- hs-source-dirs:

31 default-language: Haskell2010

32 default-language: Haskell2010

testserver/tr.nixdeleted−32

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

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

2−let

3−

4− dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;

5− cabal2nixResult = reflex-platform.cabal2nixResult;

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

7−in

8−reflex-platform.ghc.override {

9− overrides = self: super: {

10− servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});

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

12− io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});

13− io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});

14− heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});

15− xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});

16− snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});

17− snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});

18− snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});

19− snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});

20− hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});

21−

22− # servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});

23− # servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});

24− # servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});

25− # servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});

26− # servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});

27− # servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});

28− # servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});

29− # servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});

30−

31− };

32−}

travis.nixnew file+70

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

1+{

2+ nativeCompiler ? "ghc",

3+ # ^ Choose a GHC for compiling backend components (web server, selenium)

4+ # (ghc, ghc8_0, ghc8_2, ghc8_4 or ghcHEAD)

6+ jsCompiler ? "ghcjs"

7+ # ^ Choose a GHCJS for compiling the frontend

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

10+}:

11+

12+let

13+

14+ reflexPlatform = import ./nix/reflex-platform.nix;

15+

16+ lib = reflexPlatform.nixpkgs.haskell.lib;

17+ do = funs: pkg: builtins.foldl' (a: b: b a) pkg funs;

18+

19+ ghcjsPkgs = with lib; reflexPlatform.${jsCompiler}.override {

20+ overrides = self: super: {

21+ http-media = dontCheck super.http-media;

22+ servant = dontCheck super.servant;

23+ lens-aeson = dontCheck super.lens-aeson;

24+ servant-reflex = lib.appendConfigureFlag

25+ (self.callPackage ./default.nix {}) "-fExample";

26+ };

27+ };

28+

29+ ghcPkgs = with lib; reflexPlatform.${nativeCompiler}.override {

30+ overrides = self: super: {

31+ servant-snap = dontCheck ((import ./nix/servant-snap.nix {}) self super);

32+ testdriver = self.callCabal2nix "testdriver" ./testdriver {};

33+ testserver = import nix/testserver.nix ghcjsPkgs.servant-reflex self super;

34+ servant-reflex = self.callPackage ./default.nix {};

35+ };

36+ };

37+

38+ testresults = import ./nix/testresults.nix

39+ { inherit reflexPlatform;

40+ inherit (ghcPkgs) testserver testdriver;

41+ inherit (reflexPlatform.nixpkgs) curl;

42+ phantomjs = reflexPlatform.nixpkgs.phantomjs2;

43+ };

44+

45+in

46+ rec {

47+

48+ inherit reflexPlatform ghcPkgs ghcjsPkgs;

49+

50+ build = ghcjsPkgs.servant-reflex;

51+ buildGhc = ghcPkgs.servant-reflex;

52+ testserver = ghcPkgs.testserver;

53+ testdriver = ghcPkgs.testdriver;

54+ inherit testresults;

55+

56+ cabalBuild = reflexPlatform.${jsCompiler}.shellFor {

57+ name = "servant-reflex-cabal-builder";

58+

59+ packages = p: [

60+ build

61+ ];

62+

63+ shellHook = ''

64+ cabal configure --ghcjs -f Example

65+ cabal build

66+ exec/toSite.sh

67+ exit $?

68+ '';

69+ };

70+ }