git.iko.soy/servant-reflex
on 588c62e help sign in
f76dbeb
swap
0 ahead, 249 behind
.gitignore−8
since splitsnapshots
unifiedsplit
@@ -1,11 +1,3 @@
1.cabal-sandbox
1.cabal-sandbox
2cabal.sandbox.config
2cabal.sandbox.config
3dist
3dist
4−*.js
5−log
6−*.webapp
7−*.stats
8−out
9−/.stack-work/
10−TAGS
11−dist-newstyle
.gitmodules+18
@@ -0,0 +1,18 @@
1+[submodule "deps/reflex-dom-contrib"]
2+ path = deps/reflex-dom-contrib
3+ url = git@github.com:reflex-frp/reflex-dom-contrib.git
4+[submodule "deps/try-reflex"]
5+ path = deps/try-reflex
6+ url = git@github.com:ryantrinkle/try-reflex.git
7+[submodule "deps/servant"]
8+ path = deps/servant
9+ url = https://github.com/haskell-servant/servant.git
10+[submodule "deps/servant-snap"]
11+ path = deps/servant-snap
12+ url = https://github.com/haskell-servant/servant-snap
13+[submodule "deps/reflex-dom"]
14+ path = deps/reflex-dom
15+ url = https://github.com/ryantrinkle/reflex-dom
16+[submodule "deps/reflex"]
17+ path = deps/reflex
18+ url = https://github.com/ryantrinkle/reflex
.travis.ymldeleted−17
@@ -1,17 +0,0 @@
1−language: nix
2−nix: 2.3.6
3−sudo: require
4−
5−before_install:
6− - sudo cp -rT $TRAVIS_BUILD_DIR/nix /etc/nix
7−
8−before_script:
9− - sudo systemctl restart nix-daemon.service
10− - git config --global user.email "travis-ci@example.com"
11− - git config --global user.name "Travis-CI"
12−
13−script:
14− - nix-build travis.nix -A build
15− - nix-build travis.nix -A buildGhc
16− - nix-build travis.nix -A testserver
17− - nix-build travis.nix -A testresults
ChangeLog.mddeleted−60
@@ -1,60 +0,0 @@
1−0.3.5
2−-----
3−
4− - Require reflex-dom-core >= 0.6 (for internal handling of case-insensitive headers)
5− - Require servant >= 0.16
6− - Eliminate use of deprecated widgets from reflex-dom-core
7− - Bump the version of reflex-platform used in nix-shell and test suite
8−
9−0.3.4
10−-----
11−
12−Add selenium-based test suite
13−
14−0.3.3
15−-----
16−
17−- Fix encoding issue: Explicitly escape reserved characters from path pieces and query parameters
18−
19−
20−0.3.2
21−-----
22−
23−- **Addition of 'Servant.Reflex.Common.Req.ClientOpts'** which
24−allows the users to apply a final adjustment to Requests before
25−thery are sent, such as setting the 'withCredentials' flag
26−or print the Request to the console for debugging
27−[PR #47](https://github.com/imalsogreg/servant-reflex/pull/47)
28−
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!
LICENSE.mddeleted−30
@@ -1,30 +0,0 @@
1−Copyright Greg Hale (c) 2016
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
10−
11− * Redistributions in binary form must reproduce the above
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of Greg Hale nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.mddeleted−224
@@ -1,224 +0,0 @@
1−# servant-reflex
2−
3−[![Build Status](https://travis-ci.org/imalsogreg/servant-reflex.svg?branch=master)](https://travis-ci.org/imalsogreg/servant-reflex)
4−
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
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.
14−
15−
16−## Example
17−
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:
20−
21−```haskell
22−type API = "getint" :> Get '[JSON] Int
23− :<|> "sayhi" :> QueryParam "username" Text
24− :> QueryParams "greetings" Text
25− :> QueryFlag "gusto"
26− :> Get '[JSON] Text
27− :<|> "double" :> ReqBody '[JSON] Double
28− :> Post '[JSON] Double
29− :<|> Raw
30−```
31−
32−`servant-reflex` then computes client functions that can query the API through
33−an `XhrRequest`.
34−
35−```haskell
36−
37− runGUI :: forall t m.MonadWidget t m => do
38−
39− -- servant-reflex computes FRP functions for each API endpoint
40− let (getint :<|> sayhi :<|> doubleit :<|> _) = client (Proxy :: Proxy API)
41− (Proxy :: Proxy m)
42− (Proxy :: Proxy ())
43− (constDyn (BasePath "/"))
44−```
45−
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.
56−
57−```haskell
58− -- No need to write these functions. servant-reflex creates them for you!
59− getint :: MonadWidget t m
60− => Event t () -- ^ Trigger the XHR Request
61− -> m (Event t (ReqResult () Int)) -- ^ Consume the answer
62−
63− sayhi :: MonadWidget t m
64− => Dynamic t (QParam Text)
65− -- ^ One input parameter - the 'name', wrapped in 'QParam'
66− -> Dynamic t [Text]
67− -- ^ Another input: list of preferred greetings
68− -> Dynamic t Bool
69− -- ^ Flag for capitalizing the response
70− -> Event t ()
71− -- ^ Trigger the XHR Request
72− -> m (Event t (ReqResult () Text))
73−
74− doubleit :: MonadWidget t m
75− => Dynamic t (Either Text Double)
76− -> Event t ()
77− -> m (Event t (ReqResult () Double))
78−```
79−
80−`ReqResult tag a` is defined in
81−[`Servant.Common.Req`](https://github.com/imalsogreg/servant-reflex/blob/6d866e338edb9bf6fd8f8d5083ff0187b4d8c0d2/src/Servant/Common/Req.hs#L40-L42)
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:
87−
88−```haskell
89− -- ... continued ...
90− res :: Event t (ReqResult Double) <- doubleIt xs triggers
91− let ys = fmapMaybe reqSuccess res
92− errs = fmapMaybe reqFailure res
93−
94− -- Green <p> tag showing the last good result
95− elAttr "p" ("style" =: "color:green") $ do
96− text "Last good result: "
97− dynText =<< holdDyn "" (fmap show ys)
98−
99− -- Red <p> tag showing the last error, cleared by a new good value
100− elAttr "p" ("style" =: "color:red") $
101− dynText =<< holdDyn "" (leftmost [errs, const "" <$> ys])
102−```
103−
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−
107−```haskell
108− elClass "div" "int-demo" $ do
109− intButton <- button "Get Int"
110− serverInts <- fmapMaybe resSuccess <$> getint intButton
111− display =<< holdDyn (Just 0) serverInts
112−
113− elClass "div" "hello-demo" $ do
114− nameText <- QParamSome . value <$> textInput def
115− greetings <- (fmap words . value) <$> textInput def
116− withGusto <- checkbox def
117− helloButton <- button "Say hi"
118− hellos <- fmapMaybe resResult <$> sayhi nameText greetings withGusto helloButton
119− display =<< holdDyn Nothing hellos
120−
121− elClass "div" "demo-double" $ do
122− inputDouble <- (fmapMaybe readMaybe) <$> textInput def
123− doubleButton <- button "Double it"
124− outputDouble <- fmapMaybe resSuccess <$> doubleit inputDouble doubleButton
125− display =<< holdDyn Nothing outputDouble
126−```
127−
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.
133−
134−
135−## Building the library and test server
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
141−([testserver/](https://github.com/imalsogreg/servant-reflex/tree/master/testserver).
142−To build these components, we will use the nix packages for the testserver. It
143−manages the frontend build as a dependency.
144−
145−```
146−nix build -f travis.nix testserver -o server
147−```
148−
149−Point it at the static directory and run it:
150−
151−```
152−STATIC_DIR=server/static server/back -p 8000
153−```
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.
158−
159−**For a larger example of a project that shares types between backend and
160−frontend, see [hsnippet](https://github.com/mightybyte/hsnippet).**
161−
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− ...
200−```
201−
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−```
217−
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.shnew file+3
@@ -0,0 +1,3 @@
1+#!/bin/sh
2+
3+deps/try-reflex/work-on ./overrides.nix ./. --run "cabal configure --ghcjs ; cabal build"
default.nix+14−15
@@ -1,21 +1,20 @@
1−{ mkDerivation, base, bytestring, case-insensitive, containers
1+{ mkDerivation, exceptions, http-types, reflex, reflex-dom,
2−, data-default, exceptions, ghcjs-dom, http-api-data, http-media
2+ reflex-dom-contrib, servant
3−, jsaddle, mtl, network-uri, reflex, reflex-dom, reflex-dom-core
4−, safe, servant, servant-auth, stdenv, string-conversions, text
5−, transformers
6}:
3}:
4+
7mkDerivation {
5mkDerivation {
8 pname = "servant-reflex";
6 pname = "servant-reflex";
9− version = "0.3.6";
7+ version = "0.1";
10− src = ./.;
8+ src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;
11− isLibrary = true;
12 isExecutable = true;
9 isExecutable = true;
13− libraryHaskellDepends = [
10+ isLibrary = true;
14− base bytestring case-insensitive containers data-default exceptions
11+ buildDepends = [
15− ghcjs-dom http-api-data http-media jsaddle mtl network-uri reflex
12+ exceptions
16− reflex-dom reflex-dom-core safe servant servant-auth string-conversions
13+ http-types
17− text transformers
14+ reflex
15+ reflex-dom
16+ reflex-dom-contrib
17+ servant
18 ];
18 ];
19− description = "servant API generator for reflex apps";
19+ license = null;
20− license = stdenv.lib.licenses.bsd3;
21}
20}
deploy_key.encdeleted

Binary file not shown.

deps/reflexnew file+1

Submodule changed.

deps/reflex-domnew file+1

Submodule changed.

deps/reflex-dom-contribnew file+1

Submodule changed.

deps/servantnew file+1

Submodule changed.

deps/servant-snapnew file+1

Submodule changed.

deps/try-reflexnew file+1

Submodule changed.

exec/API.hs+4−64
@@ -1,69 +1,9 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TypeOperators #-}
2+{-# LANGUAGE TypeOperators #-}
4
3
5module API where
4module API where
6
5
7−import Data.Aeson
8−import Data.Aeson.Types (typeMismatch)
9−import Data.Text (Text)
10−import Servant.API
6+import Servant.API
11
7
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] ()
8+type API = "getunit" :> Get '[JSON] ()
33 :<|> "getint" :> Get '[JSON] Int
9 :<|> "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
exec/Example.hs+14−206
@@ -1,219 +1,27 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE GADTs #-}
4−{-# LANGUAGE OverloadedStrings #-}
5−{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE RecursiveDo #-}
7{-# LANGUAGE ScopedTypeVariables #-}
1{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE RankNTypes #-}
8
3
9module Main where
4module Main where
10
5
11−------------------------------------------------------------------------------
12−import Data.Bool
13−import Data.Maybe
14−import Control.Monad.Fix (MonadFix)
15−import Data.Monoid (First(..), (<>))
16−import Data.Text (Text)
17−import qualified Data.Text as T
18−import qualified Data.Text.Encoding as T
19−import GHC.TypeLits
20−import Servant.API
6+import Servant.Reflex
21import API
7import API
22import Data.Proxy
8import Data.Proxy
23−import Text.Read (readMaybe)
24−import Reflex.Dom.Core hiding (run, mainWidget)
25−import Reflex.Dom (mainWidget)
9+import Reflex.Dom
26−------------------------------------------------------------------------------
27−import Servant.Reflex
28−import Servant.Reflex.Multi
29−
30
10
31api :: Proxy API
11api :: Proxy API
32api = Proxy
12api = Proxy
33
13
34−main :: IO ()
14+url :: BaseUrl
35−main = mainWidget $ do
15+url = BaseUrl Http "localhost" 8000 ""
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 ()
80−
81−run :: forall t m. (SupportsServantReflex t m,
82− DomBuilder t m,
83− DomBuilderSpace m ~ GhcjsDomSpace,
84− MonadFix m,
85− PostBuild t m,
86− MonadHold t m) => m ()
87−run = mdo
88−
89− reqCount <- count $ leftmost
90− [() <$ unitBtn, () <$ intBtn, () <$ sayHiClicks, () <$ dblBtn, () <$ mpGo]
91− -- Allow user to choose the url target for the request
92− -- (alternatively we could just `let url = constDyn (BasePath "/")`)
93− url <- baseUrlWidget
94− el "br" (return ())
95− dynText $ showBaseUrl <$> url
96−
97− el "br" (return ())
98−
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) =
104− clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest
105−
106− c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
107−
108− (unitBtn, intBtn) <- elClass "div" "demo-group" $ do
109− unitBtn <- divClass "unit-button" $ button "Get unit"
110− intBtn <- divClass "int-button" $ button "Get int"
111
16
112− unitResponse <- getUnit $ tag (current reqCount) unitBtn
17+main :: IO ()
113− intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn
18+main = mainWidget run
114−
115− score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))
116−
117− r <- holdDyn "Waiting" $ fmap showXhrResponse $
118− leftmost [fmapMaybe response (unitResponse)
119− ,fmapMaybe response (intResponse)
120− ]
121− divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score
122− return (unitBtn, intBtn)
123−
124− sayHiClicks <- elClass "div" "demo-group" $ do
125−
126− text "Name"
127− el "br" $ return ()
128− inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ (textInput def)
129− let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp
130− el "br" $ return ()
131−
132− text "Greetings (space-separated)"
133− el "br" $ return ()
134− greetings <- fmap (fmap T.words . value) $
135− divClass "greetings-input" $ (textInput def)
136−
137− el "br" $ return ()
138−
139− gusto <- fmap value $ divClass "gusto-input" $ checkbox False def
140−
141− el "br" $ return ()
142− sayHiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"
143− let triggers = leftmost [sayHiClicks, () <$ updated inp]
144−
145− resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)
146− divClass "greeting-response" $ dynText =<<
147− holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)
148− , fmapMaybe reqFailure (resp)])
149− return sayHiClicks
150−
151− dblBtn <- elClass "div" "demo-group" $ do
152− text "A Double to double"
153− el "br" $ return ()
154− dblinp <- fmap value $ divClass "double-input" $ textInput def
155− (dblBtn) <- divClass "double-button" $ button "Double it"
156− dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
157− dblinp) (tag (current reqCount) dblBtn)
158− divClass "double-errors" $ dynText =<<
159− holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))
160− el "br" (return ())
161− divClass "double-result" $ el "p" $ dynText =<<
162− holdDyn "No number yet" (fmap tShow $
163− fmapMaybe reqSuccess (dblResp))
164− return dblBtn
165−
166− mpGo <- elClass "div" "demo-group" $ do
167− text "Multi-part path"
168− b <- value <$> checkbox False def
169− mpGo <- button "Test"
170− multiResp <- multi b (tag (current reqCount) mpGo)
171− dynText =<< holdDyn "No res yet" (fmap tShow $
172− fmapMaybe reqSuccess $
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−
200−
201−showXhrResponse :: XhrResponse -> Text
202−showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
203− T.unlines ["stat: " <> tShow stat
204− ,"stattxt: " <> tShow stattxt
205− ,"resp: " <> maybe "" showRB rbmay
206− ,"rtext: " <> tShow rtmay
207− ,"rHeaders: " <> tShow respHeaders]
208−
209−tShow :: Show a => a -> Text
210−tShow = T.pack . show
211
19
212−showRB :: XhrResponseBody -> Text
20+run :: forall t m. MonadWidget t m => m ()
213−showRB (XhrResponseBody_Default t) = tShow t
21+run = do
214−showRB (XhrResponseBody_Text t) = tShow t
22+ let (getUnit :: Event t () -> m (Event t ((),()))) = client api url
215−showRB (XhrResponseBody_Blob t) = "<Blob>"
23+ b :: Event t () <- button "Get unit"
216−showRB (XhrResponseBody_ArrayBuffer t) = tShow t
24+ res :: Event t ((),()) <- getUnit b
25+ c <- foldDyn (\_ (n :: Int) -> succ n) 0 res
26+ display c
217
27
218−note :: e -> Maybe a -> Either e a
219−note e = maybe (Left e) Right
exec/toSite.shdeleted−3
@@ -1,3 +0,0 @@
1−#!/usr/bin/env bash
2−
3−cp dist/build/example/example.jsexe/* testserver/static
init-sandbox.shnew file+40
@@ -0,0 +1,40 @@
1+#! /bin/sh
2+
3+cabal sandbox init
4+
5+cabal sandbox add-source deps/snaplet-postgresql-simple
6+
7+#! /bin/sh
8+
9+cabal sandbox init
10+
11+echo "Depend on snap-1.0 from github. Move to Hackage version when snap-1.0 is released"
12+cabal sandbox add-source deps/servant-snap/deps/snap/deps/io-streams
13+cabal sandbox add-source deps/servant-snap/deps/snap/deps/io-streams-haproxy
14+cabal sandbox add-source deps/servant-snap/deps/snap/deps/snap-core
15+cabal sandbox add-source deps/servant-snap/deps/snap/deps/snap-server
16+cabal sandbox add-source deps/servant-snap/deps/snap/deps/xmlhtml
17+cabal sandbox add-source deps/servant-snap/deps/snap/deps/heist
18+cabal sandbox add-source deps/servant-snap/deps/snap-loader-static
19+cabal sandbox add-source deps/servant-snap/deps/snap-loader-static
20+cabal sandbox add-source deps/servant-snap/deps/snap
21+cabal sandbox add-source deps/servant-snap/deps/hspec-snap
22+
23+echo "Depend on particular servant branch with (Raw m a) changes"
24+echo "TODO: Move to hackage version when servant-0.5 is released"
25+cabal sandbox add-source deps/servant-snap/deps/servant/servant
26+cabal sandbox add-source deps/servant-snap/deps/servant/servant-docs
27+cabal sandbox add-source deps/servant-snap/deps/servant/servant-client
28+cabal sandbox add-source deps/servant-snap/deps/servant/servant-blaze
29+cabal sandbox add-source deps/servant-snap/deps/servant/servant-js
30+cabal sandbox add-source deps/servant-snap/deps/servant/servant-lucid
31+cabal sandbox add-source deps/servant-snap/deps/servant/servant-mock
32+
33+cabal sandbox add-source deps/servant-snap
34+cabal sandbox add-source deps/reflex
35+cabal sandbox add-source deps/reflex-dom
36+cabal sandbox add-source deps/reflex-dom-contrib
37+
38+cabal sandbox add-source .
39+
40+cd testserver && cabal sandbox init --sandbox=../.cabal-sandbox && cd ..
nix/nix.confdeleted−3
@@ -1,3 +0,0 @@
1−substituters = https://cache.nixos.org/ https://nixcache.reflex-frp.org/
2−trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=
3−trusted-users = travis
nix/reflex-platform.nixdeleted−7
@@ -1,7 +0,0 @@
1−let
2− rev = "1aba6f367982bd6dd78ec2fda75ab246a62d32c5" ;
3−in import (builtins.fetchTarball
4− {
5− url = "https://github.com/reflex-frp/reflex-platform/archive/${rev}.tar.gz";
6− sha256 = "137vg6i8yy4lp6rz4wbvvhfcc9d9qf7j1b3fnng3r7sj63k7j664" ;
7− }) {}
nix/servant-snap.nixdeleted−7
@@ -1,7 +0,0 @@
1−# Servant-snap is marked broken in nixpkgs
2−{ nixpkgs ? import <nixpkgs> {}}: self: super:
3−self.callCabal2nix "servant-snap" (nixpkgs.fetchgit {
4− url = "https://github.com/haskell-servant/servant-snap.git";
5− rev = "af5172a6de5bb2a07eb1bf4c85952075ec6ecdf3";
6− sha256 = "sha256-fzzQGwG8Ko72OO/kwLMG52eNZSt3F2dxhNgM9gaO4yQ=";
7−}) {}
nix/testresults.nixdeleted−17
@@ -1,17 +0,0 @@
1−{ curl, reflexPlatform, testdriver, testserver, phantomjs }:
2−
3−reflexPlatform.nixpkgs.pkgs.runCommand "runWebdriveTest.sh" {} ''
4− echo About to phantom
5− ${phantomjs}/bin/phantomjs --webdriver=127.0.0.1:4444 &
6− sleep 3
7− echo About to Server
8− STATIC_DIR=${testserver}/static ${testserver}/back -q --no-access-log --no-error-log -p 8000 &
9− sleep 3
10− ${curl}/bin/curl localhost:8000
11− ${curl}/bin/curl localhost:8000/runmain.js
12− echo About to testdrive
13− ${testdriver}/bin/spec > $out 2>&1
14− echo Done
15− trap "exit" INT TERM
16− trap "kill 0" EXIT
17− ''
nix/testserver.nixdeleted−9
@@ -1,9 +0,0 @@
1−servant-reflex: self: super:
2−
3−(self.callCabal2nix "testserver" ../testserver {}).overrideDerivation (drv: {
4− postInstall = ''
5− cp dist/build/back/back $out/back
6− mkdir $out/static
7− cp ${servant-reflex}/bin/example.jsexe/* $out/static/
8− '';
9−})
overrides.nixnew file+11
@@ -0,0 +1,11 @@
1+{ try-reflex, ... }:
2+let
3+ pkgs = import <nixpkgs> {};
4+ try-reflex = import deps/try-reflex {};
5+in try-reflex.ghcjs.override {
6+ overrides = self: super: {
7+ self.lens = pkgs.haskell.lib.dontCheck (self.lens);
8+ reflex-dom-contrib = pkgs.haskell.lib.dontCheck (self.callPackage deps/reflex-dom-contrib {});
9+ servant = self.callPackage (try-reflex.cabal2nixResult deps/servant/servant) {};
10+ };
11+}
servant-reflex.cabal+34−49
@@ -1,70 +1,55 @@
1Name: servant-reflex
1Name: servant-reflex
2−Version: 0.3.6
2+Version: 0.1
3−Synopsis: servant API generator for reflex apps
3+Synopsis: Servant reflex API generator
4−Description: Generate reflex-compatible client functions from servant API descriptions
4+Description: Servant reflex API generator
5−License: BSD3
5+License: AllRightsReserved
6−License-file: LICENSE.md
6+License-file: LICENSE
7−Author: Greg Hale, Doug Beardsley
7+Author: Doug Beardsley
8−Maintainer: imalsogreg@gmail.com
8+Maintainer: mightybyte@gmail.com
9Stability: Experimental
9Stability: Experimental
10Category: Web
10Category: Web
11Build-type: Simple
11Build-type: Simple
12−Cabal-version: >=1.10
12+Cabal-version: >=1.8
13−
14−Flag Example
15− description: Enable example
16− default: False
17
13
18library
14library
19− exposed-modules:
15+ exposed-modules:
16+ Servant.Reflex
17+
18+ other-modules:
20 Servant.Common.BaseUrl
19 Servant.Common.BaseUrl
21 Servant.Common.Req
20 Servant.Common.Req
22− Servant.Reflex
23− Servant.Reflex.Multi
24
21
25 hs-source-dirs: src
22 hs-source-dirs: src
26 build-depends:
23 build-depends:
27− base >= 4.8 && < 5,
24+ base,
28 bytestring >= 0.10 && < 0.11,
25 bytestring >= 0.10 && < 0.11,
29− case-insensitive >= 1.2.0.4 && < 1.3,
30− containers >= 0.5.6 && < 0.7,
26+ containers,
31− data-default >= 0.5 && < 0.8,
27+ data-default >= 0.5 && < 0.6,
32− exceptions >= 0.8 && < 0.11,
28+ exceptions >= 0.8 && < 0.9,
29+ ghcjs-base,
33− ghcjs-dom >= 0.2 && < 0.10,
30+ ghcjs-dom >= 0.2 && < 0.3,
34− http-api-data >= 0.3.6 && < 0.5,
31+ http-api-data >= 0.2 && < 0.3,
35− http-media >= 0.6 && < 0.9,
32+-- http-media >= 0.6 && < 0.7,
36− jsaddle >= 0.8 && < 0.10,
33+-- http-types >= 0.8 && < 0.9,
37− mtl >= 2.2.1 && < 2.3,
34+ mtl,
38 network-uri >= 2.6 && < 2.7,
35 network-uri >= 2.6 && < 2.7,
39− reflex >= 0.5 && < 0.9,
36+ reflex,
40− reflex-dom-core >= 0.6 && < 0.7,
37+ reflex-dom,
41− safe >= 0.3.9 && < 0.4,
38+ safe,
42− servant >= 0.16 && < 0.18,
39+ servant >= 0.5 && < 0.6,
43− servant-auth >= 0.2.1 && < 0.4,
44− string-conversions >= 0.4 && < 0.5,
40+ string-conversions,
45− text >= 1.2 && < 1.3,
41+ text,
46− transformers >= 0.4 && < 0.6
42+ transformers >= 0.4 && < 0.5
47
43
48− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields
44+ if impl(ghcjs)
45+ build-depends: ghcjs-base
49
46
50− default-language: Haskell2010
47+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
51
48
52executable example
49executable example
53− if flag(Example)
54− buildable: True
55− else
56− buildable: False
57− build-depends:
58− aeson,
59− reflex,
60− servant-reflex,
50+ build-depends: reflex, servant-reflex, base, servant, reflex-dom
61− base,
62− scientific,
63− servant,
64− reflex-dom,
65− reflex-dom-core,
66− text
67 default-language: Haskell2010
51 default-language: Haskell2010
68 main-is: Example.hs
52 main-is: Example.hs
69 other-modules: API
53 other-modules: API
70 hs-source-dirs: exec
54 hs-source-dirs: exec
55+
shell.nixdeleted−1
@@ -1 +0,0 @@
1−(import ./travis.nix {nativeCompiler = "ghc";}).ghcPkgs.servant-reflex.env
shell.shnew file+3
@@ -0,0 +1,3 @@
1+#!/bin/sh
2+
3+deps/try-reflex/work-on ./overrides.nix ./.
src/Servant/Common/BaseUrl.hs+47−68
@@ -1,98 +1,77 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
1+{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE ViewPatterns #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE OverloadedStrings #-}
7−{-# LANGUAGE ViewPatterns #-}
8−{-# LANGUAGE RankNTypes #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10module Servant.Common.BaseUrl (
4module Servant.Common.BaseUrl (
11 -- * types
5 -- * types
12 BaseUrl (..)
6 BaseUrl (..)
7+ , InvalidBaseUrlException
13 , Scheme (..)
8 , Scheme (..)
14 -- * functions
9 -- * functions
15− , baseUrlWidget
10+ , parseBaseUrl
16 , showBaseUrl
11 , showBaseUrl
17−
18− -- * constraints
19− , SupportsServantReflex
20) where
12) where
21
13
22−import Control.Monad (join)
14+import Control.Monad.Catch (Exception, MonadThrow, throwM)
23−-- import Control.Monad.IO.Class (MonadIO)
24−import Control.Monad.Fix (MonadFix)
25−import Data.Monoid ((<>))
15+import Data.List
26−import Data.Text (Text)
16+import Data.Typeable
27−import qualified Data.Text as T
28import GHC.Generics
17import GHC.Generics
29−import Language.Javascript.JSaddle.Monad (MonadJSM)
18+import Network.URI hiding (path)
30−import Reflex
19+import Safe
31−import Reflex.Dom.Core
32import Text.Read
20import Text.Read
33
21
34−
35−type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadJSM (Performable m))
36−
37-- | URI scheme to use
22-- | URI scheme to use
38data Scheme =
23data Scheme =
39 Http -- ^ http://
24 Http -- ^ http://
40 | Https -- ^ https://
25 | Https -- ^ https://
41− deriving (Show, Read, Eq, Ord, Generic)
26+ deriving (Show, Eq, Ord, Generic)
42
27
43-- | Simple data type to represent the target of HTTP requests
28-- | Simple data type to represent the target of HTTP requests
44-- for servant's automatically-generated clients.
29-- for servant's automatically-generated clients.
45−data BaseUrl = BaseFullUrl Scheme Text Int Text
30+data BaseUrl = BaseUrl
46− | BasePath Text
31+ { baseUrlScheme :: Scheme -- ^ URI scheme to use
32+ , baseUrlHost :: String -- ^ host (eg "haskell.org")
33+ , baseUrlPort :: Int -- ^ port (eg 80)
34+ , baseUrlPath :: String -- ^ path (eg "/a/b/c")
47− deriving (Ord, Read, Show, Generic)
35+ } deriving (Show, Ord, Generic)
48−
49
36
50instance Eq BaseUrl where
37instance Eq BaseUrl where
51− BasePath s == BasePath s' = s == s'
52− BaseFullUrl a b c path == BaseFullUrl a' b' c' path'
38+ BaseUrl a b c path == BaseUrl a' b' c' path'
53 = a == a' && b == b' && c == c' && s path == s path'
39 = a == a' && b == b' && c == c' && s path == s path'
54− where s x = if T.isPrefixOf "/" x then T.tail x else x
40+ where s ('/':x) = x
55− _ == _ = False
41+ s x = x
56
42
57−showBaseUrl :: BaseUrl -> Text
43+showBaseUrl :: BaseUrl -> String
58−showBaseUrl (BasePath s) = s
59−showBaseUrl (BaseFullUrl urlscheme host port path) =
44+showBaseUrl (BaseUrl urlscheme host port path) =
60− schemeString <> "//" <> host <> (portString </> path)
45+ schemeString ++ "//" ++ host ++ (portString </> path)
61 where
46 where
62− a </> b = if "/" `T.isPrefixOf` b || T.null b then a <> b else a <> "/" <> b
47+ a </> b = if "/" `isPrefixOf` b || null b then a ++ b else a ++ '/':b
63 schemeString = case urlscheme of
48 schemeString = case urlscheme of
64 Http -> "http:"
49 Http -> "http:"
65 Https -> "https:"
50 Https -> "https:"
66 portString = case (urlscheme, port) of
51 portString = case (urlscheme, port) of
67 (Http, 80) -> ""
52 (Http, 80) -> ""
68 (Https, 443) -> ""
53 (Https, 443) -> ""
69− _ -> ":" <> T.pack (show port)
54+ _ -> ":" ++ show port
55+
56+data InvalidBaseUrlException = InvalidBaseUrlException String deriving (Show, Typeable)
57+instance Exception InvalidBaseUrlException
70
58
71−baseUrlWidget :: forall t m .(SupportsServantReflex t m,
59+parseBaseUrl :: MonadThrow m => String -> m BaseUrl
72− DomBuilderSpace m ~ GhcjsDomSpace,
60+parseBaseUrl s = case parseURI (removeTrailingSlash s) of
73− MonadFix m,
61+ -- This is a rather hacky implementation and should be replaced with something
74− PostBuild t m,
62+ -- implemented in attoparsec (which is already a dependency anyhow (via aeson)).
75− MonadHold t m,
63+ Just (URI "http:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->
76− DomBuilder t m)
64+ return (BaseUrl Http host port path)
77− => m (Dynamic t BaseUrl)
65+ Just (URI "http:" (Just (URIAuth "" host "")) path "" "") ->
78−baseUrlWidget = elClass "div" "base-url" $ do
66+ return (BaseUrl Http host 80 path)
79− urlWidget <- dropdown (0 :: Int) (constDyn $ 0 =: "BasePath" <> 1 =: "BaseUrlFull") def
67+ Just (URI "https:" (Just (URIAuth "" host (':' : (readMaybe -> Just port)))) path "" "") ->
80− let bUrlWidget = ffor (value urlWidget) $ \i -> case i of
68+ return (BaseUrl Https host port path)
81− 0 -> pathWidget
69+ Just (URI "https:" (Just (URIAuth "" host "")) path "" "") ->
82− 1 -> fullUrlWidget
70+ return (BaseUrl Https host 443 path)
83− _ -> error "Surprising value"
71+ _ -> if "://" `isInfixOf` s
84− join <$> widgetHold pathWidget (updated bUrlWidget)
72+ then throwM (InvalidBaseUrlException $ "Invalid base URL: " ++ s)
85− where pathWidget :: m (Dynamic t BaseUrl)
73+ else parseBaseUrl ("http://" ++ s)
86− pathWidget = do
74+ where
87− text "Url base path"
75+ removeTrailingSlash str = case lastMay str of
88− t <- inputElement def
76+ Just '/' -> init str
89− return $ BasePath <$> value t
77+ _ -> str
90− fullUrlWidget :: m (Dynamic t BaseUrl)
91− fullUrlWidget = do
92− schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def
93− srv <- inputElement def
94− text ":"
95− prt <- inputElement def
96− port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))
97− path <- inputElement def
98− return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path
src/Servant/Common/Req.hs+177−414
@@ -1,431 +1,194 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE GADTs #-}
5{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TupleSections #-}
10−
11module Servant.Common.Req where
5module Servant.Common.Req where
12
6
13−-------------------------------------------------------------------------------
14−import Control.Applicative (liftA2, liftA3)
15−import Control.Arrow ((&&&))
7+-- import Control.Exception
16−import Control.Concurrent
8+-- import Control.Monad
17−import Control.Monad (join)
9+-- import Control.Monad.Catch (MonadThrow)
18−import Control.Monad.IO.Class (MonadIO, liftIO)
10+-- import Control.Monad.IO.Class
19−import Data.Bifunctor (first)
11+-- import Control.Monad.Trans.Except
20−import qualified Data.ByteString.Builder as Builder
21−import qualified Data.ByteString.Lazy.Char8 as BL
12+import Data.ByteString.Char8 hiding (pack, filter, map, null, elem)
22−import Data.ByteString (ByteString)
23−import qualified Data.Map as Map
13+-- import qualified Data.Foldable as F
24−import Data.Maybe (catMaybes, fromMaybe)
14+import qualified Data.List as L
25−import Data.Functor.Compose
26−import Data.Monoid ((<>))
15+-- import Data.Monoid
27−import Data.Proxy (Proxy(..))
16+-- import Data.String
17+-- import Data.String.Conversions
28−import Data.Text (Text)
18+-- import Data.Proxy
29−import qualified Data.Text as T
19+-- import Data.Text (Text)
30−import qualified Data.Text.Encoding as TE
20+-- import Data.Text.Encoding
31−import Data.Traversable (forM)
21+-- import Data.Typeable
32−import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
22+-- import Network.HTTP.Client hiding (Proxy, path)
23+-- import Network.HTTP.Media
24+-- import Network.HTTP.Types
33−import qualified Network.URI as N
25+-- import qualified Network.HTTP.Types.Header as HTTP
34−import Reflex.Dom.Core hiding (tag)
26+-- import Network.URI hiding (path)
35−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
36− SupportsServantReflex)
37−import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
27+-- import Servant.API.ContentTypes
28+import Servant.Common.BaseUrl
29+import Reflex
30+import Reflex.Dom
31+
32+-- import qualified Network.HTTP.Client as Client
33+
38−import Web.HttpApiData (ToHttpApiData(..))
34+import Web.HttpApiData
39−-------------------------------------------------------------------------------
35+
40−import Servant.API.BasicAuth
36+-- data ServantError
41−
37+-- = FailureResponse
42−
38+-- { responseStatus :: Status
43−------------------------------------------------------------------------------
39+-- , responseContentType :: MediaType
44−-- | The result of a request event
40+-- , responseBody :: ByteString
45−data ReqResult tag a
41+-- }
46− = ResponseSuccess tag a XhrResponse
42+-- | DecodeFailure
47− -- ^ The succesfully decoded response from a request tagged with 'tag'
43+-- { decodeError :: String
48− | ResponseFailure tag Text XhrResponse
44+-- , responseContentType :: MediaType
49− -- ^ The failure response, which may have failed decoding or had
45+-- , responseBody :: ByteString
50− -- a non-successful response code
46+-- }
51− | RequestFailure tag Text
47+-- | UnsupportedContentType
52− -- ^ A failure to construct the request tagged with 'tag' at trigger time
48+-- { responseContentType :: MediaType
49+-- , responseBody :: ByteString
50+-- }
51+-- | InvalidContentTypeHeader
52+-- { responseContentTypeHeader :: ByteString
53+-- , responseBody :: ByteString
54+-- }
55+-- | ConnectionError
56+-- { connectionError :: SomeException
57+-- }
53− deriving (Functor)
58+-- deriving (Show, Typeable)
54−
59+
55−data ClientOptions = ClientOptions
60+-- instance Exception ServantError
56− { optsRequestFixup :: forall a. Show a => XhrRequest a -> JSM (XhrRequest a)
57− -- ^ Aribtrarily modify requests just before they are sent.
58− -- Warning: This escape hatch opens the possibility for your
59− -- requests to diverge from what the server expects, when the
60− -- server is also derived from a servant API
61− }
62−
63−defaultClientOptions :: ClientOptions
64−defaultClientOptions = ClientOptions { optsRequestFixup = return }
65−
66−-- withCredentials :: Lens' (XhrRequest a) Bool
67−withCredentials :: (Show a, Functor f) => (Bool -> f Bool) -> XhrRequest a -> f (XhrRequest a)
68−withCredentials inj r@(XhrRequest _ _ cfg) =
69− let cfg' = (\b -> cfg { _xhrRequestConfig_withCredentials = b}) <$>
70− inj (_xhrRequestConfig_withCredentials cfg)
71− in (\c' -> r {_xhrRequest_config = c' }) <$> cfg'
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
91−reqFailure :: ReqResult tag a -> Maybe Text
92−reqFailure (ResponseFailure _ s _) = Just s
93−reqFailure (RequestFailure _ s) = Just s
94−reqFailure _ = Nothing
95−
96−------------------------------------------------------------------------------
97−-- | Simple filter/accessor like 'reqFailure', but keeping the request tag
98−reqFailure' :: ReqResult tag a -> Maybe (tag,Text)
99−reqFailure' (ResponseFailure tag s _) = Just (tag,s)
100−reqFailure' (RequestFailure tag s) = Just (tag,s)
101−reqFailure' _ = Nothing
102−
103−
104−------------------------------------------------------------------------------
105−-- | Simple filter/accessor for the raw XHR response
106−response :: ReqResult tag a -> Maybe XhrResponse
107−response (ResponseSuccess _ _ x) = Just x
108−response (ResponseFailure _ _ x) = Just x
109−response _ = Nothing
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
61
118−-------------------------------------------------------------------------------
119−-- | You must wrap the parameter of a QueryParam endpoint with 'QParam' to
120−-- indicate whether the parameter is valid and present, validly absent, or
121−-- invalid
122−data QParam a = QParamSome a
123− -- ^ A valid query parameter
124− | QNone
125− -- ^ Indication that the parameter is intentionally absent (the request is valid)
126− | QParamInvalid Text
127− -- ^ Indication that your validation failed (the request isn't valid)
128−
129−
130−qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)
131−qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)
132−qParamToQueryPart QNone = Right Nothing
133−qParamToQueryPart (QParamInvalid e) = Left e
134−
135−
136−data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
137− | QueryPartParams (Dynamic t [Text])
138− | QueryPartFlag (Dynamic t Bool)
139−
140−
141−-------------------------------------------------------------------------------
142−-- The data structure used to build up request information while traversing
143−-- the shape of a servant API
144data Req t = Req
62data Req t = Req
145− { reqMethod :: Text
63+ { reqPathParts :: [Behavior t (Maybe String)]
146− , reqPathParts :: [Dynamic t (Either Text Text)]
64+ , qParams :: [(String, Behavior t String)]
147− , qParams :: [(Text, QueryPart t)]
148− , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))
65+ , reqBody :: Maybe (ByteString, String)
149− , headers :: [(Text, Dynamic t (Either Text Text))]
66+ -- , reqAccept :: [MediaType]
150− , respHeaders :: XhrResponseHeaders
67+ , headers :: [(String, Behavior t String)]
151− , authData :: Maybe (Dynamic t (Maybe BasicAuthData))
152 }
68 }
153
69
154defReq :: Req t
70defReq :: Req t
155−defReq = Req "GET" [] [] Nothing [] def Nothing
71+defReq = Req [] [] Nothing []
156
72
157−prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t
73+prependToPathParts :: Reflex t => Behavior t (Maybe String) -> Req t -> Req t
158prependToPathParts p req =
74prependToPathParts p req =
159 req { reqPathParts = p : reqPathParts req }
75 req { reqPathParts = p : reqPathParts req }
160
76
161−addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
77+addHeader :: (ToHttpApiData a, Reflex t) => String -> Behavior t (Maybe a) -> Req t -> Req t
78+addHeader name val req = req { headers = headers req
79+ ++ [(name, fmap (unpack . toHeader) val)]
162−addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
80+-- ++ [(name, (fmap . fmap) (decodeUtf8 . toHeader) val)]
163−
81+ }
164−
82+
165−reqToReflexRequest
83+-- setRQBody :: ByteString -> String -> Req -> Req
166− :: forall t. Reflex t
84+-- setRQBody b t req = req { reqBody = Just (b, t) }
167− => Text
85+
168− -> Dynamic t BaseUrl
86+-- TODO: Helpful soon!
169− -> Req t
87+-- reqToRequest :: (Reflex t, Functor m, MonadThrow m) => Req t -> BaseUrl -> m Request
170− -> Dynamic t (Either Text (XhrRequest XhrPayload))
88+-- reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
171−reqToReflexRequest reqMeth reqHost req =
89+-- setheaders . setAccept . setrqb . setQS <$> parseUrl url
172− let t :: Dynamic t [Either Text Text]
90+
173− t = sequence $ reverse $ reqPathParts req
91+-- where url = show $ nullURI { uriScheme = case reqScheme of
174−
92+-- Http -> "http:"
175− baseUrl :: Dynamic t (Either Text Text)
93+-- Https -> "https:"
176− baseUrl = Right . showBaseUrl <$> reqHost
94+-- , uriAuthority = Just $
177−
95+-- URIAuth { uriUserInfo = ""
178− urlParts :: Dynamic t (Either Text [Text])
96+-- , uriRegName = reqHost
179− urlParts = fmap sequence t
97+-- , uriPort = ":" ++ show reqPort
180−
98+-- }
181− urlPath :: Dynamic t (Either Text Text)
99+-- , uriPath = path ++ reqPath req
182− urlPath = (fmap.fmap)
183− (T.intercalate "/" . fmap escape)
184− urlParts
185−
186− queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
187− queryPartString (pName, qp) = case qp of
188− QueryPartParam p -> ffor p $ \case
189− Left e -> Just (Left e)
190− Right (Just a) -> Just (Right $ pName <> "=" <> escape a)
191− Right Nothing -> Nothing
192− QueryPartParams ps -> ffor ps $ \pStrings ->
193− if null pStrings
194− then Nothing
195− else Just . Right
196− . T.intercalate "&"
197− $ fmap (\p -> pName <> "=" <> escape p) pStrings
198− QueryPartFlag fl -> ffor fl $ \case
199− True -> Just $ Right pName
200− False -> Nothing
201−
202−
203− queryPartStrings :: [Dynamic t (Maybe (Either Text Text))]
204− queryPartStrings = map queryPartString (qParams req)
205− queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Dynamic t (Either Text [Text])
206− queryString :: Dynamic t (Either Text Text) =
207− ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs
208− xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q)
209− baseUrl urlPath queryString
210− where
211− (</>) :: Text -> Text -> Text
212− x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y
213− | otherwise = x <> "/" <> y
214−
215−
216− xhrHeaders :: Dynamic t (Either Text [(Text, Text)])
217− xhrHeaders = (fmap sequence . sequence . fmap f . headers) req
218− where
219− f = \(headerName, dynam) ->
220− fmap (fmap (\rightVal -> (headerName, rightVal))) dynam
221−
222− mkConfigBody :: Either Text [(Text,Text)]
223− -> (Either Text (BL.ByteString, Text))
224− -> Either Text (XhrRequestConfig XhrPayload)
225− mkConfigBody ehs rb = case (ehs, rb) of
226− (_, Left e) -> Left e
227− (Left e, _) -> Left e
228− (Right hs, Right (bBytes, bCT)) ->
229− Right $ XhrRequestConfig
230− { _xhrRequestConfig_sendData = bytesToPayload bBytes
231− , _xhrRequestConfig_headers =
232− Map.insert "Content-Type" bCT (Map.fromList hs)
233− , _xhrRequestConfig_user = Nothing
234− , _xhrRequestConfig_password = Nothing
235− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
236− , _xhrRequestConfig_withCredentials = False
237− , _xhrRequestConfig_responseHeaders = def
238− }
239−
240− xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))
241− xhrOpts = case reqBody req of
242− Nothing -> ffor xhrHeaders $ \case
243− Left e -> Left e
244− Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
245− , _xhrRequestConfig_user = Nothing
246− , _xhrRequestConfig_password = Nothing
247− , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
248− , _xhrRequestConfig_sendData = mempty
249− , _xhrRequestConfig_withCredentials = False
250− }
100+-- }
251− Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
101+
252−
102+-- setrqb r = case reqBody req of
253− mkAuth :: Maybe BasicAuthData -> Either Text (XhrRequestConfig x) -> Either Text (XhrRequestConfig x)
103+-- Nothing -> r
254− mkAuth _ (Left e) = Left e
104+-- Just (b,t) -> r { requestBody = RequestBodyLBS b
255− mkAuth Nothing r = r
105+-- , requestHeaders = requestHeaders r
256− mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config
106+-- ++ [(hContentType, cs . show $ t)] }
257− { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
107+-- setQS = setQueryString $ queryTextToQuery (qs req)
258− , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
108+-- setheaders r = r { requestHeaders = requestHeaders r
259−
109+-- <> fmap toProperHeader (headers req) }
260− addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
110+-- setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
261− -> Dynamic t (Either Text (XhrRequestConfig x))
111+-- <> [("Accept", renderHeader $ reqAccept req)
262− addAuth xhr = case authData req of
112+-- | not . null . reqAccept $ req] }
263− Nothing -> xhr
113+-- toProperHeader (name, val) =
264− Just auth -> liftA2 mkAuth auth xhr
114+-- (fromString name, encodeUtf8 val)
265−
266− xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
267−
268− in xhrReq
269
115
270-- * performing requests
116-- * performing requests
271
117
272−displayHttpRequest :: Text -> Text
118+displayHttpRequest :: String -> String
273−displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
119+displayHttpRequest httpmethod = "HTTP " ++ httpmethod ++ " request"
274−
120+
275−-- | This function performs the request
121+
276−performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
277− => Text
278− -> Dynamic t (f (Req t))
279− -> Dynamic t BaseUrl
122+performRequest :: forall t m.MonadWidget t m => String -> Req t -> Dynamic t BaseUrl
280− -> ClientOptions
281− -> Event t tag
123+ -> Event t ()
282− -> m (Event t (tag, f (Either Text XhrResponse)))
124+ -> m (Event t XhrResponse)
283−performRequests reqMeth rs reqHost opts trigger = do
125+ -- -> ExceptT ServantError IO ( Int, ByteString, MediaType
284− let xhrReqs =
126+ -- , [HTTP.Header], Response ByteString)
285− join $ (\(fxhr :: f (Req t)) -> sequence $
127+performRequest reqMethod req _ trigger = do
286− reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
128+ let t :: Behavior t [Maybe String] = sequence $ reqPathParts req
287−
129+ let urlParts :: Behavior t (Maybe [String]) = fmap sequence t
288− -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
130+ let urlPath :: Behavior t (Maybe String) = (fmap.fmap) (L.intercalate "/") urlParts
289− reqs = attachPromptlyDynWith
131+ xhrReq = (fmap . fmap) (\p -> XhrRequest reqMethod p def) urlPath
290− (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
132+ performRequestAsync (fmapMaybe id $ tag xhrReq trigger)
291−
133+
292− resps <- performSomeRequestsAsync opts reqs
134+-- TODO implement
293− return $ getCompose <$> resps
135+-- => String -> Req -> BaseUrl -> ExceptT ServantError IO [HTTP.Header]
294−
136+performRequestNoBody ::
295−-- | Issues a collection of requests when the supplied Event fires.
137+ forall t m .MonadWidget t m => String -> Req t -> Dynamic t BaseUrl
296−-- When ALL requests from a given firing complete, the results are
138+ -> Event t () -> m (Event t XhrResponse)
297−-- collected and returned via the return Event.
139+performRequestNoBody reqMethod req reqHost trigger = do
298−performSomeRequestsAsync
140+ performRequest reqMethod req reqHost trigger
299− :: (MonadIO (Performable m),
141+ -- return hdrs
300− MonadJSM (Performable m),
142+
301− HasWebView (Performable m),
143+performRequestCT :: (MonadWidget t m, FromHttpApiData a)
302− PerformEvent t m,
144+ => String -> Req t -> Dynamic t BaseUrl
303− TriggerEvent t m,
145+ -> Event t () -> m (Event t (Maybe a, XhrResponse))
304− Traversable f,
146+performRequestCT reqMethod req reqHost trigger = do
305− IsXhrPayload a,
147+ fmap () -- TODO
306− Show a
148+
307− )
149+
308− => ClientOptions
150+ -- partialRequest <- liftIO $ reqToRequest req reqHost
309− -> Event t (f (Either Text (XhrRequest a)))
151+
310− -> m (Event t (f (Either Text XhrResponse)))
152+ -- let request = partialRequest { Client.method = reqMethod
311−performSomeRequestsAsync opts =
153+ -- , checkStatus = \ _status _headers _cookies -> Nothing
312− performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
154+ -- , qs :: QueryText
313−
155+ -- , qs :: QueryText
314−
156+ -- }
315−------------------------------------------------------------------------------
157+
316−-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
158+ -- eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
317−-- that accepts 'f (Either e (XhrRequestb))' events
159+ -- case eResponse of
318−performSomeRequestsAsync'
160+ -- Left err ->
319− :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
161+ -- throwE . ConnectionError $ SomeException err
320− => ClientOptions
162+
321− -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
163+ -- Right response -> do
322− -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
164+ -- let status = Client.responseStatus response
323−performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
165+ -- body = Client.responseBody response
324− rs <- hrs
166+ -- hdrs = Client.responseHeaders response
325− resps <- forM rs $ \r -> case r of
167+ -- status_code = statusCode status
326− Left e -> do
168+ -- ct <- case lookup "Content-Type" $ Client.responseHeaders response of
327− resp <- liftIO $ newMVar (Left e)
169+ -- Nothing -> pure $ "application/octet-stream"
328− return resp
170+ -- Just t -> case parseAccept t of
329− Right r' -> do
171+ -- Nothing -> throwE $ InvalidContentTypeHeader (cs t) body
330− resp <- liftIO newEmptyMVar
172+ -- Just t' -> pure t'
331− r'' <- liftJSM $ (optsRequestFixup opts) r'
173+ -- unless (status_code >= 200 && status_code < 300) $
332− _ <- newXhr r'' $ liftIO . putMVar resp . Right
174+ -- throwE $ FailureResponse status ct body
333− return resp
175+ -- return (status_code, body, ct, hdrs, response)
334− _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
176+
335− return ()
177+
336−
178+-- TODO implement
337−
338−
339−type XhrPayload = ByteString
340−bytesToPayload :: BL.ByteString -> XhrPayload
341−bytesToPayload = BL.toStrict
342−
343−
344−performRequestsCT
345− :: (SupportsServantReflex t m,
346− MimeUnrender ct a, Traversable f)
179+-- performRequestCT :: (MimeUnrender ct result, Reflex t) =>
347− => Proxy ct
180+-- Proxy ct -> String -> Req t -> BaseUrl -> Event t ()
348− -> Text
181+-- -> m (Event t (Maybe result, XhrResponse)) -- ExceptT ServantError IO ([HTTP.Header], result)
349− -> Dynamic t (f (Req t))
182+-- performRequestCT ct reqMethod req reqHost = do
350− -> Dynamic t BaseUrl
183+-- let acceptCT = contentType ct
351− -> ClientOptions
184+-- (_status, respBody, respCT, hdrs, _response) <-
352− -> Event t tag
185+-- performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager
353− -> m (Event t (f (ReqResult tag a)))
186+-- unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
354−performRequestsCT ct reqMeth reqs reqHost opts trigger = do
355− resps <- performRequests reqMeth reqs reqHost opts trigger
356− let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
357− first T.pack .
358− mimeUnrender ct $
187+-- case mimeUnrender ct respBody of
359− BL.fromStrict x
188+-- Left err -> throwE $ DecodeFailure err respCT respBody
360− decodeResp _ = Left "No body"
189+-- Right val -> return (hdrs, val)
361− return $ fmap
190+
362− (\(t,rs) -> ffor rs $ \r -> case r of
191+-- catchConnectionError :: IO a -> IO (Either ServantError a)
363− Left e -> RequestFailure t e
192+-- catchConnectionError action =
364− Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
193+-- catch (Right <$> action) $ \e ->
365− )
194+-- pure . Left . ConnectionError $ SomeException (e :: HttpException)
366− resps
367−
368−
369−performRequestsNoBody
370− :: (SupportsServantReflex t m,
371− Traversable f)
372− => Text
373− -> Dynamic t (f (Req t))
374− -> Dynamic t BaseUrl
375− -> ClientOptions
376− -> Event t tag
377− -> m (Event t (f (ReqResult tag NoContent)))
378−performRequestsNoBody reqMeth reqs reqHost opts trigger = do
379− resps <- performRequests reqMeth reqs reqHost opts trigger
380− let decodeResp = const $ Right NoContent
381− return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
382− Left e -> RequestFailure tag e
383− Right g -> evalResponse decodeResp (tag,g)
384−
385−
386−------------------------------------------------------------------------------
387−evalResponse
388− :: (XhrResponse -> Either Text a)
389− -> (tag, XhrResponse)
390− -> ReqResult tag a
391−evalResponse decode (tag, xhr) =
392− let status = _xhrResponse_status xhr
393− okStatus = status >= 200 && status < 400
394− errMsg = fromMaybe
395− ("Empty response with error code " <>
396− T.pack (show $ _xhrResponse_status xhr))
397− (_xhrResponse_responseText xhr)
398− respPayld = if okStatus
399− then either
400− (\e -> ResponseFailure tag e xhr)
401− (\v -> ResponseSuccess tag v xhr)
402− (decode xhr)
403− else ResponseFailure tag errMsg xhr
404− in respPayld
405−
406−------------------------------------------------------------------------------
407−-- | Utility for simultaneously accessing/filtering Success and Failure
408−-- response 'Event's,
409−fanReqResult :: Reflex t => Event t (ReqResult tag a) -> (Event t Text, Event t a)
410−fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess
411−
412−------------------------------------------------------------------------------
413−-- | Utility for simultaneously accessing/filtering Success and Failure
414−-- response 'Event's, but keeping the request tag
415−fanReqResult' :: Reflex t => Event t (ReqResult tag a) -> (Event t (tag, Text), Event t (tag, a))
416−fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'
417−
418−
419−note :: e -> Maybe a -> Either e a
420−note e = maybe (Left e) Right
421−
422−fmapL :: (e -> e') -> Either e a -> Either e' a
423−fmapL _ (Right a) = Right a
424−fmapL f (Left e) = Left (f e)
425−
426−builderToText :: Builder.Builder -> T.Text
427−builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
428−
429−escape :: T.Text -> T.Text
430−escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
431−
src/Servant/Reflex.hs+196−398
@@ -1,23 +1,15 @@
1−{-# LANGUAGE AllowAmbiguousTypes #-}
1+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE CPP #-}
3−{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DataKinds #-}
4−{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE InstanceSigs #-}
5+{-# LANGUAGE InstanceSigs #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
7+{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE Rank2Types #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE TupleSections #-}
14−{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeFamilies #-}
15−{-# LANGUAGE TypeOperators #-}
10+{-# LANGUAGE TypeOperators #-}
16−{-# LANGUAGE UndecidableInstances #-}
11+{-# LANGUAGE UndecidableInstances #-}
17−
12+{-# LANGUAGE MultiParamTypeClasses #-}
18−#if MIN_VERSION_base(4,9,0)
19−{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
20−#endif
21
13
22-- #include "overlapping-compat.h"
14-- #include "overlapping-compat.h"
23-- | This module provides 'client' which can automatically generate
15-- | This module provides 'client' which can automatically generate
@@ -25,71 +17,28 @@
25-- API.
17-- API.
26module Servant.Reflex
18module Servant.Reflex
27 ( client
19 ( client
28− , clientWithOpts
29− , clientWithOptsAndResultHandler
30− , clientWithRoute
31− , clientWithRouteAndResultHandler
32− , BuildHeaderKeysTo(..)
33− , toHeaders
34− , HasClient
20+ , HasClient(..)
35− , Client
21+ , ServantError(..)
36− , module Servant.Common.Req
37 , module Servant.Common.BaseUrl
22 , module Servant.Common.BaseUrl
38 ) where
23 ) where
39
24
40−------------------------------------------------------------------------------
41−import Control.Applicative
25+import Control.Applicative ((<$>))
42−import qualified Data.CaseInsensitive as CI
26+import Control.Monad.Trans.Except
43−import Data.Functor.Identity
44−import qualified Data.Map as Map
45−import Data.Monoid ((<>))
27+import Data.ByteString.Lazy (ByteString)
46−import Data.Proxy (Proxy (..))
28+import Data.List
47−import qualified Data.Set as Set
29+import Data.Proxy
48−import Data.Text (Text)
30+import Data.String.Conversions
49−import qualified Data.Text as T
50−import qualified Data.Text.Encoding as E
31+import Data.Text (unpack)
51−import GHC.Exts (Constraint)
52−import GHC.TypeLits (KnownSymbol, symbolVal)
32+import GHC.TypeLits
53−import Servant.API ((:<|>) (..), (:>), BasicAuth,
33+-- import Network.HTTP.Media
54− BasicAuthData, BuildHeadersTo (..),
34+-- import qualified Network.HTTP.Types as H
55− Capture, Header, Headers (..),
35+-- import qualified Network.HTTP.Types.Header as HTTP
56− HttpVersion, IsSecure,
36+import Servant.API
57− MimeRender (..), MimeUnrender,
58− NoContent, QueryFlag, QueryParam,
59− QueryParams, Raw, ReflectMethod (..),
60− RemoteHost, ReqBody,
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−------------------------------------------------------------------------------
73−import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
74− showBaseUrl,
75− SupportsServantReflex)
76−import Servant.Common.Req (ClientOptions(..),
37+import Servant.Common.BaseUrl
77− defaultClientOptions,
38+import Servant.Common.Req
78− Req, ReqResult(..), QParam(..),
39+import Reflex
79− QueryPart(..), addHeader, authData,
40+import Reflex.Dom
80− defReq, evalResponse, prependToPathParts,
41+import Reflex.Dom.Xhr
81− -- performRequestCT,
82− performRequestsCT,
83− -- performRequestNoBody,
84− performRequestsNoBody,
85− performSomeRequestsAsync,
86− qParamToQueryPart, reqBody,
87− reqSuccess, reqFailure,
88− reqMethod, respHeaders,
89− response,
90− reqTag,
91− qParams, withCredentials)
92−
93
42
94-- * Accessing APIs as a Client
43-- * Accessing APIs as a Client
95
44
@@ -101,193 +50,113 @@ import Servant.Common.Req (ClientOptions(..),
101-- > myApi :: Proxy MyApi
50-- > myApi :: Proxy MyApi
102-- > myApi = Proxy
51-- > myApi = Proxy
103-- >
52-- >
104−-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
53+-- > getAllBooks :: Event t () -> m (Event t (Either XhrError ((),[Book])))
105−-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
54+-- > postNewBook :: Behavior t (Maybe Book) -> Event t ()
106−-- > -> m (Event t (l, ReqResult Book)))
55+-- -> m (Event t (Either XhrError (Book,Book)))
107-- > (getAllBooks :<|> postNewBook) = client myApi host
56-- > (getAllBooks :<|> postNewBook) = client myApi host
108-- > where host = constDyn $ BaseUrl Http "localhost" 8080
57-- > 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
119− :: (HasClient t m layout tag)
58+client :: (HasClient t m layout) => Proxy layout -> Dynamic t BaseUrl -> Client t m layout
120− => Proxy layout
121− -> Proxy m
122− -> Proxy tag
123− -> Dynamic t BaseUrl
124− -> ClientOptions
125− -> Client t m layout tag
126−clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl
59+client p baseurl = clientWithRoute p 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
60
143-- | This class lets us define how each API combinator
61-- | This class lets us define how each API combinator
144-- influences the creation of an HTTP request. It's mostly
62-- influences the creation of an HTTP request. It's mostly
145-- an internal class, you can just use 'client'.
63-- an internal class, you can just use 'client'.
146−class Monad m => HasClient t m layout (tag :: *) where
64+class HasClient t m layout where
147− type Client t m layout tag :: *
65+ type Client t m layout :: *
148− clientWithRoute
66+ clientWithRoute :: Proxy layout -> Req t -> BaseUrl -> Client t m layout
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
67
176
68
69+instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where
70+ type Client t m (a :<|> b) = Client t m a :<|> Client t m b
71+ clientWithRoute Proxy req baseurl =
72+ clientWithRoute (Proxy :: Proxy a) req baseurl :<|>
73+ clientWithRoute (Proxy :: Proxy b) req baseurl
74+
177-- Capture. Example:
75-- Capture. Example:
178-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
76-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
179-- >
77-- >
180-- > myApi :: Proxy MyApi = Proxy
78-- > myApi :: Proxy MyApi = Proxy
181-- >
79-- >
182−-- > getBook :: SupportsServantReflex t m
80+-- > getBook :: MonadWidget t m
183-- => Dynamic t BaseUrl
81-- => Dynamic t BaseUrl
184−-- -> Dynamic t (Maybe Text)
82+-- -> Behavior t (Maybe Text)
185−-- -> Event t l
83+-- -> Event t ()
186−-- -> m (Event t (l, ReqResult Book))
84+-- -> m (Event t (Either XhrError (Text, Book)))
187-- > getBook = client myApi (constDyn host)
85-- > getBook = client myApi (constDyn host)
86+instance (MonadWidget t m, KnownSymbol capture, ToHttpApiData a, HasClient t m sublayout)
87+ => HasClient t m (Capture capture a :> sublayout) where
188
88
189−instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout tag)
190− => HasClient t m (Capture capture a :> sublayout) tag where
191−
192− type Client t m (Capture capture a :> sublayout) tag =
89+ type Client t m (Capture capture a :> sublayout) =
193− Dynamic t (Either Text a) -> Client t m sublayout tag
90+ Behavior t (Maybe a) -> Client t m sublayout
194
91
195− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =
92+ clientWithRoute Proxy req baseurl val =
196− clientWithRouteAndResultHandler
93+ clientWithRoute (Proxy :: Proxy sublayout)
197− (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap
94+ (prependToPathParts p req)
198− where p = (fmap . fmap) (toUrlPiece) val
95+ baseurl
199
96
97+ where p = fmap (unpack . toUrlPiece) val
200
98
201-- VERB (Returning content) --
99-- VERB (Returning content) --
202instance {-# OVERLAPPABLE #-}
100instance {-# OVERLAPPABLE #-}
203 -- Note [Non-Empty Content Types]
101 -- Note [Non-Empty Content Types]
204− (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
102+ (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), MonadWidget t m
205− ) => HasClient t m (Verb method status cts' a) tag where
103+ ) => HasClient t m (Verb method status cts' a) where
206− type Client t m (Verb method status cts' a) tag =
104+ type Client t m (Verb method status cts' a) =
207− Event t tag -> m (Event t (ReqResult tag a))
105+ Event t () -> m (Event t (Maybe a, XhrResponse))
208 -- TODO how to access input types here?
106 -- TODO how to access input types here?
209 -- ExceptT ServantError IO a
107 -- ExceptT ServantError IO a
210− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
108+ clientWithRoute Proxy req baseurl =
211− wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs
109+ performRequestCT (Proxy :: Proxy ct) method req baseurl
212− where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
110+ where method = reflectMethod (Proxy :: Proxy method)
213− req' = req { reqMethod = method }
111+
214−
215−
216−-- -- VERB (No content) --
112+-- VERB (No content) --
217−instance {-# OVERLAPPING #-}
113+instance {-# OVERLAPPABLE #-}
218− (ReflectMethod method, SupportsServantReflex t m) =>
114+ (ReflectMethod method, MonadWidget t m) =>
219− HasClient t m (Verb method status cts NoContent) tag where
115+ HasClient t m (Verb method status cts NoContent) where
220− type Client t m (Verb method status cts NoContent) tag =
116+ type Client t m (Verb method status cts NoContent) =
221− Event t tag -> m (Event t (ReqResult tag NoContent))
117+ Event t () -> m (Event t XhrResponse)
222 -- TODO: how to access input types here?
118 -- TODO: how to access input types here?
223 -- ExceptT ServantError IO NoContent
119 -- ExceptT ServantError IO NoContent
224− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =
120+ clientWithRoute Proxy req baseurl =
225− wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs
121+ performRequestNoBody method req baseurl
226− where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
122+ where method = reflectMethod (Proxy :: Proxy method)
227−
228−
229−toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
230−toHeaders r =
231− let hdrs = maybe []
232− (\xhr -> fmap (\(h,v) -> (CI.map E.encodeUtf8 h, E.encodeUtf8 v))
233− (Map.toList $ _xhrResponse_headers xhr))
234− (response r)
235− in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}
236−
237−
238−class BuildHeaderKeysTo hs where
239− buildHeaderKeysTo :: Proxy hs -> [CI.CI T.Text]
240−
241−instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
242− where buildHeaderKeysTo _ = []
243−
244−instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
245− => BuildHeaderKeysTo ((Header h v) ': xs) where
246− buildHeaderKeysTo _ =
247− let
248− thisKey = CI.mk $ T.pack (symbolVal (Proxy :: Proxy h))
249− in thisKey : buildHeaderKeysTo (Proxy :: Proxy xs)
250−
251
123
252-- HEADERS Verb (Content) --
124-- HEADERS Verb (Content) --
253-- Headers combinator not treated in fully general case,
125-- Headers combinator not treated in fully general case,
254-- in order to deny instances for (Headers ls (Capture "id" Int)),
126-- in order to deny instances for (Headers ls (Capture "id" Int)),
255-- a combinator that wouldn't make sense
127-- a combinator that wouldn't make sense
256−-- TODO Overlapping??
257instance {-# OVERLAPPABLE #-}
128instance {-# OVERLAPPABLE #-}
258 -- Note [Non-Empty Content Types]
129 -- Note [Non-Empty Content Types]
259− ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
130+ ( MimeUnrender ct a, BuildHeadersTo ls,
260 ReflectMethod method, cts' ~ (ct ': cts),
131 ReflectMethod method, cts' ~ (ct ': cts),
261− SupportsServantReflex t m
132+ MonadWidget t m
262− ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
133+ ) => HasClient t m (Verb method status cts' (Headers ls a)) where
263− type Client t m (Verb method status cts' (Headers ls a)) tag =
134+ type Client t m (Verb method status cts' (Headers ls a))
264− Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
135+ = Event t () -> m (Event t (Maybe a, XhrResponse))
265− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
136+ -- ExceptT ServantError IO (Headers ls a)
137+ clientWithRoute Proxy req baseurl = do
266− let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
138+ let method = reflectMethod (Proxy :: Proxy method)
267− resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs
139+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl
268− wrap $ toHeaders <$> resp
140+ return $ Headers { getResponse = resp
269− where req' = req { respHeaders =
141+ , getHeadersHList = buildHeadersTo hdrs
270− OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
271 }
142 }
272
143
273−
274-- HEADERS Verb (No content) --
144-- HEADERS Verb (No content) --
275instance {-# OVERLAPPABLE #-}
145instance {-# OVERLAPPABLE #-}
276− ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,
146+ ( BuildHeadersTo ls, ReflectMethod method,
277− SupportsServantReflex t m
147+ MonadWidget t m
278− ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
148+ ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where
279− type Client t m (Verb method status cts (Headers ls NoContent)) tag
149+ type Client t m (Verb method status cts (Headers ls NoContent))
150+ = Event t () -> m (Event t XhrResponse)
280− = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
151+ -- ExceptT ServantError IO (Headers ls NoContent)
281− clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do
152+ clientWithRoute Proxy req baseurl = do
282− let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
153+ let method = reflectMethod (Proxy :: Proxy method)
283− resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs
154+ hdrs <- performRequestNoBody method req baseurl
284− wrap $ toHeaders <$> resp
155+ return $ Headers { getResponse = NoContent
285− where req' = req {respHeaders =
156+ , getHeadersHList = buildHeadersTo hdrs
286− OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
287 }
157 }
288
158
289
159
290−
291-- HEADER
160-- HEADER
292-- > newtype Referer = Referer { referrer :: Text }
161-- > newtype Referer = Referer { referrer :: Text }
293-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)
162-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)
@@ -302,46 +171,32 @@ instance {-# OVERLAPPABLE #-}
302-- > -- then you can just use "viewRefer" to query that endpoint
171-- > -- then you can just use "viewRefer" to query that endpoint
303-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
172-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
304instance (KnownSymbol sym, ToHttpApiData a,
173instance (KnownSymbol sym, ToHttpApiData a,
305− HasClient t m sublayout tag, SupportsServantReflex t m)
174+ HasClient t m sublayout, MonadWidget t m)
306− => HasClient t m (Header sym a :> sublayout) tag where
175+ => HasClient t m (Header sym a :> sublayout) where
307−
308− type Client t m (Header sym a :> sublayout) tag =
309− Dynamic t (Either Text a) -> Client t m sublayout tag
310−
311− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =
312− clientWithRouteAndResultHandler
313− (Proxy :: Proxy sublayout) q t
314− (Servant.Common.Req.addHeader hname eVal req)
315− baseurl opts wrap
316− where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
317
176
177+ type Client t m (Header sym a :> sublayout) =
178+ Behavior t (Maybe a) -> Client t m sublayout
318
179
180+ clientWithRoute Proxy req baseurl mval =
181+ clientWithRoute (Proxy :: Proxy sublayout)
182+ (maybe req
183+ (\value -> Servant.Common.Req.addHeader hname value req)
184+ mval
185+ )
186+ baseurl
319
187
188+ where hname = symbolVal (Proxy :: Proxy sym)
320
189
321-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
190-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
322-- functions.
191-- functions.
323−instance HasClient t m sublayout tag
192+instance HasClient t m sublayout
324− => HasClient t m (HttpVersion :> sublayout) tag where
193+ => HasClient t m (HttpVersion :> sublayout) 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)
342−
343
194
195+ type Client t m (HttpVersion :> sublayout) =
196+ Client t m sublayout
344
197
198+ clientWithRoute Proxy =
199+ clientWithRoute (Proxy :: Proxy sublayout)
345
200
346-- | If you use a 'QueryParam' in one of your endpoints in your API,
201-- | If you use a 'QueryParam' in one of your endpoints in your API,
347-- the corresponding querying function will automatically take
202-- the corresponding querying function will automatically take
@@ -369,24 +224,22 @@ instance (HasClient t m sublayout tag, KnownSymbol sym)
369-- > -- then you can just use "getBooksBy" to query that endpoint.
224-- > -- then you can just use "getBooksBy" to query that endpoint.
370-- > -- 'getBooksBy Nothing' for all books
225-- > -- 'getBooksBy Nothing' for all books
371-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
226-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
372−instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)
227+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)
373− => HasClient t m (QueryParam sym a :> sublayout) tag where
228+ => HasClient t m (QueryParam sym a :> sublayout) where
374
229
375− type Client t m (QueryParam sym a :> sublayout) tag =
230+ type Client t m (QueryParam sym a :> sublayout) =
231+ -- TODO (Maybe a), or (Maybe (Maybe a))? (should the user be able to send a Nothing)
376− Dynamic t (QParam a) -> Client t m sublayout tag
232+ Behavior t (Maybe a) -> Client t m sublayout
377
233
378 -- if mparam = Nothing, we don't add it to the query string
234 -- if mparam = Nothing, we don't add it to the query string
379− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =
235+ clientWithRoute Proxy req baseurl mparam =
380− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
236+ clientWithRoute (Proxy :: Proxy sublayout)
381− (req {qParams = paramPair : qParams req}) baseurl opts wrap
237+ (req {qParams = (pname', map show mparam) : qParams req})
382−
238+ baseurl
383− where pname = symbolVal (Proxy :: Proxy sym)
384− --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm
385− --paramPair = (T.pack pname, p mparam)
386− p prm = QueryPartParam $ fmap qParamToQueryPart prm -- (fmap . fmap) (unpack . toQueryParam) prm
387− paramPair = (T.pack pname, p mparam)
388−
389
239
240+ where pname = cs pname'
241+ pname' = symbolVal (Proxy :: Proxy sym)
242+ mparamText = fmap toQueryParam mparam
390
243
391-- | If you use a 'QueryParams' in one of your endpoints in your API,
244-- | If you use a 'QueryParams' in one of your endpoints in your API,
392-- the corresponding querying function will automatically take
245-- the corresponding querying function will automatically take
@@ -416,21 +269,23 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
416-- > -- 'getBooksBy []' for all books
269-- > -- 'getBooksBy []' for all books
417-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
270-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
418-- > -- to get all books by Asimov and Heinlein
271-- > -- to get all books by Asimov and Heinlein
419−instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)
272+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)
420− => HasClient t m (QueryParams sym a :> sublayout) tag where
273+ => HasClient t m (QueryParams sym a :> sublayout) where
421−
422− type Client t m (QueryParams sym a :> sublayout) tag =
423− Dynamic t [a] -> Client t m sublayout tag
424
274
425− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =
275+ type Client t m (QueryParams sym a :> sublayout) =
426− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
276+ [a] -> Client t m sublayout
427−
428− where req' = req { qParams = (T.pack pname, params') : qParams req }
429− pname = symbolVal (Proxy :: Proxy sym)
430− params' = QueryPartParams $ (fmap . fmap) toQueryParam
431− paramlist
432
277
278+ clientWithRoute Proxy req baseurl paramlist =
279+ clientWithRoute (Proxy :: Proxy sublayout)
280+ (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
281+ req
282+ paramlist'
283+ )
284+ baseurl
433
285
286+ where pname = cs pname'
287+ pname' = symbolVal (Proxy :: Proxy sym)
288+ paramlist' = map (Just . toQueryParam) paramlist
434
289
435-- | If you use a 'QueryFlag' in one of your endpoints in your API,
290-- | If you use a 'QueryFlag' in one of your endpoints in your API,
436-- the corresponding querying function will automatically take
291-- the corresponding querying function will automatically take
@@ -454,44 +309,32 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex
454-- > -- then you can just use "getBooks" to query that endpoint.
309-- > -- then you can just use "getBooks" to query that endpoint.
455-- > -- 'getBooksBy False' for all books
310-- > -- 'getBooksBy False' for all books
456-- > -- 'getBooksBy True' to only get _already published_ books
311-- > -- 'getBooksBy True' to only get _already published_ books
312+instance (KnownSymbol sym, HasClient t m sublayout)
313+ => HasClient t m (QueryFlag sym :> sublayout) where
457
314
458−-- TODO Bring back
459−instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
460− => HasClient t m (QueryFlag sym :> sublayout) tag where
461−
462− type Client t m (QueryFlag sym :> sublayout) tag =
315+ type Client t m (QueryFlag sym :> sublayout) =
463− Dynamic t Bool -> Client t m sublayout tag
316+ Bool -> Client t m sublayout
464−
465− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =
466− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
467−
468− where req' = req { qParams = thisPair : qParams req }
469− thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
470− pName = symbolVal (Proxy :: Proxy sym)
471
317
318+ clientWithRoute Proxy req baseurl flag =
319+ clientWithRoute (Proxy :: Proxy sublayout)
320+ (if flag
321+ then appendToQueryString paramname Nothing req
322+ else req
323+ )
324+ baseurl
472
325
326+ where paramname = cs $ symbolVal (Proxy :: Proxy sym)
473
327
474−-- | Send a raw 'XhrRequest ()' directly to 'baseurl'
475−instance SupportsServantReflex t m => HasClient t m Raw tag where
476− type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))
477− -> Event t tag
478− -> m (Event t (ReqResult tag ()))
479
328
480− clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do
329+-- | Pick a 'Method' and specify where the server you want to query is. You get
481−
330+-- back the full `Response`.
482− let xhrs' = liftA2 (\x path -> case x of
331+-- TODO redo
483− Left e -> Left e
332+-- instance HasClient Raw where
484− Right jx -> Right $ jx { _xhrRequest_url = path <> _xhrRequest_url jx }
333+-- type Client Raw = String -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
485− ) xhrs (showBaseUrl <$> baseurl)
486− xhrs'' = attachPromptlyDynWith (flip (,)) xhrs' triggers :: Event t (tag, Either Text (XhrRequest ()))
487− badReq = fmapMaybe (\(t,x) -> either (Just . (t,)) (const Nothing) x) xhrs'' :: Event t (tag, Text)
488− okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
489−
490− resps <- performRequestsAsync okReq
491− wrap $ leftmost [ uncurry RequestFailure <$> badReq
492− , evalResponse (const $ Right ()) <$> resps
493− ]
494
334
335+-- clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw
336+-- clientWithRoute Proxy req baseurl httpMethod = do
337+-- performRequest httpMethod req baseurl
495
338
496-- | If you use a 'ReqBody' in one of your endpoints in your API,
339-- | If you use a 'ReqBody' in one of your endpoints in your API,
497-- the corresponding querying function will automatically take
340-- the corresponding querying function will automatically take
@@ -509,76 +352,58 @@ instance SupportsServantReflex t m => HasClient t m Raw tag where
509-- > myApi = Proxy
352-- > myApi = Proxy
510-- >
353-- >
511-- > addBook :: Book -> ExceptT String IO Book
354-- > addBook :: Book -> ExceptT String IO Book
512−-- > addBook = client myApi host
355+-- > addBook = client myApi host
513-- > where host = BaseUrl Http "localhost" 8080
356-- > where host = BaseUrl Http "localhost" 8080
514-- > -- then you can just use "addBook" to query that endpoint
357-- > -- then you can just use "addBook" to query that endpoint
358+instance (MimeRender ct a, HasClient t m sublayout)
359+ => HasClient t m (ReqBody (ct ': cts) a :> sublayout) where
515
360
516−instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
517− => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where
518−
519− type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
361+ type Client t m (ReqBody (ct ': cts) a :> sublayout) =
520− Dynamic t (Either Text a) -> Client t m sublayout tag
362+ a -> Client sublayout
521−
522− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =
523− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap
524− where req' = req { reqBody = bodyBytesCT }
525− ctProxy = Proxy :: Proxy ct
526− ctString = T.pack $ show $ contentType ctProxy
527− bodyBytesCT = Just $ (fmap . fmap)
528− (\b -> (mimeRender ctProxy b, ctString))
529− body
530−
531
363
364+ clientWithRoute Proxy req baseurl body =
365+ clientWithRoute (Proxy :: Proxy sublayout)
366+ (let ctProxy = Proxy :: Proxy ct
367+ in setRQBody (mimeRender ctProxy body)
368+ (contentType ctProxy)
369+ req
370+ )
371+ baseurl
532
372
533-- | Make the querying function append @path@ to the request path.
373-- | Make the querying function append @path@ to the request path.
534−instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
374+instance (KnownSymbol path, HasClient t m sublayout) => HasClient t m (path :> sublayout) where
535− type Client t m (path :> sublayout) tag = Client t m sublayout tag
375+ type Client t m (path :> sublayout) = Client t m sublayout
536
376
537− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =
377+ clientWithRoute Proxy req baseurl =
538− clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t
378+ clientWithRoute (Proxy :: Proxy sublayout)
539− (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap
379+ (prependToPath (constant p) req)
380+ baseurl
540
381
541 where p = symbolVal (Proxy :: Proxy path)
382 where p = symbolVal (Proxy :: Proxy path)
542
383
384+instance HasClient t m api => HasClient t m (Vault :> api) where
385+ type Client t m (Vault :> api) = Client api
543
386
544−instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
387+ clientWithRoute Proxy req baseurl =
545− type Client t m (Vault :> api) tag = Client t m api tag
388+ clientWithRoute (Proxy :: Proxy api) req baseurl
546−
547− clientWithRouteAndResultHandler Proxy =
548− clientWithRouteAndResultHandler (Proxy :: Proxy api)
549−
550−
551−instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
552− type Client t m (RemoteHost :> api) tag = Client t m api tag
553−
554− clientWithRouteAndResultHandler Proxy =
555− clientWithRouteAndResultHandler (Proxy :: Proxy api)
556−
557
389
390+instance HasClient t m api => HasClient t m (RemoteHost :> api) where
391+ type Client t m (RemoteHost :> api) = Client t m api
558
392
559−instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
393+ clientWithRoute Proxy req baseurl =
560− type Client t m (IsSecure :> api) tag = Client t m api tag
394+ clientWithRoute (Proxy :: Proxy api) req baseurl
561
395
562− clientWithRouteAndResultHandler Proxy =
396+instance HasClient t m api => HasClient t m (IsSecure :> api) where
563− clientWithRouteAndResultHandler (Proxy :: Proxy api)
397+ type Client t m (IsSecure :> api) = Client t m api
564
398
399+ clientWithRoute Proxy req baseurl =
400+ clientWithRoute (Proxy :: Proxy api) req baseurl
565
401
566−instance (HasClient t m api tag, Reflex t)
402+instance HasClient t m subapi =>
567− => HasClient t m (BasicAuth realm usr :> api) tag where
403+ HasClient t m (WithNamedConfig name config subapi) where
568
404
569− type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
570− -> Client t m api tag
571−
572− clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =
573− clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap
574− where
575− req' = req { authData = Just authdata }
576−
577−-- instance HasClient t m subapi =>
578−-- HasClient t m (WithNamedConfig name config subapi) where
579−
580−-- type Client t m (WithNamedConfig name config subapi) = Client t m subapi
405+ type Client t m (WithNamedConfig name config subapi) = Client t m subapi
581−-- clientWithRoute Proxy q = clientWithRoute (Proxy :: Proxy subapi) q
406+ clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)
582
407
583
408
584{- Note [Non-Empty Content Types]
409{- Note [Non-Empty Content Types]
@@ -596,30 +421,3 @@ non-empty lists, but is otherwise more specific, no instance will be overall
596more specific. This in turn generally means adding yet another instance (one
421more specific. This in turn generally means adding yet another instance (one
597for empty and one for non-empty lists).
422for empty and one for non-empty lists).
598-}
423-}
599−
600−
601−-- SUPPORT FOR servant-auth --
602−
603−-- For JavaScript clients we should be sending/storing JSON web tokens in a
604−-- way that is inaccessible to JavaScript.
605−--
606−-- For @servant-auth@ this is done with HTTP-only cookies. In a Reflex-DOM
607−-- app this means the @servant-auth@ client should only verify that the API
608−-- supports Cookie-based authentication but do nothing with the token
609−-- directly.
610−
611−-- @HasCookieAuth auths@ is nominally a redundant constraint, but ensures
612−-- we're not trying to rely on cookies when the API does not use them.
613−instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where
614−
615− type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag
616− clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)
617−
618−
619−type family HasCookieAuth xs :: Constraint where
620− HasCookieAuth (Auth.Cookie ': xs) = ()
621− HasCookieAuth (x ': xs) = HasCookieAuth xs
622− HasCookieAuth '[] = CookieAuthNotEnabled
623−
624−class CookieAuthNotEnabled
625−
src/Servant/Reflex/Multi.hsdeleted−401
@@ -1,401 +0,0 @@
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.yamldeleted−56
@@ -1,56 +0,0 @@
1−flags: {}
2−extra-package-dbs: []
3−packages:
4−- '.'
5−
6−- location:
7− git: https://github.com/reflex-frp/reflex
8− commit: d78ba4318c425ca9b942dc387d7c5c7ab2d2e095
9− extra-dep: true
10−
11−- location:
12− git: https://github.com/mokus0/dependent-sum.git
13− commit: bbc8ad3a81ea7f2b07ce7d036efd56f2e0f7c6ff
14− extra-dep: true
15−
16−- location:
17− git: https://github.com/gtk2hs/gtk2hs.git
18− commit: 21d3a12a82756d04066e5e4198b35097012ee65b
19− subdirs:
20− - cairo
21− - gio
22− - glib
23− - gtk
24− - pango
25− - tools
26− extra-dep: true
27−
28−- location:
29− git: https://github.com/byorgey/hashtables.git
30− commit: 47d9ed261a5aba66a13d3c4da0e391d338b57fc5
31− extra-dep: true
32−
33−- location:
34− git: https://github.com/afcady/reflex-dom.git
35− commit: 39b5ff23f3ae95d77c909ab3ed4bc4bd9e61f600
36− extra-dep: true
37−
38−- location:
39− git: https://github.com/afcady/dependent-sum-template.git
40− commit: 68fc1a90580ea8f20775491cf651eefea422212a
41− extra-dep: true
42−
43−extra-deps:
44−- cpphs-1.20.4
45−- directory-1.2.7.1
46−- ghcjs-dom-0.2.4.0
47−- haskell-src-exts-1.17.1
48−- haskell-src-meta-0.6.0.14
49−- hlint-1.9.35
50−- prim-uniq-0.1.0.1
51−- primitive-0.6.2.0
52−- ref-tf-0.4.0.1
53−- vector-0.12.0.0
54−- webkitgtk3-javascriptcore-0.13.2.0
55−- zenc-0.1.1
56−resolver: lts-8.3
testdriver/LICENSE.mddeleted−30
@@ -1,30 +0,0 @@
1−Copyright Greg Hale (c) 2016
2−
3−All rights reserved.
4−
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
7−
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
10−
11− * Redistributions in binary form must reproduce the above
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of Greg Hale nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
testdriver/deploy-code-coverage.shdeleted−65
@@ -1,65 +0,0 @@
1−#!/usr/bin/env bash
2−
3−set -e # Exit with nonzero exit code if anything fails
4−
5−SOURCE_BRANCH="dynamic"
6−TARGET_BRANCH="gh-pages"
7−OUT=out
8−
9−function doCompile {
10− ./runTestsAndCoverage.sh
11−}
12−
13−# Pull requests and commits to other branches shouldn't try to deploy, just build to verify
14−if [ "$TRAVIS_PULL_REQUEST" != "false" -o "$TRAVIS_BRANCH" != "$SOURCE_BRANCH" ]; then
15− echo "Skipping deploy; just doing a build."
16− doCompile
17− exit 0
18−fi
19−
20−# Save some useful information
21−REPO=`git config remote.origin.url`
22−SSH_REPO=${REPO/https:\/\/github.com\//git@github.com:}
23−SHA=`git rev-parse --verify HEAD`
24−
25−# Clone the existing gh-pages for this repo into $OUTt/
26−# Create a new empty branch if gh-pages doesn't exist yet (should only happen on first deply)
27−git clone $REPO $OUT
28−cd $OUT
29−git checkout $TARGET_BRANCH || git checkout --orphan $TARGET_BRANCH
30−cd ..
31−
32−# Clean out existing contents
33−# rm -rf $OUT/* || exit 0
34−
35−# Run our compile script
36−doCompile
37−
38−# Now let's go have some fun with the cloned repo
39−cd $OUT
40−git config user.name "Travis CI"
41−git config user.email "$COMMIT_AUTHOR_EMAIL"
42−
43−# If there are no changes to the compiled out (e.g. this is a README update) then just bail.
44−if [ -z `git diff --exit-code` ]; then
45− echo "No changes to the output on this push; exiting."
46− exit 0
47−fi
48−
49−# Commit the "changes", i.e. the new version.
50−# The delta will show diffs between new and old versions.
51−git add -A
52−git commit -m "Deploy to GitHub Pages: ${SHA}"
53−
54−# Get the deploy key by using Travis's stored variables to decrypt deploy_key.enc
55−ENCRYPTED_KEY_VAR="encrypted_${ENCRYPTION_LABEL}_key"
56−ENCRYPTED_IV_VAR="encrypted_${ENCRYPTION_LABEL}_iv"
57−ENCRYPTED_KEY=${!ENCRYPTED_KEY_VAR}
58−ENCRYPTED_IV=${!ENCRYPTED_IV_VAR}
59−openssl aes-256-cbc -K $ENCRYPTED_KEY -iv $ENCRYPTED_IV -in ../deploy_key.enc -out ../deploy_key -d
60−chmod 600 ../deploy_key
61−eval `ssh-agent -s`
62−ssh-add ../deploy_key
63−
64−# Now that we're all set up, we can push.
65−git push $SSH_REPO $TARGET_BRANCH
testdriver/runTestsAndCoverage.shdeleted−59
@@ -1,59 +0,0 @@
1−#!/bin/sh
2−
3−set -e
4−
5−# All directory variables relative to project root
6−# DIR=dist-newstyle/hpc
7−DIR=./dist/hpc
8−
9−#SUITE=./dist-newstyle/build/servant-reflex-0.2/build/testsuite/testsuite
10−SUITE=./dist/build/testsuite/testsuite
11−
12−if [ -z "$DEBUG" ]; then
13− export DEBUG=snap-testsuite
14−fi
15−
16−rm -f testsuite.tix
17−rm -rf "$DIR"
18−mkdir -p "$DIR"
19−
20−if [ ! -f $SUITE ]; then
21− cat <<EOF
22−Testsuite executable not found, please run:
23− cabal install --enable-tests --only-dependencies
24− cabal configure --enable-tests
25− cabal build
26−EOF
27− exit;
28−fi
29−
30−$SUITE $*
31−
32−EXCLUDES='Main
33−Paths_servant-reflex
34−'
35−
36−EXCL=""
37−
38−for m in $EXCLUDES; do
39− EXCL="$EXCL --exclude=$m"
40−done
41−
42−# TODO - actually send results to /dev/null when hpc kinks are fully removed
43−echo "Call hpc:"
44−echo hpc markup $EXCL --destdir=$DIR testsuite # >/dev/null 2>&1
45−hpc markup $EXCL --destdir=$DIR testsuite # >/dev/null 2>&1
46−
47−echo "ls $DIR:"
48−ls $DIR
49−
50−echo "ls:"
51−ls
52−
53−cp -r $DIR out/
54−
55−cat <<EOF
56−
57−
58−Test coverage report written to $HTMLDIR.
59−EOF
testdriver/test/Servant/ReflexSpec.hsdeleted−94
@@ -1,94 +0,0 @@
1−{-# language OverloadedStrings #-}
2−
3−module Servant.ReflexSpec where
4−
5−import Control.Concurrent (threadDelay)
6−import Control.Monad.IO.Class (liftIO)
7−import Data.Monoid ((<>))
8−import qualified Data.Text as T
9−import Data.Foldable
10−import Test.WebDriver.Commands.Wait
11−import Test.Hspec.WebDriver
12−import Test.Hspec.WebDriver (chromeCaps)
13−
14−
15−clickingShouldCause :: Selector -> Selector -> Double -> (Element -> Element -> WD Bool) -> WD ()
16−clickingShouldCause inp outp timeLimit s = do
17− inputEl <- findElem inp
18− outputEl <- findElem outp
19− click inputEl
20− _ <- waitUntil timeLimit $ do
21− r <- s inputEl outputEl
22− return r
23− return ()
24−
25−hasInfixText :: Element -> T.Text -> WD Bool
26−hasInfixText el t = getText el >>= \txt -> return $ t `T.isInfixOf` txt
27−
28−spec :: Spec
29−spec = do
30− describe "servant-reflex tests" $ do
31−
32− session "test page" $ using [chromeCaps] $ do
33−
34− it "opens the page" $ runWD $
35− openPage "http://localhost:8000"
36−
37− it "has a div" $ runWD $ do
38− e <- waitUntil 5 $ findElem $ ByCSS "div"
39− e `shouldBeTag` "div"
40−
41− it "has demo-group div" $ runWD $ do
42− e <- findElem $ ByCSS "div.demo-group"
43− e `shouldBeTag` "div"
44−
45− it "doesn't have demo-group-nonexistent div" $ runWD $ do
46− e <- findElems $ ByCSS "div.demo-group.nonexistent"
47− e `shouldBe` []
48−
49− it "can get an int or unit from the API" $ runWD $ do
50− let outEl = ByCSS "div.unit-int-response p"
51− clickingShouldCause (ByCSS "div.int-button > button") outEl 0.1
52− (\i o -> o `hasInfixText` "Just \"100\"")
53− clickingShouldCause (ByCSS "div.unit-button > button") outEl 0.1
54− (\i o -> o `hasInfixText` "Just \"[[]]\"")
55−
56− let setupGreeting = do
57− iName <- findElem $ ByCSS ".name-input input"
58− iGreetings <- findElem $ ByCSS ".greetings-input input"
59− bGusto <- findElem $ ByCSS ".gusto-input input"
60− goBtn <- findElem $ ByCSS ".hi-button button"
61− greetingRes <- findElem $ ByCSS ".greeting-response"
62− return (iName, iGreetings, bGusto, goBtn, greetingRes)
63−
64− it "handle query params" $ runWD $ do
65− (iName, iGreetings, bGusto, goBtn, greetingRes) <- setupGreeting
66− sendKeys "Haskell" iName
67− sendKeys "Hello Hi" iGreetings
68− click goBtn
69− greetingRes `shouldHaveText` "Hello, and Hi, Haskell"
70−
71− it "handles queryflag" $ runWD $ do
72− (iName, iGreetings, bGusto, goBtn, greetingRes) <- setupGreeting
73− click bGusto
74− click goBtn
75− greetingRes `shouldHaveText` "HELLO, AND HI, HASKELL"
76−
77− it "tags dyn promptly" $ runWD $ do
78− (iName, iGreetings, bGusto, goBtn, greetingRes) <- setupGreeting
79− sendKeys "!" iName
80− greetingRes `shouldHaveText` "HELLO, AND HI, HASKELL!"
81−
82−{- Broken. Why?
83− it "handles request bodies" $ runWD $ do
84− dText <- findElem $ ByCSS ".double-input input"
85− dSend <- findElem $ ByCSS ".double-button button"
86− dRes <- findElem $ ByCSS ".double-result p"
87− dErr <- findElem $ ByCSS ".double-errors"
88− sendKeys "200" dText
89− click dSend
90− saveScreenshot "/home/ubuntu/screen.png"
91− liftIO (threadDelay 1000000)
92− dErr `shouldHaveText` "(no errors)"
93− dRes `shouldHaveText` "400.0"
94−-}
testdriver/test/Spec.hsdeleted−1
@@ -1 +0,0 @@
1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
testdriver/testdriver.cabaldeleted−26
@@ -1,26 +0,0 @@
1−Name: testdriver
2−Version: 0.2
3−Synopsis: Selenium test driver for Servant reflex
4−Description: Servant reflex API generator
5−License: AllRightsReserved
6−License-file: LICENSE.md
7−Author: Greg Hale, Doug Beardsley
8−Maintainer: imalsogreg@gmail.com
9−Stability: Experimental
10−Category: Web
11−Build-type: Simple
12−Cabal-version: >=1.10
13−
14−executable spec
15− type: exitcode-stdio-1.0
16− main-is: Spec.hs
17− hs-source-dirs: test
18− ghc-prof-options: -auto
19− ghc-options: -Wall -fwarn-tabs -O2 -threaded
20− other-modules:
21− default-language: Haskell2010
22− build-depends: base,
23− hspec,
24− hspec-webdriver,
25− text,
26− webdriver
testserver/API.hsmode 100644 → 120000+1−69
@@ -1,69 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TypeOperators #-}
4−
5−module API where
6−
7−import Data.Aeson
8−import Data.Aeson.Types (typeMismatch)
9−import Data.Text (Text)
10−import Servant.API
11−
12−newtype Question = Question { unQuestion :: Text } deriving (Show)
13−
14−instance ToJSON Question where
15− toJSON (Question txt) = object ["question" .= txt]
16−
17−instance FromJSON Question where
18− parseJSON (Object v) = Question <$> v .: "question"
19− parseJSON x = typeMismatch "Couldn't find key 'question'" x
20−
21−newtype Answer = Answer { unAnswer :: Text } deriving (Show)
22−
23−instance ToJSON Answer where
24− toJSON (Answer txt) = object ["answer" .= txt]
25−
26−instance FromJSON Answer where
27− parseJSON (Object v) = Answer <$> v .: "answer"
28− parseJSON x = typeMismatch "Couldn't find key 'answer'" x
29−
30−
31−-- | API spec for server, client, and docs
32−type API = "getunit" :> Get '[JSON] ()
33− :<|> "getint" :> Get '[JSON] Int
34− :<|> "sayhi" :> QueryParam "username" Text
35− :> QueryParams "greetings" Text
36− :> QueryFlag "gusto"
37− :> Get '[JSON] Text
38− :<|> "double" :> ReqBody '[JSON] Double
39− :> Post '[JSON] Double
40− :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
41− :<|> "qna" :> ReqBody '[JSON] Question
42− :> Post '[JSON] Answer
43− :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
44− :<|> Raw
45−
46−type GET = Get '[JSON] ()
47−
48−-- Imported the comprehensive API example for testing.
49−-- https://github.com/haskell-servant/servant/blob/master/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs
50−type ComprehensiveAPI =
51− GET :<|>
52− Get '[JSON] Int :<|>
53− Capture "foo" Int :> GET :<|>
54− Header "foo" Int :> GET :<|>
55− HttpVersion :> GET :<|>
56− IsSecure :> GET :<|>
57− QueryParam "foo" Int :> GET :<|>
58− QueryParams "foo" Int :> GET :<|>
59− QueryFlag "foo" :> GET :<|>
60−-- Raw :<|>
61− RemoteHost :> GET :<|>
62− ReqBody '[JSON] Int :> GET :<|>
63− Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>
64− "foo" :> GET :<|>
65− Vault :> GET :<|>
66− Verb 'POST 204 '[JSON] () :<|>
67− Verb 'POST 204 '[JSON] Int
68−-- This one isn't in scope
69−-- :<|> WithNamedContext "foo" '[] GET
@@ -0,0 +1 @@
1+../exec/API.hs
testserver/Main.hs+16−61
@@ -2,34 +2,21 @@
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE PolyKinds #-}
4{-# LANGUAGE PolyKinds #-}
5−{-# LANGUAGE TypeApplications #-}
6{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
8
7
9−import Control.Monad.IO.Class (liftIO)
10−import Control.Monad.Reader (reader)
11import Data.Aeson
8import Data.Aeson
12−import Data.Bool
13−import Data.Char (toUpper)
14−import qualified Data.List as L
15−import Data.Maybe (fromMaybe)
16import Data.Monoid
9import Data.Monoid
17import Data.Proxy
10import Data.Proxy
18−import Data.Text hiding (head, length, map,
11+import Data.Text
19− null, toUpper)
20−import qualified Data.Text as T
21−import qualified Data.Text.IO as T
22import GHC.Generics
12import GHC.Generics
23−import Servant.Server.Internal.SnapShims
24−import Snap.Core
25import Snap.Http.Server
13import Snap.Http.Server
14+import Snap.Core
15+import Servant.Server.Internal.SnapShims
26
16
27import Servant
17import Servant
28import Servant.Server
18import Servant.Server
29−-- import Snap.Util.FileServe
30−import System.Environment (lookupEnv)
31import API
19import API
32−import Snap
33
20
34-- * Example
21-- * Example
35
22
@@ -43,60 +30,28 @@ instance ToJSON Greet
43testApi :: Proxy API
30testApi :: Proxy API
44testApi = Proxy
31testApi = Proxy
45
32
46−data App = App { appStaticDir :: String }
47−
48-- Server-side handlers.
33-- Server-side handlers.
49--
34--
50-- There's one handler per endpoint, which, just like in the type
35-- There's one handler per endpoint, which, just like in the type
51-- that represents the API, are glued together using :<|>.
36-- that represents the API, are glued together using :<|>.
52--
37--
53-- Each handler runs in the 'ExceptT ServantErr IO' monad.
38-- Each handler runs in the 'ExceptT ServantErr IO' monad.
54−server :: Server API '[BasicAuthCheck (Handler App App) ()] (Handler App App)
39+server :: Server API Snap
55−server = return () :<|> return 100 :<|> sayhi :<|> dbl
40+server = return () :<|> return 100
56− :<|> multi :<|> qna :<|> serveSecret
41+
57− :<|> statics
42+ where helloH name Nothing = helloH name (Just False)
58− where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
43+ helloH name (Just False) = return . Greet $ "Hello, " <> name
59− sayhi nm greetings withGusto = case nm of
44+ helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
60− Nothing -> return ("Sorry, who are you?" :: Text)
45+
61− Just n -> do
46+ postGreetH greet = return greet
62− let modifier = bool id T.toUpper withGusto
47+
63− greetPart
48+ deleteGreetH _ = return ()
64− | null greetings = "Hi, "
65− | length greetings == 1 = L.head greetings <> ", "
66− | otherwise = T.intercalate ", " (L.init greetings)
67− <> ", and " <> L.last greetings <> ", "
68− return . modifier $ greetPart <> n
69− dbl x = if x `elem` [4,13]
70− then throwError $ err500 { errBody = "No unlucky numbers please" }
71− else return $ x * 2
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
85
49
86-- Turn the server into a WAI app. 'serve' is provided by servant,
50-- Turn the server into a WAI app. 'serve' is provided by servant,
87-- more precisely by the Servant.Server module.
51-- more precisely by the Servant.Server module.
88−test :: Handler App App ()
52+test :: Application Snap
89−test = serveSnapWithContext testApi
53+test = serve testApi server
90− (BasicAuthCheck (\_ -> return @(Handler App App) (Authorized ())) :. EmptyContext) server
91−
92−initApp :: SnapletInit App App
93−initApp = makeSnaplet "myapp" "example" Nothing $ do
94− staticDir <- fromMaybe "static" <$> liftIO (lookupEnv "STATIC_DIR")
95− addRoutes [("", test)
96− ,("", serveDirectory "static")
97− ]
98− return (App staticDir)
99
54
100-- Put this all to work!
55-- Put this all to work!
101main :: IO ()
56main :: IO ()
102−main = serveSnaplet mempty initApp
57+main = quickHttpServe $ applicationToSnap (serve testApi server)
testserver/static/index.htmldeleted−11
@@ -1,11 +0,0 @@
1−<!DOCTYPE html>
2−<html>
3− <head>
4− <script language="javascript" src="rts.js"></script>
5− <script language="javascript" src="lib.js"></script>
6− <script language="javascript" src="out.js"></script>
7− </head>
8− <body>
9− </body>
10− <script language="javascript" src="runmain.js" defer></script>
11−</html>
testserver/testserver.cabal+10−18
@@ -1,32 +1,24 @@
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/
2-- see http://haskell.org/cabal/users-guide/
3
3
4name: testserver
4name: testserver
5version: 0.1.0.0
5version: 0.1.0.0
6−-- synopsis:
6+-- synopsis:
7−-- description:
7+-- description:
8license: BSD3
8license: BSD3
9license-file: LICENSE
9license-file: LICENSE
10author: Greg Hale
10author: Greg Hale
11maintainer: imalsogreg@gmail.com
11maintainer: imalsogreg@gmail.com
12−-- copyright:
12+-- copyright:
13−-- category:
13+-- category:
14build-type: Simple
14build-type: Simple
15−-- extra-source-files:
15+-- extra-source-files:
16cabal-version: >=1.10
16cabal-version: >=1.10
17
17
18executable back
18executable back
19 main-is: Main.hs
19 main-is: Main.hs
20− -- other-modules:
20+ -- other-modules:
21− -- other-extensions:
21+ -- other-extensions:
22− build-depends: aeson >= 0.9 && < 1.5
22+ build-depends: aeson, base >=4.8 && <4.9, snap, snap-server, snap-core, servant, servant-snap, text
23− , base >=4.8 && < 5
24− , mtl
25− , snap >= 1.0 && < 1.2
26− , snap-server >= 1.0 && < 1.2
27− , snap-core >= 1.0 && < 1.1
28− , servant >= 0.16 && < 0.18
29− , servant-snap >= 0.8 && < 0.9
30− , text >= 1.0 && < 1.3
31− -- hs-source-dirs:
23+ -- hs-source-dirs:
32 default-language: Haskell2010
24 default-language: Haskell2010
travis.nixdeleted−70
@@ -1,70 +0,0 @@
1−{
2− nativeCompiler ? "ghc",
3− # ^ Choose a GHC for compiling backend components (web server, selenium)
4− # (ghc, ghc8_0, ghc8_2, ghc8_4 or ghcHEAD)
5−
6− jsCompiler ? "ghcjs"
7− # ^ Choose a GHCJS for compiling the frontend
8− # (ghcjs, ghcjs8_0, ghcjs8_2 or ghcjs8_4)
9−
10−}:
11−
12−let
13−
14− reflexPlatform = import ./nix/reflex-platform.nix;
15−
16− lib = reflexPlatform.nixpkgs.haskell.lib;
17− do = funs: pkg: builtins.foldl' (a: b: b a) pkg funs;
18−
19− ghcjsPkgs = with lib; reflexPlatform.${jsCompiler}.override {
20− overrides = self: super: {
21− http-media = dontCheck super.http-media;
22− servant = dontCheck super.servant;
23− lens-aeson = dontCheck super.lens-aeson;
24− servant-reflex = lib.appendConfigureFlag
25− (self.callPackage ./default.nix {}) "-fExample";
26− };
27− };
28−
29− ghcPkgs = with lib; reflexPlatform.${nativeCompiler}.override {
30− overrides = self: super: {
31− servant-snap = dontCheck ((import ./nix/servant-snap.nix {}) self super);
32− testdriver = self.callCabal2nix "testdriver" ./testdriver {};
33− testserver = import nix/testserver.nix ghcjsPkgs.servant-reflex self super;
34− servant-reflex = self.callPackage ./default.nix {};
35− };
36− };
37−
38− testresults = import ./nix/testresults.nix
39− { inherit reflexPlatform;
40− inherit (ghcPkgs) testserver testdriver;
41− inherit (reflexPlatform.nixpkgs) curl;
42− phantomjs = reflexPlatform.nixpkgs.phantomjs2;
43− };
44−
45−in
46− rec {
47−
48− inherit reflexPlatform ghcPkgs ghcjsPkgs;
49−
50− build = ghcjsPkgs.servant-reflex;
51− buildGhc = ghcPkgs.servant-reflex;
52− testserver = ghcPkgs.testserver;
53− testdriver = ghcPkgs.testdriver;
54− inherit testresults;
55−
56− cabalBuild = reflexPlatform.${jsCompiler}.shellFor {
57− name = "servant-reflex-cabal-builder";
58−
59− packages = p: [
60− build
61− ];
62−
63− shellHook = ''
64− cabal configure --ghcjs -f Example
65− cabal build
66− exec/toSite.sh
67− exit $?
68− '';
69− };
70− }