git.iko.soy/typeable/servant-reflex
on master help sign in
merge master
a0af3a9Greg Hale
.gitignore+2
compare with master
unifiedsplit
@@ -6,3 +6,5 @@ log
6*.webapp
6*.webapp
7*.stats
7*.stats
8out
8out
9+reflex-platform
10+/.stack-work/
.travis.yml+1−2
@@ -20,7 +20,6 @@ matrix:
20
20
21
21
22before_install:
22before_install:
23− - openssl aes-256-cbc -K $encrypted_3c89d919c82e_key -iv $encrypted_3c89d919c82e_iv -in deploy_key.enc -out deploy_key -d
24 - unset CC
23 - unset CC
25 - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
24 - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
26 - git submodule update --init --recursive
25 - git submodule update --init --recursive
@@ -49,7 +48,7 @@ script:
49 - git config --global user.email "travis-ci@example.com"
48 - git config --global user.email "travis-ci@example.com"
50 - git config --global user.name "Travis-CI"
49 - git config --global user.name "Travis-CI"
51 - ./build.sh
50 - ./build.sh
52− - testdriver/dist/build/spec/spec
51+ # - testdriver/dist/build/spec/spec
53
52
54cache:
53cache:
55 directories:
54 directories:
changelog.mdnew file+32
@@ -0,0 +1,32 @@
1+0.3
2+---
3+
4+- **Addition of the 'Servant.Reflex.Multi' module** which allows the user
5+to choose some '(Applicative f, Traversable f) => f' for collecting
6+endpoint parameters. The traversable instance is used for passing
7+multiple 'XhrRequest's in response to a single event trigger. The
8+Applicative instance is used to combine parameters. For example,
9+'Capture "id" Name :> QueryParam "greeting" Text :> Get '[JSON] Text'
10+will generate a client function:
11+`Dynamic t (f Name) -> Dynamic t (f greeting) -> Event t tag ->
12+ m (Event t (f (ReqResult tag Text)))`
13+Calling that function with 'f' chosen to be list ('[]'), this call
14+`clientFun
15+(constDyn ["Greg", "Bernie"])
16+(constDyn ["Greetings", "Hey"])
17+trigger`
18+would produce four XhrRequests per 'trigger' event, one for each
19+combination of possible parameters, and one response event
20+would carry a list of the four responses.
21+A 'zip-wise' combination of the parameters can be chosen with
22+a different applicative wrapper: 'ZipList'
23+
24+- **Event tags**. A new type parameter lets users choose a payload
25+value to attach to outgoing requests at the point of triggering,
26+and which is embedded in the response, allowing individual
27+request-response pairs to be followed. The response's tag has been
28+added to each constructor `ReqResult tag a` type.
29+
30+- **Improved Unicode support** Thanks to Schell Scivally
31+(https://github.com/schell) for identifying and fixing a UTF-8
32+encoding bug!
deps/servant+1−1

Submodule changed.

deps/servant-snap+1−1

Submodule changed.

exec/API.hs+28−4
@@ -1,10 +1,32 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE TypeOperators #-}
3+{-# LANGUAGE TypeOperators #-}
3
4
4module API where
5module API where
5
6
7+import Data.Aeson
8+import Data.Aeson.Types (typeMismatch)
6−import Data.Text (Text)
9+import Data.Text (Text)
7−import Servant.API
10+import Servant.API
11+
12+newtype Question = Question { unQuestion :: Text } deriving (Show)
13+
14+instance ToJSON Question where
15+ toJSON (Question txt) = object ["question" .= txt]
16+
17+instance FromJSON Question where
18+ parseJSON (Object v) = Question <$> v .: "question"
19+ parseJSON x = typeMismatch "Couldn't find key 'question'" x
20+
21+newtype Answer = Answer { unAnswer :: Text } deriving (Show)
22+
23+instance ToJSON Answer where
24+ toJSON (Answer txt) = object ["answer" .= txt]
25+
26+instance FromJSON Answer where
27+ parseJSON (Object v) = Answer <$> v .: "answer"
28+ parseJSON x = typeMismatch "Couldn't find key 'answer'" x
29+
8
30
9-- | API spec for server, client, and docs
31-- | API spec for server, client, and docs
10type API = "getunit" :> Get '[JSON] ()
32type API = "getunit" :> Get '[JSON] ()
@@ -16,6 +38,8 @@ type API = "getunit" :> Get '[JSON] ()
16 :<|> "double" :> ReqBody '[JSON] Double
38 :<|> "double" :> ReqBody '[JSON] Double
17 :> Post '[JSON] Double
39 :> Post '[JSON] Double
18 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
40 :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
41+ :<|> "qna" :> ReqBody '[JSON] Question
42+ :> Post '[JSON] Answer
19 :<|> Raw
43 :<|> Raw
20
44
21type GET = Get '[JSON] ()
45type GET = Get '[JSON] ()
exec/Example.hs+96−28
@@ -2,29 +2,75 @@
2{-# LANGUAGE GADTs #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE RecursiveDo #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
6
7
7module Main where
8module Main where
8
9
10+------------------------------------------------------------------------------
9import Data.Bool
11import Data.Bool
10import Data.Maybe
12import Data.Maybe
11import Control.Monad.Fix (MonadFix)
13import Control.Monad.Fix (MonadFix)
12−import Data.Monoid ((<>))
14+import Data.Monoid (First(..), (<>))
13import Data.Text (Text)
15import Data.Text (Text)
14import qualified Data.Text as T
16import qualified Data.Text as T
17+import GHC.TypeLits
15import Servant.API
18import Servant.API
16−import Servant.Reflex
17import API
19import API
18import Data.Proxy
20import Data.Proxy
19import Text.Read (readMaybe)
21import Text.Read (readMaybe)
20import Reflex.Dom
22import Reflex.Dom
23+------------------------------------------------------------------------------
24+import Servant.Reflex
25+import Servant.Reflex.Multi
26+
21
27
22api :: Proxy API
28api :: Proxy API
23api = Proxy
29api = Proxy
24
30
25main :: IO ()
31main :: IO ()
26−main = mainWidget run
32+main = mainWidget $ do
27−
33+ divClass "example-base" run
34+ divClass "example-multi" runMulti
35+
36+
37+runMulti :: forall t m. (SupportsServantReflex t m,
38+ DomBuilder t m,
39+ DomBuilderSpace m ~ GhcjsDomSpace,
40+ MonadFix m,
41+ PostBuild t m,
42+ MonadHold t m) => m ()
43+runMulti = do
44+ url <- baseUrlWidget
45+ el "br" blank
46+ let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ ) =
47+ clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url
48+
49+ num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
50+ num2 :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def
51+
52+ b <- button "Run dbl multi"
53+ reqCount :: Dynamic t Int <- count b
54+ r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)
55+ dynText =<< holdDyn "Waiting" (T.pack . show . fmap reqSuccess <$> r)
56+
57+ lastInd <- holdDyn [] $ fmap reqTag <$> r
58+ display lastInd
59+
60+ divClass "demo-group" $ do
61+ nms <- fmap (fmap T.words . value) $ divClass "" $ do
62+ text "Names"
63+ textInput def
64+ grts <- fmap (fmap T.words . value) $ divClass "" $ do
65+ text "Greetings"
66+ textInput def
67+ gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def
68+ b <- button "Go"
69+ r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts) (constDyn [True, False]) (1 <$ b)
70+
71+ dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes . fmap reqSuccess <$> r')
72+
73+ return ()
28
74
29run :: forall t m. (SupportsServantReflex t m,
75run :: forall t m. (SupportsServantReflex t m,
30 DomBuilder t m,
76 DomBuilder t m,
@@ -32,35 +78,41 @@ run :: forall t m. (SupportsServantReflex t m,
32 MonadFix m,
78 MonadFix m,
33 PostBuild t m,
79 PostBuild t m,
34 MonadHold t m) => m ()
80 MonadHold t m) => m ()
35−run = do
81+run = mdo
36
82
83+ reqCount <- count $ leftmost
84+ [() <$ unitBtn, () <$ intBtn, () <$ sayHiClicks, () <$ dblBtn, () <$ mpGo]
37 -- Allow user to choose the url target for the request
85 -- Allow user to choose the url target for the request
38 -- (alternatively we could just `let url = constDyn (BasePath "/")`)
86 -- (alternatively we could just `let url = constDyn (BasePath "/")`)
39 url <- baseUrlWidget
87 url <- baseUrlWidget
40 el "br" (return ())
88 el "br" (return ())
41 dynText $ showBaseUrl <$> url
89 dynText $ showBaseUrl <$> url
90+
42 el "br" (return ())
91 el "br" (return ())
43
92
44 -- Name the computed API client functions
93 -- Name the computed API client functions
45− let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> doRaw) =
94+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> doRaw) =
46− client api (Proxy :: Proxy m) url
95+ client api (Proxy :: Proxy m) (Proxy :: Proxy Int) url
47
96
97+ c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now
98+
48− elClass "div" "demo-group" $ do
99+ (unitBtn, intBtn) <- elClass "div" "demo-group" $ do
49 unitBtn <- divClass "unit-button" $ button "Get unit"
100 unitBtn <- divClass "unit-button" $ button "Get unit"
50 intBtn <- divClass "int-button" $ button "Get int"
101 intBtn <- divClass "int-button" $ button "Get int"
51
102
52− unitResponse <- getUnit unitBtn
103+ unitResponse <- getUnit $ tag (current reqCount) unitBtn
53− intResponse :: Event t (ReqResult Int) <- getInt intBtn
104+ intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn
54
105
55− score <- foldDyn (+) 0 (fmapMaybe reqSuccess intResponse)
106+ score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))
56
107
57 r <- holdDyn "Waiting" $ fmap showXhrResponse $
108 r <- holdDyn "Waiting" $ fmap showXhrResponse $
58− leftmost [fmapMaybe response unitResponse
109+ leftmost [fmapMaybe response (unitResponse)
59− ,fmapMaybe response intResponse
110+ ,fmapMaybe response (intResponse)
60 ]
111 ]
61 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score
112 divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score
113+ return (unitBtn, intBtn)
62
114
63− elClass "div" "demo-group" $ do
115+ sayHiClicks <- elClass "div" "demo-group" $ do
64
116
65 text "Name"
117 text "Name"
66 el "br" $ return ()
118 el "br" $ return ()
@@ -78,36 +130,52 @@ run = do
78 gusto <- fmap value $ divClass "gusto-input" $ checkbox False def
130 gusto <- fmap value $ divClass "gusto-input" $ checkbox False def
79
131
80 el "br" $ return ()
132 el "br" $ return ()
81− sayhiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"
133+ sayHiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"
82− let triggers = leftmost [sayhiClicks, () <$ updated inp]
134+ let triggers = leftmost [sayHiClicks, () <$ updated inp]
83
135
84− resp <- sayhi checkedName greetings gusto triggers
136+ resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)
85 divClass "greeting-response" $ dynText =<<
137 divClass "greeting-response" $ dynText =<<
86− holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess resp
138+ holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)
87− , fmapMaybe reqFailure resp])
139+ , fmapMaybe reqFailure (resp)])
140+ return sayHiClicks
88
141
89− elClass "div" "demo-group" $ do
142+ dblBtn <- elClass "div" "demo-group" $ do
90 text "A Double to double"
143 text "A Double to double"
91 el "br" $ return ()
144 el "br" $ return ()
92 dblinp <- fmap value $ divClass "double-input" $ textInput def
145 dblinp <- fmap value $ divClass "double-input" $ textInput def
93− dblBtn <- divClass "double-button" $ button "Double it"
146+ (dblBtn) <- divClass "double-button" $ button "Double it"
94 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
147 dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
95− dblinp) dblBtn
148+ dblinp) (tag (current reqCount) dblBtn)
96− divClass "double-errors" $ dynText =<<
149+ divClass "double-errors" $ dynText =<<
97− holdDyn "(no errors)" (fmapMaybe reqFailure dblResp)
150+ holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))
98 el "br" (return ())
151 el "br" (return ())
99 divClass "double-result" $ el "p" $ dynText =<<
152 divClass "double-result" $ el "p" $ dynText =<<
100 holdDyn "No number yet" (fmap tShow $
153 holdDyn "No number yet" (fmap tShow $
101− fmapMaybe reqSuccess dblResp)
154+ fmapMaybe reqSuccess (dblResp))
155+ return dblBtn
102
156
103− elClass "div" "demo-group" $ do
157+ mpGo <- elClass "div" "demo-group" $ do
104 text "Multi-part path"
158 text "Multi-part path"
105 b <- value <$> checkbox False def
159 b <- value <$> checkbox False def
106 mpGo <- button "Test"
160 mpGo <- button "Test"
107− multiResp <- multi b mpGo
161+ multiResp <- multi b (tag (current reqCount) mpGo)
108 dynText =<< holdDyn "No res yet" (fmap tShow $
162 dynText =<< holdDyn "No res yet" (fmap tShow $
109 fmapMaybe reqSuccess $
163 fmapMaybe reqSuccess $
110− multiResp)
164+ (multiResp))
165+ return mpGo
166+
167+ return ()
168+
169+ el "br" $ return ()
170+
171+ elClass "div" "demo-group" $ do
172+ text "JSON Unicode encoding test"
173+ txt <- value <$> textInput def
174+ ev <- fmap (1 <$) $ button "Question"
175+ let dQ = Right . Question <$> traceDyn "will send: " txt
176+ rr <- qna dQ ev
177+ el "p" $
178+ dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
111
179
112showXhrResponse :: XhrResponse -> Text
180showXhrResponse :: XhrResponse -> Text
113showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
181showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
overrides-ghc.nix+2−1
@@ -1,5 +1,5 @@
1{ reflex-platform, ... }:
1{ reflex-platform, ... }:
2−let
2+let
3 pkgs = import <nixpkgs> {};
3 pkgs = import <nixpkgs> {};
4 c2n = reflex-platform.cabal2nixResult;
4 c2n = reflex-platform.cabal2nixResult;
5in reflex-platform.ghc.override {
5in reflex-platform.ghc.override {
@@ -13,6 +13,7 @@ in reflex-platform.ghc.override {
13 xmlhtml = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
13 xmlhtml = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
14 snap-core = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-core) {});
14 snap-core = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-core) {});
15 servant = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant/servant) {});
15 servant = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant/servant) {});
16+ Glob = pkgs.haskell.lib.dontCheck super.Glob;
16 http-api-data = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/http-api-data) {});
17 http-api-data = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/http-api-data) {});
17 };
18 };
18}
19}
overrides.nix+21
@@ -10,5 +10,26 @@ reflex-platform.ghcjs.override {
10 overrides = self: super: {
10 overrides = self: super: {
11 servant = dontCheck (self.callPackage (cabal2nixResult deps/servant/servant) {});
11 servant = dontCheck (self.callPackage (cabal2nixResult deps/servant/servant) {});
12 http-api-data = dontCheck (self.callPackage (cabal2nixResult deps/http-api-data) {});
12 http-api-data = dontCheck (self.callPackage (cabal2nixResult deps/http-api-data) {});
13+ natural-transformation = self.callPackage (
14+ { mkDerivation, base, containers, fetchgit, quickcheck-instances
15+ , stdenv, tasty, tasty-quickcheck
16+ }:
17+ mkDerivation {
18+ pname = "natural-transformation";
19+ version = "0.4";
20+ src = fetchgit {
21+ url = "https://github.com/ku-fpg/natural-transformation";
22+ sha256 = "0xbnnxbf5ydszbhf7h5ra3mrqy4mcyqc3zb2k8bwm1zyqrz6v0fs";
23+ rev = "b1200c09dcafd034e32846413913b74735c8ba56";
24+ };
25+ libraryHaskellDepends = [ base ];
26+ testHaskellDepends = [
27+ base containers quickcheck-instances tasty tasty-quickcheck
28+ ];
29+ homepage = "https://github.com/ku-fpg/natural-transformation";
30+ description = "A natural transformation package";
31+ license = stdenv.lib.licenses.bsd3;
32+ }
33+ ) {};
13 };
34 };
14}
35}
servant-reflex.cabal+4−3
@@ -1,5 +1,5 @@
1Name: servant-reflex
1Name: servant-reflex
2−Version: 0.2
2+Version: 0.3
3Synopsis: Servant reflex API generator
3Synopsis: Servant reflex API generator
4Description: Servant reflex API generator
4Description: Servant reflex API generator
5License: AllRightsReserved
5License: AllRightsReserved
@@ -18,6 +18,7 @@ Flag Example
18library
18library
19 exposed-modules:
19 exposed-modules:
20 Servant.Reflex
20 Servant.Reflex
21+ Servant.Reflex.Multi
21
22
22 other-modules:
23 other-modules:
23 Servant.Common.BaseUrl
24 Servant.Common.BaseUrl
@@ -39,7 +40,7 @@ library
39 reflex >= 0.5 && < 0.6,
40 reflex >= 0.5 && < 0.6,
40 reflex-dom == 0.4 && < 0.5,
41 reflex-dom == 0.4 && < 0.5,
41 safe >= 0.3.9 && < 0.4,
42 safe >= 0.3.9 && < 0.4,
42− servant >= 0.5 && < 0.9,
43+ servant >= 0.8 && < 0.11,
43 string-conversions >= 0.4 && < 0.5,
44 string-conversions >= 0.4 && < 0.5,
44 text >= 1.2 && < 1.3,
45 text >= 1.2 && < 1.3,
45 transformers >= 0.4 && < 0.6
46 transformers >= 0.4 && < 0.6
@@ -53,7 +54,7 @@ executable example
53 buildable: True
54 buildable: True
54 else
55 else
55 buildable: False
56 buildable: False
56− build-depends: reflex, servant-reflex, base, scientific, servant, reflex-dom, text
57+ build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text
57 default-language: Haskell2010
58 default-language: Haskell2010
58 main-is: Example.hs
59 main-is: Example.hs
59 other-modules: API
60 other-modules: API
src/Servant/Common/Req.hs+246−73
@@ -1,4 +1,3 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
3{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
@@ -6,49 +5,89 @@
6{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TupleSections #-}
7{-# LANGUAGE TupleSections #-}
8+
9module Servant.Common.Req where
9module Servant.Common.Req where
10
10
11-------------------------------------------------------------------------------
11-------------------------------------------------------------------------------
12+import Control.Concurrent
12import Control.Applicative (liftA2, liftA3)
13import Control.Applicative (liftA2, liftA3)
14+import Control.Monad (join)
15+import Control.Monad.IO.Class (MonadIO, liftIO)
16+import Data.Bifunctor (first)
13import qualified Data.ByteString.Lazy.Char8 as BL
17import qualified Data.ByteString.Lazy.Char8 as BL
14import qualified Data.Map as Map
18import qualified Data.Map as Map
15−import Data.Maybe (catMaybes)
19+import Data.Maybe (catMaybes, fromMaybe)
20+import Data.Functor.Compose
16import Data.Monoid ((<>))
21import Data.Monoid ((<>))
17import Data.Proxy (Proxy(..))
22import Data.Proxy (Proxy(..))
18import Data.Text (Text)
23import Data.Text (Text)
19import qualified Data.Text as T
24import qualified Data.Text as T
20import qualified Data.Text.Encoding as TE
25import qualified Data.Text.Encoding as TE
26+import Data.Traversable (forM)
21−import Reflex.Dom
27+import Reflex.Dom hiding (tag)
22−import Servant.Common.BaseUrl (BaseUrl, showBaseUrl, SupportsServantReflex)
28+import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,
29+ SupportsServantReflex)
23import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
30import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))
24import Web.HttpApiData (ToHttpApiData(..))
31import Web.HttpApiData (ToHttpApiData(..))
25-------------------------------------------------------------------------------
32-------------------------------------------------------------------------------
26import Servant.API.BasicAuth
33import Servant.API.BasicAuth
27
34
28
35
36+------------------------------------------------------------------------------
37+-- | The result of a request event
38+data ReqResult tag a
39+ = ResponseSuccess tag a XhrResponse
40+ -- ^ The succesfully decoded response from a request tagged with 'tag'
41+ | ResponseFailure tag Text XhrResponse
42+ -- ^ The failure response, which may have failed decoding or had
43+ -- a non-successful response code
44+ | RequestFailure tag Text
45+ -- ^ A failure to construct the request tagged with 'tag' at trigger time
46+
47+
48+------------------------------------------------------------------------------
49+-- | Simple filter/accessor for successful responses, when you want to
50+-- ignore the error case. For example:
51+-- >> goodResponses <- fmapMaybe reqSuccess <$> clientFun triggers
52+reqSuccess :: ReqResult tag a -> Maybe a
53+reqSuccess (ResponseSuccess _ x _) = Just x
54+reqSuccess _ = Nothing
55+
56+
57+------------------------------------------------------------------------------
58+-- | Simple filter/accessor like 'reqSuccess', but keeping the request tag
59+reqSuccess' :: ReqResult tag a -> Maybe (tag,a)
60+reqSuccess' (ResponseSuccess tag x _) = Just (tag,x)
61+reqSuccess' _ = Nothing
29
62
30−data ReqResult a = ResponseSuccess a XhrResponse
31− | ResponseFailure Text XhrResponse
32− | RequestFailure Text
33
63
34−instance Functor ReqResult where
64+------------------------------------------------------------------------------
35− fmap f (ResponseSuccess a xhr) = ResponseSuccess (f a) xhr
65+-- | Simple filter/accessor for any failure case
36− fmap _ (ResponseFailure r x) = ResponseFailure r x
66+reqFailure :: ReqResult tag a -> Maybe Text
37− fmap _ (RequestFailure r) = RequestFailure r
67+reqFailure (ResponseFailure _ s _) = Just s
68+reqFailure (RequestFailure _ s) = Just s
69+reqFailure _ = Nothing
38
70
39−reqSuccess :: ReqResult a -> Maybe a
40−reqSuccess (ResponseSuccess x _) = Just x
41−reqSuccess _ = Nothing
42
71
72+------------------------------------------------------------------------------
73+-- | Simple filter/accessor for the raw XHR response
43−reqFailure :: ReqResult a -> Maybe Text
74+response :: ReqResult tag a -> Maybe XhrResponse
75+response (ResponseSuccess _ _ x) = Just x
44−reqFailure (ResponseFailure s _) = Just s
76+response (ResponseFailure _ _ x) = Just x
45−reqFailure (RequestFailure s) = Just s
46−reqFailure _ = Nothing
77+response _ = Nothing
47
78
48−response :: ReqResult a -> Maybe XhrResponse
79+------------------------------------------------------------------------------
80+-- | Retrieve response tag
81+reqTag :: ReqResult tag a -> tag
49−response (ResponseSuccess _ x) = Just x
82+reqTag (ResponseSuccess tag _ _) = tag
50−response (ResponseFailure _ x) = Just x
83+reqTag (ResponseFailure tag _ _) = tag
51−response _ = Nothing
84+reqTag (RequestFailure tag _ ) = tag
85+
86+------------------------------------------------------------------------------
87+instance Functor (ReqResult tag) where
88+ fmap f (ResponseSuccess tag a xhr) = ResponseSuccess tag (f a) xhr
89+ fmap _ (ResponseFailure tag r x) = ResponseFailure tag r x
90+ fmap _ (RequestFailure tag r) = RequestFailure tag r
52
91
53
92
54-------------------------------------------------------------------------------
93-------------------------------------------------------------------------------
@@ -62,11 +101,13 @@ data QParam a = QParamSome a
62 | QParamInvalid Text
101 | QParamInvalid Text
63 -- ^ Indication that your validation failed (the request isn't valid)
102 -- ^ Indication that your validation failed (the request isn't valid)
64
103
104+
65qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)
105qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)
66qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)
106qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)
67qParamToQueryPart QNone = Right Nothing
107qParamToQueryPart QNone = Right Nothing
68qParamToQueryPart (QParamInvalid e) = Left e
108qParamToQueryPart (QParamInvalid e) = Left e
69
109
110+
70data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
111data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
71 | QueryPartParams (Dynamic t [Text])
112 | QueryPartParams (Dynamic t [Text])
72 | QueryPartFlag (Dynamic t Bool)
113 | QueryPartFlag (Dynamic t Bool)
@@ -96,20 +137,13 @@ addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) ->
96addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
137addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
97
138
98
139
99−-- * performing requests
140+reqToReflexRequest
100−
141+ :: forall t. Reflex t
101−displayHttpRequest :: Text -> Text
102−displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
103−
104−-- | This function actually performs the request.
105−performRequest :: forall t m.(SupportsServantReflex t m)
106− => Text
142+ => Text
107− -> Req t
108− -> Dynamic t BaseUrl
143+ -> Dynamic t BaseUrl
109− -> Event t ()
144+ -> Req t
110− -> m (Event t XhrResponse, Event t Text)
145+ -> (Dynamic t (Either Text (XhrRequest XhrPayload)))
111−performRequest reqMeth req reqHost trigger = do
146+reqToReflexRequest reqMeth reqHost req =
112−
113 let t :: Dynamic t [Either Text Text]
147 let t :: Dynamic t [Either Text Text]
114 t = sequence $ reverse $ reqPathParts req
148 t = sequence $ reverse $ reqPathParts req
115
149
@@ -142,8 +176,8 @@ performRequest reqMeth req reqHost trigger = do
142 queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Dynamic t (Either Text [Text])
176 queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Dynamic t (Either Text [Text])
143 queryString :: Dynamic t (Either Text Text) =
177 queryString :: Dynamic t (Either Text Text) =
144 ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs
178 ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs
145−-- ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") (sequence qs)
146− xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q) baseUrl urlPath queryString
179+ xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q)
180+ baseUrl urlPath queryString
147 where
181 where
148 (</>) :: Text -> Text -> Text
182 (</>) :: Text -> Text -> Text
149 x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y
183 x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y
@@ -202,47 +236,186 @@ performRequest reqMeth req reqHost trigger = do
202
236
203 xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
237 xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
204
238
205− let reqs = tagPromptlyDyn xhrReq trigger
239+ in xhrReq
206− okReqs = fmapMaybe (either (const Nothing) Just) reqs
207− badReqs = fmapMaybe (either Just (const Nothing)) reqs
208
240
209− resps <- performRequestAsync okReqs
241+-- * performing requests
242+
243+displayHttpRequest :: Text -> Text
244+displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
245+
246+-- | This function actually performs the request.
247+performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
248+ => Text
249+ -> Dynamic t (f (Req t))
250+ -> Dynamic t BaseUrl
251+ -> Event t tag
252+ -> m (Event t (tag, f (Either Text XhrResponse)))
253+performRequests reqMeth rs reqHost trigger = do
254+ -- let xhrReqs = sequence $ (\r -> reqToReflexRequest reqMeth r reqHost) <$> rs :: Dynamic t (f (Either Text (XhrRequest XhrPayload)))
255+ let xhrReqs = join $ (\(fxhr :: f (Req t)) -> sequence $ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
256+ let reqs = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
257+ resps <- performSomeRequestsAsync reqs
258+ return $ getCompose <$> resps
259+
260+-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.
261+performSomeRequestsAsync
262+ :: (MonadIO (Performable m),
263+ HasWebView (Performable m),
264+ PerformEvent t m,
265+ TriggerEvent t m,
266+ Traversable f,
267+ IsXhrPayload a)
268+ => Event t (f (Either Text (XhrRequest a)))
269+ -> m (Event t (f (Either Text XhrResponse)))
270+performSomeRequestsAsync = performSomeRequestsAsync' newXMLHttpRequest . fmap return
271+
272+
273+------------------------------------------------------------------------------
274+-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
275+-- that accepts 'f (Either e (XhrRequestb))' events
276+performSomeRequestsAsync'
277+ :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f)
278+ => (XhrRequest b -> (a -> IO ()) -> Performable m XMLHttpRequest)
279+ -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
280+performSomeRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
281+ rs <- hrs
282+ resps <- forM rs $ \r -> case r of
283+ Left e -> do
284+ resp <- liftIO $ newMVar (Left e)
285+ return resp
286+ Right r' -> do
287+ resp <- liftIO newEmptyMVar
288+ _ <- newXhr r' $ liftIO . putMVar resp . Right
289+ return resp
290+ _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
291+ return ()
292+
293+
294+
295+-- | This function actually performs the request.
296+performRequest :: forall t m tag .(SupportsServantReflex t m)
297+ => Text
298+ -> (Req t)
299+ -> Dynamic t BaseUrl
300+ -> Event t tag
301+ -> m (Event t (tag, XhrResponse), Event t (tag, Text))
302+performRequest reqMeth req reqHost trigger = do
303+
304+ let xhrReq = reqToReflexRequest reqMeth reqHost req
305+ let reqs = attachPromptlyDynWith (flip (,)) xhrReq trigger
306+ okReqs = fmapMaybe (\(t,e) -> either (const Nothing) (Just . (t,)) e) reqs
307+ badReqs = fmapMaybe (\(t,e) -> either (Just . (t,)) (const Nothing) e) reqs
308+
309+ resps <- performRequestsAsync okReqs
210
310
211 return (resps, badReqs)
311 return (resps, badReqs)
212
312
213−#ifdef ghcjs_HOST_OS
313+
214−type XhrPayload = String
215−bytesToPayload :: BL.ByteString -> XhrPayload
216−bytesToPayload = BL.unpack
217−#else
218type XhrPayload = T.Text
314type XhrPayload = T.Text
219bytesToPayload :: BL.ByteString -> XhrPayload
315bytesToPayload :: BL.ByteString -> XhrPayload
220−bytesToPayload = T.pack . BL.unpack
316+bytesToPayload = TE.decodeUtf8 . BL.toStrict
221−#endif
317+
222−
318+
223−performRequestNoBody :: forall t m .(SupportsServantReflex t m)
319+-- performRequestNoBody :: forall t m tag.(SupportsServantReflex t m)
224− => Text
320+-- => Text
225− -> Req t
321+-- -> Req t
226− -> Dynamic t BaseUrl
322+-- -> Dynamic t BaseUrl
227− -> Event t () -> m (Event t (ReqResult NoContent))
323+-- -> Event t tag -> m (Event t (ReqResult tag NoContent))
228−performRequestNoBody reqMeth req reqHost trigger = do
324+-- performRequestNoBody reqMeth req reqHost trigger = do
229− (resp, badReq) <- performRequest reqMeth req reqHost trigger
325+-- (resp, badReq) <- performRequest reqMeth req reqHost trigger
326+-- let decodeResp = const $ Right NoContent
327+-- return $ leftmost [ fmap (evalResponse decodeResp) resp
230− return $ leftmost [ fmap (ResponseSuccess NoContent) resp, fmap RequestFailure badReq]
328+-- , fmap (uncurry RequestFailure) badReq
231−
329+-- ]
232−
330+
331+
332+-- performRequestCT
233−performRequestCT :: (SupportsServantReflex t m,
333+-- :: (SupportsServantReflex t m,
234− MimeUnrender ct a)
334+-- MimeUnrender ct a)
235− => Proxy ct -> Text -> Req t -> Dynamic t BaseUrl
335+-- => Proxy ct
236− -> Event t () -> m (Event t (ReqResult a))
336+-- -> Text
237−performRequestCT ct reqMeth req reqHost trigger = do
337+-- -> Req t
238− (resp, badReq) <- performRequest reqMeth req reqHost trigger
338+-- -> Dynamic t BaseUrl
239− let decodes = ffor resp $ \xhr ->
339+-- -> Event t tag
240− ((mimeUnrender ct . BL.fromStrict . TE.encodeUtf8)
340+-- -> m (Event t (ReqResult tag a))
241− =<< note "No body text" (_xhrResponse_responseText xhr), xhr)
341+-- performRequestCT ct reqMeth req reqHost trigger = do
242− reqs = ffor decodes $ \case
342+-- (resp, badReq) <- performRequest reqMeth req reqHost trigger
243− (Right a, r) -> ResponseSuccess a r
343+-- let decodeResp x = first T.pack .
344+-- mimeUnrender ct .
345+-- BL.fromStrict .
346+-- TE.encodeUtf8 =<< note "No body text"
347+-- (_xhrResponse_responseText x)
348+
349+-- return $ leftmost [fmap (evalResponse decodeResp) resp
350+-- , fmap (uncurry RequestFailure) badReq
351+-- ]
352+
353+
354+performRequestsCT
355+ :: (SupportsServantReflex t m,
356+ MimeUnrender ct a, Traversable f)
357+ => Proxy ct
358+ -> Text
359+ -> Dynamic t (f (Req t))
360+ -> Dynamic t BaseUrl
361+ -> Event t tag
362+ -> m (Event t (f (ReqResult tag a)))
363+performRequestsCT ct reqMeth reqs reqHost trigger = do
364+ resps <- performRequests reqMeth reqs reqHost trigger
365+ let decodeResp x = first T.pack .
366+ mimeUnrender ct .
367+ BL.fromStrict .
368+ TE.encodeUtf8 =<< note "No body text"
369+ (_xhrResponse_responseText x)
370+ return $ fmap
371+ (\(t,rs) -> ffor rs $ \r -> case r of
372+ Left e -> RequestFailure t e
373+ Right g -> evalResponse decodeResp (t,g)
374+ )
375+ resps
376+
377+
378+performRequestsNoBody
379+ :: (SupportsServantReflex t m,
380+ Traversable f)
381+ => Text
382+ -> Dynamic t (f (Req t))
383+ -> Dynamic t BaseUrl
384+ -> Event t tag
385+ -> m (Event t (f (ReqResult tag NoContent)))
386+performRequestsNoBody reqMeth reqs reqHost trigger = do
387+ resps <- performRequests reqMeth reqs reqHost trigger
388+ let decodeResp = const $ Right NoContent
389+ return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
390+ Left e -> RequestFailure tag e
391+ Right g -> evalResponse decodeResp (tag,g)
392+
393+
394+------------------------------------------------------------------------------
395+evalResponse
396+ :: (XhrResponse -> Either Text a)
397+ -> (tag, XhrResponse)
398+ -> ReqResult tag a
399+evalResponse decode (tag, xhr) =
400+ let okStatus = _xhrResponse_status xhr < 400
401+ errMsg = fromMaybe
402+ ("Empty response with error code " <>
403+ T.pack (show $ _xhrResponse_status xhr))
404+ (_xhrResponse_responseText xhr)
405+ respPayld = if okStatus
406+ then either
244− (Left e, r) -> ResponseFailure (T.pack e) r
407+ (\e -> ResponseFailure tag e xhr)
245− return $ leftmost [reqs, fmap RequestFailure badReq]
408+ (\v -> ResponseSuccess tag v xhr)
409+ (decode xhr)
410+ else ResponseFailure tag errMsg xhr
411+ in respPayld
412+
413+
414+
246
415
247note :: e -> Maybe a -> Either e a
416note :: e -> Maybe a -> Either e a
248note e = maybe (Left e) Right
417note e = maybe (Left e) Right
418+
419+fmapL :: (e -> e') -> Either e a -> Either e' a
420+fmapL _ (Right a) = Right a
421+fmapL f (Left e) = Left (f e)
src/Servant/Reflex.hs+192−160
@@ -1,16 +1,24 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE InstanceSigs #-}
6+{-# LANGUAGE InstanceSigs #-}
6−{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE OverloadedStrings #-}
7−{-# LANGUAGE PolyKinds #-}
8+{-# LANGUAGE PolyKinds #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE TupleSections #-}
10+{-# LANGUAGE TupleSections #-}
10−{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE TypeOperators #-}
12−{-# LANGUAGE UndecidableInstances #-}
13+{-# LANGUAGE UndecidableInstances #-}
13{-# LANGUAGE MultiParamTypeClasses #-}
14{-# LANGUAGE MultiParamTypeClasses #-}
15+{-# LANGUAGE OverloadedStrings #-}
16+{-# LANGUAGE PolyKinds #-}
17+{-# LANGUAGE ScopedTypeVariables #-}
18+{-# LANGUAGE TupleSections #-}
19+{-# LANGUAGE TypeFamilies #-}
20+{-# LANGUAGE TypeOperators #-}
21+{-# LANGUAGE UndecidableInstances #-}
14
22
15-- #include "overlapping-compat.h"
23-- #include "overlapping-compat.h"
16-- | This module provides 'client' which can automatically generate
24-- | This module provides 'client' which can automatically generate
@@ -18,17 +26,20 @@
18-- API.
26-- API.
19module Servant.Reflex
27module Servant.Reflex
20 ( client
28 ( client
29+ , BuildHeaderKeysTo(..)
30+ , toHeaders
21 , HasClient(..)
31 , HasClient(..)
22 , module Servant.Common.Req
32 , module Servant.Common.Req
23 , module Servant.Common.BaseUrl
33 , module Servant.Common.BaseUrl
24 ) where
34 ) where
25
35
26−-------------------------------------------------------------------------------
36+------------------------------------------------------------------------------
27import Control.Applicative
37import Control.Applicative
28import Data.Monoid ((<>))
38import Data.Monoid ((<>))
29import qualified Data.Set as Set
39import qualified Data.Set as Set
30import qualified Data.Text.Encoding as E
40import qualified Data.Text.Encoding as E
31import Data.CaseInsensitive (mk)
41import Data.CaseInsensitive (mk)
42+import Data.Functor.Identity
32import Data.Proxy (Proxy (..))
43import Data.Proxy (Proxy (..))
33import qualified Data.Map as Map
44import qualified Data.Map as Map
34import Data.Text (Text)
45import Data.Text (Text)
@@ -43,24 +54,31 @@ import Servant.API ((:<|>)(..),(:>), BasicAuth,
43 QueryParams, Raw, ReflectMethod(..),
54 QueryParams, Raw, ReflectMethod(..),
44 RemoteHost, ReqBody,
55 RemoteHost, ReqBody,
45 ToHttpApiData(..), Vault, Verb)
56 ToHttpApiData(..), Vault, Verb)
57+
58+import Reflex.Dom (Dynamic, Event, Reflex,
59+ XhrRequest(..),
60+ XhrResponseHeaders(..),
61+ XhrResponse(..), attachPromptlyDynWith, constDyn, ffor, fmapMaybe,
62+ leftmost, performRequestsAsync,
63+ )
64+------------------------------------------------------------------------------
46import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
65import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
47 showBaseUrl,
66 showBaseUrl,
48 SupportsServantReflex)
67 SupportsServantReflex)
49import Servant.Common.Req (Req, ReqResult(..), QParam(..),
68import Servant.Common.Req (Req, ReqResult(..), QParam(..),
50 QueryPart(..), addHeader, authData,
69 QueryPart(..), addHeader, authData,
51− defReq, prependToPathParts,
70+ defReq, evalResponse, prependToPathParts,
52− performRequestCT,
71+ -- performRequestCT,
72+ performRequestsCT,
53− performRequestNoBody,
73+ -- performRequestNoBody,
74+ performRequestsNoBody,
75+ performSomeRequestsAsync,
54 qParamToQueryPart, reqBody,
76 qParamToQueryPart, reqBody,
55 reqSuccess, reqFailure,
77 reqSuccess, reqFailure,
56 reqMethod, respHeaders, response,
78 reqMethod, respHeaders, response,
79+ reqTag,
57 qParams)
80 qParams)
58−import Reflex.Dom (Dynamic, Event, Reflex,
81+
59− XhrRequest(..),
60− XhrResponseHeaders(..),
61− XhrResponse(..), ffor, fmapMaybe,
62− leftmost, performRequestAsync,
63− tagPromptlyDyn )
64
82
65-- * Accessing APIs as a Client
83-- * Accessing APIs as a Client
66
84
@@ -72,28 +90,31 @@ import Reflex.Dom (Dynamic, Event, Reflex,
72-- > myApi :: Proxy MyApi
90-- > myApi :: Proxy MyApi
73-- > myApi = Proxy
91-- > myApi = Proxy
74-- >
92-- >
75−-- > getAllBooks :: Event t () -> m (Event t (Either XhrError ((),[Book])))
93+-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))
76−-- > postNewBook :: Dynamic t (Maybe Book) -> Event t ()
94+-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l
77−-- -> m (Event t (Either XhrError (Book,Book)))
95+-- -> m (Event t (l, ReqResult Book)))
78-- > (getAllBooks :<|> postNewBook) = client myApi host
96-- > (getAllBooks :<|> postNewBook) = client myApi host
79-- > where host = constDyn $ BaseUrl Http "localhost" 8080
97-- > where host = constDyn $ BaseUrl Http "localhost" 8080
80−client :: (HasClient t m layout)
98+client :: (HasClient t m layout tag)
81− => Proxy layout -> Proxy m -> Dynamic t BaseUrl -> Client t m layout
99+ => Proxy layout -> Proxy m -> Proxy tag -> Dynamic t BaseUrl -> Client t m layout tag
82−client p q baseurl = clientWithRoute p q defReq baseurl
100+client p q t baseurl = clientWithRoute p q t defReq baseurl
101+
83
102
84-- | This class lets us define how each API combinator
103-- | This class lets us define how each API combinator
85-- influences the creation of an HTTP request. It's mostly
104-- influences the creation of an HTTP request. It's mostly
86-- an internal class, you can just use 'client'.
105-- an internal class, you can just use 'client'.
87−class HasClient t m layout where
106+class HasClient t m layout (tag :: *) where
88− type Client t m layout :: *
107+ type Client t m layout tag :: *
89− clientWithRoute :: Proxy layout -> Proxy m -> Req t -> Dynamic t BaseUrl -> Client t m layout
108+ clientWithRoute :: Proxy layout -> Proxy m -> Proxy tag -> Req t -> Dynamic t BaseUrl -> Client t m layout tag
90
109
91
110
92−instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where
111+instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where
93− type Client t m (a :<|> b) = Client t m a :<|> Client t m b
112+ type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag
113+
94− clientWithRoute Proxy q req baseurl =
114+ clientWithRoute Proxy q pTag req baseurl =
95− clientWithRoute (Proxy :: Proxy a) q req baseurl :<|>
115+ clientWithRoute (Proxy :: Proxy a) q pTag req baseurl :<|>
96− clientWithRoute (Proxy :: Proxy b) q req baseurl
116+ clientWithRoute (Proxy :: Proxy b) q pTag req baseurl
117+
97
118
98-- Capture. Example:
119-- Capture. Example:
99-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
120-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
@@ -103,50 +124,54 @@ instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where
103-- > getBook :: SupportsServantReflex t m
124-- > getBook :: SupportsServantReflex t m
104-- => Dynamic t BaseUrl
125-- => Dynamic t BaseUrl
105-- -> Dynamic t (Maybe Text)
126-- -> Dynamic t (Maybe Text)
106−-- -> Event t ()
127+-- -> Event t l
107−-- -> m (Event t (Either XhrError (Text, Book)))
128+-- -> m (Event t (l, ReqResult Book))
108-- > getBook = client myApi (constDyn host)
129-- > getBook = client myApi (constDyn host)
109−instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout)
110− => HasClient t m (Capture capture a :> sublayout) where
111
130
131+instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout tag)
132+ => HasClient t m (Capture capture a :> sublayout) tag where
133+
112− type Client t m (Capture capture a :> sublayout) =
134+ type Client t m (Capture capture a :> sublayout) tag =
113− Dynamic t (Either Text a) -> Client t m sublayout
135+ Dynamic t (Either Text a) -> Client t m sublayout tag
114
136
115− clientWithRoute Proxy q req baseurl val =
137+ clientWithRoute Proxy q t req baseurl val =
116 clientWithRoute (Proxy :: Proxy sublayout)
138 clientWithRoute (Proxy :: Proxy sublayout)
117− q
139+ q t
118 (prependToPathParts p req)
140 (prependToPathParts p req)
119 baseurl
141 baseurl
120−
121 where p = (fmap . fmap) (toUrlPiece) val
142 where p = (fmap . fmap) (toUrlPiece) val
122
143
144+
123-- VERB (Returning content) --
145-- VERB (Returning content) --
124instance {-# OVERLAPPABLE #-}
146instance {-# OVERLAPPABLE #-}
125 -- Note [Non-Empty Content Types]
147 -- Note [Non-Empty Content Types]
126 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
148 (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m
127− ) => HasClient t m (Verb method status cts' a) where
149+ ) => HasClient t m (Verb method status cts' a) tag where
128− type Client t m (Verb method status cts' a) =
150+ type Client t m (Verb method status cts' a) tag =
129− Event t () -> m (Event t (ReqResult a))
151+ Event t tag -> m (Event t (ReqResult tag a))
130 -- TODO how to access input types here?
152 -- TODO how to access input types here?
131 -- ExceptT ServantError IO a
153 -- ExceptT ServantError IO a
132− clientWithRoute Proxy _ req baseurl =
154+ clientWithRoute Proxy _ _ req baseurl trigs =
133− performRequestCT (Proxy :: Proxy ct) method req' baseurl
155+ -- performRequestCT (Proxy :: Proxy ct) method req' baseurl trigs
156+ fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl trigs
134 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
157 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
135 req' = req { reqMethod = method }
158 req' = req { reqMethod = method }
136
159
160+
137-- -- VERB (No content) --
161-- -- VERB (No content) --
138instance {-# OVERLAPPING #-}
162instance {-# OVERLAPPING #-}
139 (ReflectMethod method, SupportsServantReflex t m) =>
163 (ReflectMethod method, SupportsServantReflex t m) =>
140− HasClient t m (Verb method status cts NoContent) where
164+ HasClient t m (Verb method status cts NoContent) tag where
141− type Client t m (Verb method status cts NoContent) =
165+ type Client t m (Verb method status cts NoContent) tag =
142− Event t () -> m (Event t (ReqResult NoContent))
166+ Event t tag -> m (Event t (ReqResult tag NoContent))
143 -- TODO: how to access input types here?
167 -- TODO: how to access input types here?
144 -- ExceptT ServantError IO NoContent
168 -- ExceptT ServantError IO NoContent
145− clientWithRoute Proxy _ req baseurl =
169+ clientWithRoute Proxy _ _ req baseurl =
146− performRequestNoBody method req baseurl
170+ (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl
147 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
171 where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
148
172
173+
149−toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)
174+toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)
150toHeaders r =
175toHeaders r =
151 let toBS = E.encodeUtf8
176 let toBS = E.encodeUtf8
152 hdrs = maybe []
177 hdrs = maybe []
@@ -162,8 +187,8 @@ instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
162 where buildHeaderKeysTo _ = []
187 where buildHeaderKeysTo _ = []
163
188
164instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
189instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
165− => BuildHeaderKeysTo '[(Header h v) ': xs] where
190+ => BuildHeaderKeysTo ((Header h v) ': xs) where
166− buildHeaderKeysTo _ = (T.pack $ symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
191+ buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
167
192
168-- HEADERS Verb (Content) --
193-- HEADERS Verb (Content) --
169-- Headers combinator not treated in fully general case,
194-- Headers combinator not treated in fully general case,
@@ -175,33 +200,35 @@ instance {-# OVERLAPPABLE #-}
175 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
200 ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
176 ReflectMethod method, cts' ~ (ct ': cts),
201 ReflectMethod method, cts' ~ (ct ': cts),
177 SupportsServantReflex t m
202 SupportsServantReflex t m
178− ) => HasClient t m (Verb method status cts' (Headers ls a)) where
203+ ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where
179− type Client t m (Verb method status cts' (Headers ls a)) =
204+ type Client t m (Verb method status cts' (Headers ls a)) tag =
180− Event t () -> m (Event t (ReqResult (Headers ls a)))
205+ Event t tag -> m (Event t (ReqResult tag (Headers ls a)))
181− clientWithRoute Proxy _ req baseurl = do
206+ clientWithRoute Proxy _ _ req baseurl trigs = do
182 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
207 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
183− resp <- performRequestCT (Proxy :: Proxy ct) method req' baseurl
208+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl trigs
184− return $ (fmap . fmap) toHeaders resp
209+ return $ toHeaders <$> resp
185 where req' = req { respHeaders =
210 where req' = req { respHeaders =
186 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
211 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
187 }
212 }
188
213
214+
189-- HEADERS Verb (No content) --
215-- HEADERS Verb (No content) --
190instance {-# OVERLAPPABLE #-}
216instance {-# OVERLAPPABLE #-}
191 ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,
217 ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,
192 SupportsServantReflex t m
218 SupportsServantReflex t m
193− ) => HasClient t m (Verb method status cts (Headers ls NoContent)) where
219+ ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where
194− type Client t m (Verb method status cts (Headers ls NoContent))
220+ type Client t m (Verb method status cts (Headers ls NoContent)) tag
195− = Event t () -> m (Event t (ReqResult (Headers ls NoContent)))
221+ = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))
196− clientWithRoute Proxy _ req baseurl = do
222+ clientWithRoute Proxy _ _ req baseurl trigs = do
197 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
223 let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
198− resp <- performRequestNoBody method req' baseurl
224+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl trigs
199− return $ (fmap . fmap) toHeaders resp
225+ return $ toHeaders <$> resp
200 where req' = req {respHeaders =
226 where req' = req {respHeaders =
201 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
227 OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))
202 }
228 }
203
229
204
230
231+
205-- HEADER
232-- HEADER
206-- > newtype Referer = Referer { referrer :: Text }
233-- > newtype Referer = Referer { referrer :: Text }
207-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)
234-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)
@@ -216,29 +243,32 @@ instance {-# OVERLAPPABLE #-}
216-- > -- then you can just use "viewRefer" to query that endpoint
243-- > -- then you can just use "viewRefer" to query that endpoint
217-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
244-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
218instance (KnownSymbol sym, ToHttpApiData a,
245instance (KnownSymbol sym, ToHttpApiData a,
219− HasClient t m sublayout, SupportsServantReflex t m)
246+ HasClient t m sublayout tag, SupportsServantReflex t m)
220− => HasClient t m (Header sym a :> sublayout) where
247+ => HasClient t m (Header sym a :> sublayout) tag where
221
248
222− type Client t m (Header sym a :> sublayout) =
249+ type Client t m (Header sym a :> sublayout) tag =
223− Dynamic t (Either Text a) -> Client t m sublayout
250+ Dynamic t (Either Text a) -> Client t m sublayout tag
224
251
225− clientWithRoute Proxy q req baseurl eVal =
252+ clientWithRoute Proxy q t req baseurl eVal =
226 clientWithRoute (Proxy :: Proxy sublayout)
253 clientWithRoute (Proxy :: Proxy sublayout)
227− q
254+ q t
228 (Servant.Common.Req.addHeader hname eVal req)
255 (Servant.Common.Req.addHeader hname eVal req)
229 baseurl
256 baseurl
230 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
257 where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
231
258
259+
260+
261+
232-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
262-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
233-- functions.
263-- functions.
234−instance HasClient t m sublayout
264+instance HasClient t m sublayout tag
235− => HasClient t m (HttpVersion :> sublayout) where
265+ => HasClient t m (HttpVersion :> sublayout) tag where
236
266
237− type Client t m (HttpVersion :> sublayout) =
267+ type Client t m (HttpVersion :> sublayout) tag =
238− Client t m sublayout
268+ Client t m sublayout tag
239
269
240− clientWithRoute Proxy q =
270+ clientWithRoute Proxy q t =
241− clientWithRoute (Proxy :: Proxy sublayout) q
271+ clientWithRoute (Proxy :: Proxy sublayout) q t
242
272
243
273
244-- | If you use a 'QueryParam' in one of your endpoints in your API,
274-- | If you use a 'QueryParam' in one of your endpoints in your API,
@@ -267,15 +297,15 @@ instance HasClient t m sublayout
267-- > -- then you can just use "getBooksBy" to query that endpoint.
297-- > -- then you can just use "getBooksBy" to query that endpoint.
268-- > -- 'getBooksBy Nothing' for all books
298-- > -- 'getBooksBy Nothing' for all books
269-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
299-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
270−instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
300+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)
271− => HasClient t m (QueryParam sym a :> sublayout) where
301+ => HasClient t m (QueryParam sym a :> sublayout) tag where
272
302
273− type Client t m (QueryParam sym a :> sublayout) =
303+ type Client t m (QueryParam sym a :> sublayout) tag =
274− Dynamic t (QParam a) -> Client t m sublayout
304+ Dynamic t (QParam a) -> Client t m sublayout tag
275
305
276 -- if mparam = Nothing, we don't add it to the query string
306 -- if mparam = Nothing, we don't add it to the query string
277− clientWithRoute Proxy q req baseurl mparam =
307+ clientWithRoute Proxy q t req baseurl mparam =
278− clientWithRoute (Proxy :: Proxy sublayout) q
308+ clientWithRoute (Proxy :: Proxy sublayout) q t
279 (req {qParams = paramPair : qParams req}) baseurl
309 (req {qParams = paramPair : qParams req}) baseurl
280
310
281 where pname = symbolVal (Proxy :: Proxy sym)
311 where pname = symbolVal (Proxy :: Proxy sym)
@@ -284,6 +314,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
284 p prm = QueryPartParam $ fmap qParamToQueryPart prm -- (fmap . fmap) (unpack . toQueryParam) prm
314 p prm = QueryPartParam $ fmap qParamToQueryPart prm -- (fmap . fmap) (unpack . toQueryParam) prm
285 paramPair = (T.pack pname, p mparam)
315 paramPair = (T.pack pname, p mparam)
286
316
317+
318+
287-- | If you use a 'QueryParams' in one of your endpoints in your API,
319-- | If you use a 'QueryParams' in one of your endpoints in your API,
288-- the corresponding querying function will automatically take
320-- the corresponding querying function will automatically take
289-- an additional argument, a list of values of the type specified
321-- an additional argument, a list of values of the type specified
@@ -312,21 +344,22 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
312-- > -- 'getBooksBy []' for all books
344-- > -- 'getBooksBy []' for all books
313-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
345-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
314-- > -- to get all books by Asimov and Heinlein
346-- > -- to get all books by Asimov and Heinlein
315−instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
347+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)
316− => HasClient t m (QueryParams sym a :> sublayout) where
348+ => HasClient t m (QueryParams sym a :> sublayout) tag where
317
349
318− type Client t m (QueryParams sym a :> sublayout) =
350+ type Client t m (QueryParams sym a :> sublayout) tag =
319− Dynamic t [a] -> Client t m sublayout
351+ Dynamic t [a] -> Client t m sublayout tag
320
352
321− clientWithRoute Proxy q req baseurl paramlist =
353+ clientWithRoute Proxy q t req baseurl paramlist =
322− clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl
354+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
323
355
324 where req' = req { qParams = (T.pack pname, params') : qParams req }
356 where req' = req { qParams = (T.pack pname, params') : qParams req }
325 pname = symbolVal (Proxy :: Proxy sym)
357 pname = symbolVal (Proxy :: Proxy sym)
326− params' = QueryPartParams $ (fmap . fmap) (toQueryParam)
358+ params' = QueryPartParams $ (fmap . fmap) toQueryParam
327 paramlist
359 paramlist
328
360
329
361
362+
330-- | If you use a 'QueryFlag' in one of your endpoints in your API,
363-- | If you use a 'QueryFlag' in one of your endpoints in your API,
331-- the corresponding querying function will automatically take
364-- the corresponding querying function will automatically take
332-- an additional 'Bool' argument.
365-- an additional 'Bool' argument.
@@ -351,49 +384,42 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
351-- > -- 'getBooksBy True' to only get _already published_ books
384-- > -- 'getBooksBy True' to only get _already published_ books
352
385
353-- TODO Bring back
386-- TODO Bring back
354−instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)
387+instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)
355− => HasClient t m (QueryFlag sym :> sublayout) where
388+ => HasClient t m (QueryFlag sym :> sublayout) tag where
356
389
357− type Client t m (QueryFlag sym :> sublayout) =
390+ type Client t m (QueryFlag sym :> sublayout) tag =
358− Dynamic t Bool -> Client t m sublayout
391+ Dynamic t Bool -> Client t m sublayout tag
359
392
360− clientWithRoute Proxy q req baseurl flag =
393+ clientWithRoute Proxy q t req baseurl flag =
361− clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl
394+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
362
395
363 where req' = req { qParams = thisPair : qParams req }
396 where req' = req { qParams = thisPair : qParams req }
364 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
397 thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)
365 pName = symbolVal (Proxy :: Proxy sym)
398 pName = symbolVal (Proxy :: Proxy sym)
366
399
367
400
368−-- | Pick a 'Method' and specify where the server you want to query is. You get
401+
369−-- back the full `Response`.
402+-- | Send a raw 'XhrRequest ()' directly to 'baseurl'
370−-- TODO redo
371−instance SupportsServantReflex t m => HasClient t m Raw where
403+instance SupportsServantReflex t m => HasClient t m Raw tag where
372− type Client t m Raw = Dynamic t (Either Text (XhrRequest ()))
404+ type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))
373− -> Event t ()
405+ -> Event t tag
374− -> m (Event t (ReqResult ()))
406+ -> m (Event t (ReqResult tag ()))
375−
407+
376− -- clientWithRoute :: Proxy Raw -> Proxy m -> Req -> BaseUrl -> Client t m Raw
377− clientWithRoute _ _ _ baseurl xhrs triggers = do
408+ clientWithRoute _ _ _ _ baseurl xhrs triggers = do
409+
378− let xhrs' = liftA2 (\x path -> case x of
410+ let xhrs' = liftA2 (\x path -> case x of
379− Left e -> Left e
411+ Left e -> Left e
380− Right jx -> Right $ jx {_xhrRequest_url = path
412+ Right jx -> Right $ jx { _xhrRequest_url = path <> _xhrRequest_url jx }
381− <> _xhrRequest_url jx})
382− xhrs
383− (showBaseUrl <$> baseurl)
413+ ) xhrs (showBaseUrl <$> baseurl)
384− reqs = tagPromptlyDyn xhrs' triggers
414+ xhrs'' = attachPromptlyDynWith (flip (,)) xhrs' triggers :: Event t (tag, Either Text (XhrRequest ()))
385− okReq = fmapMaybe hush reqs
415+ badReq = fmapMaybe (\(t,x) -> either (Just . (t,)) (const Nothing) x) xhrs'' :: Event t (tag, Text)
386− badReq = fmapMaybe tattle reqs
416+ okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())
387− resps <- performRequestAsync okReq
417+
388− return $ leftmost [fmap (ResponseSuccess () ) resps
418+ resps <- performRequestsAsync okReq
389− ,fmap RequestFailure badReq]
419+ return $ leftmost [ uncurry RequestFailure <$> badReq
390−
420+ , evalResponse (const $ Right ()) <$> resps
391−
421+ ]
392−hush :: Either e a -> Maybe a
422+
393−hush = either (const Nothing) Just
394−
395−tattle :: Either e a -> Maybe e
396−tattle = either Just (const Nothing)
397
423
398-- | If you use a 'ReqBody' in one of your endpoints in your API,
424-- | If you use a 'ReqBody' in one of your endpoints in your API,
399-- the corresponding querying function will automatically take
425-- the corresponding querying function will automatically take
@@ -415,14 +441,14 @@ tattle = either Just (const Nothing)
415-- > where host = BaseUrl Http "localhost" 8080
441-- > where host = BaseUrl Http "localhost" 8080
416-- > -- then you can just use "addBook" to query that endpoint
442-- > -- then you can just use "addBook" to query that endpoint
417
443
418−instance (MimeRender ct a, HasClient t m sublayout, Reflex t)
444+instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)
419− => HasClient t m (ReqBody (ct ': cts) a :> sublayout) where
445+ => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where
420
446
421− type Client t m (ReqBody (ct ': cts) a :> sublayout) =
447+ type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =
422− Dynamic t (Either Text a) -> Client t m sublayout
448+ Dynamic t (Either Text a) -> Client t m sublayout tag
423
449
424− clientWithRoute Proxy q req baseurl body =
450+ clientWithRoute Proxy q t req baseurl body =
425− clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl
451+ clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl
426 where req' = req { reqBody = bodyBytesCT }
452 where req' = req { reqBody = bodyBytesCT }
427 ctProxy = Proxy :: Proxy ct
453 ctProxy = Proxy :: Proxy ct
428 ctString = T.pack $ show $ contentType ctProxy
454 ctString = T.pack $ show $ contentType ctProxy
@@ -430,43 +456,49 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)
430 (\b -> (mimeRender ctProxy b, ctString))
456 (\b -> (mimeRender ctProxy b, ctString))
431 body
457 body
432
458
459+
460+
433-- | Make the querying function append @path@ to the request path.
461-- | Make the querying function append @path@ to the request path.
434−instance (KnownSymbol path, HasClient t m sublayout, Reflex t) => HasClient t m (path :> sublayout) where
462+instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where
435− type Client t m (path :> sublayout) = Client t m sublayout
463+ type Client t m (path :> sublayout) tag = Client t m sublayout tag
436
464
437− clientWithRoute Proxy q req baseurl =
465+ clientWithRoute Proxy q t req baseurl =
438− clientWithRoute (Proxy :: Proxy sublayout) q
466+ clientWithRoute (Proxy :: Proxy sublayout) q t
439− (prependToPathParts (pure (Right $ T.pack p)) req)
467+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl
440− baseurl
441
468
442 where p = symbolVal (Proxy :: Proxy path)
469 where p = symbolVal (Proxy :: Proxy path)
443
470
444−instance HasClient t m api => HasClient t m (Vault :> api) where
445− type Client t m (Vault :> api) = Client t m api
446
471
472+instance HasClient t m api tag => HasClient t m (Vault :> api) tag where
473+ type Client t m (Vault :> api) tag = Client t m api tag
474+
447− clientWithRoute Proxy q req baseurl =
475+ clientWithRoute Proxy q t req baseurl =
448− clientWithRoute (Proxy :: Proxy api) q req baseurl
476+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
477+
478+
479+instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where
480+ type Client t m (RemoteHost :> api) tag = Client t m api tag
481+
482+ clientWithRoute Proxy q t req baseurl =
483+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
484+
449
485
450−instance HasClient t m api => HasClient t m (RemoteHost :> api) where
451− type Client t m (RemoteHost :> api) = Client t m api
452
486
453− clientWithRoute Proxy q req baseurl =
487+instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where
454− clientWithRoute (Proxy :: Proxy api) q req baseurl
488+ type Client t m (IsSecure :> api) tag = Client t m api tag
455
489
456−instance HasClient t m api => HasClient t m (IsSecure :> api) where
490+ clientWithRoute Proxy q t req baseurl =
457− type Client t m (IsSecure :> api) = Client t m api
491+ clientWithRoute (Proxy :: Proxy api) q t req baseurl
458
492
459− clientWithRoute Proxy q req baseurl =
460− clientWithRoute (Proxy :: Proxy api) q req baseurl
461
493
462−instance (HasClient t m api, Reflex t)
494+instance (HasClient t m api tag, Reflex t)
463− => HasClient t m (BasicAuth realm usr :> api) where
495+ => HasClient t m (BasicAuth realm usr :> api) tag where
464
496
465− type Client t m (BasicAuth realm usr :> api) = Dynamic t (Maybe BasicAuthData)
497+ type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)
466− -> Client t m api
498+ -> Client t m api tag
467
499
468− clientWithRoute Proxy q req baseurl authdata =
500+ clientWithRoute Proxy q t req baseurl authdata =
469− clientWithRoute (Proxy :: Proxy api) q req' baseurl
501+ clientWithRoute (Proxy :: Proxy api) q t req' baseurl
470 where
502 where
471 req' = req { authData = Just authdata }
503 req' = req { authData = Just authdata }
472
504
src/Servant/Reflex/Multi.hsnew file+372
@@ -0,0 +1,372 @@
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+ , BaseUrl(..)
20+ , Scheme(..)
21+
22+ -- * Build QueryParam arguments
23+ , QParam(..)
24+
25+
26+ -- * Access response data
27+ , ReqResult(..)
28+ , reqSuccess
29+ , reqSuccess'
30+ , reqFailure
31+ , response
32+
33+ , HasClientMulti(..)
34+ ) where
35+
36+------------------------------------------------------------------------------
37+import Control.Applicative (liftA2)
38+import Data.Functor.Compose (Compose (..), getCompose)
39+import Data.Proxy (Proxy (..))
40+import qualified Data.Set as Set
41+import Data.Text (Text)
42+import qualified Data.Text as T
43+import qualified Data.Text.Encoding as E
44+import GHC.TypeLits (KnownSymbol, symbolVal)
45+import Servant.API ((:<|>) (..), (:>), BasicAuth,
46+ BasicAuthData, BuildHeadersTo (..),
47+ Capture, Header, Headers (..),
48+ HttpVersion, IsSecure, MimeRender (..),
49+ MimeUnrender, NoContent, QueryFlag,
50+ QueryParam, QueryParams, Raw,
51+ ReflectMethod (..), RemoteHost,
52+ ReqBody, ToHttpApiData (..), Vault,
53+ Verb, contentType)
54+
55+import Reflex.Dom (Dynamic, Event, Reflex,
56+ XhrRequest (..),
57+ XhrResponseHeaders (..),
58+ attachPromptlyDynWith, constDyn)
59+------------------------------------------------------------------------------
60+import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
61+ SupportsServantReflex)
62+import Servant.Common.Req (QParam (..), QueryPart (..), Req,
63+ ReqResult (..), addHeader, authData,
64+ defReq, performRequestsCT,
65+ performRequestsNoBody,
66+ performSomeRequestsAsync,
67+ prependToPathParts, qParamToQueryPart,
68+ qParams, reqBody, reqFailure,
69+ reqMethod, reqSuccess, reqSuccess',
70+ respHeaders, response)
71+import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)
72+
73+
74+------------------------------------------------------------------------------
75+clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)
76+ => Proxy layout -> Proxy m -> Proxy f -> Proxy tag
77+ -> Dynamic t BaseUrl -> ClientMulti t m layout f tag
78+clientA p q f tag baseurl =
79+ clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl
80+
81+
82+------------------------------------------------------------------------------
83+class HasClientMulti t m layout f (tag :: *) where
84+ type ClientMulti t m layout f tag :: *
85+ clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag
86+ -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl
87+ -> ClientMulti t m layout f tag
88+
89+
90+------------------------------------------------------------------------------
91+instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>
92+ HasClientMulti t m (a :<|> b) f tag where
93+ type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>
94+ ClientMulti t m b f tag
95+ clientWithRouteMulti Proxy q f tag reqs baseurl =
96+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl :<|>
97+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl
98+
99+
100+------------------------------------------------------------------------------
101+instance (SupportsServantReflex t m,
102+ ToHttpApiData a,
103+ HasClientMulti t m sublayout f tag,
104+ Applicative f)
105+ => HasClientMulti t m (Capture capture a :> sublayout) f tag where
106+
107+ type ClientMulti t m (Capture capture a :> sublayout) f tag =
108+ f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
109+
110+ clientWithRouteMulti _ q f tag reqs baseurl vals =
111+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
112+ where
113+ reqs' = (prependToPathParts <$> ps <*>) <$> reqs
114+ ps = (fmap . fmap . fmap) toUrlPiece vals
115+
116+
117+------------------------------------------------------------------------------
118+-- VERB (Returning content) --
119+instance {-# OVERLAPPABLE #-}
120+ -- Note [Non-Empty Content Types]
121+ (MimeUnrender ct a,
122+ ReflectMethod method, cts' ~ (ct ': cts),
123+ SupportsServantReflex t m,
124+ Applicative f,
125+ Traversable f
126+ ) => HasClientMulti t m (Verb method status cts' a) f tag where
127+
128+ type ClientMulti t m (Verb method status cts' a) f tag =
129+ Event t tag -> m (Event t (f (ReqResult tag a)))
130+
131+ clientWithRouteMulti _ _ _ _ reqs baseurl =
132+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl
133+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
134+ reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs
135+
136+
137+------------------------------------------------------------------------------
138+-- -- VERB (No content) --
139+instance {-# OVERLAPPING #-}
140+ (ReflectMethod method, SupportsServantReflex t m, Traversable f) =>
141+ HasClientMulti t m (Verb method status cts NoContent) f tag where
142+ type ClientMulti t m (Verb method status cts NoContent) f tag =
143+ Event t tag -> m (Event t (f (ReqResult tag NoContent)))
144+ -- TODO: how to access input types here?
145+ -- ExceptT ServantError IO NoContent
146+ clientWithRouteMulti Proxy _ _ _ req baseurl =
147+ performRequestsNoBody method req baseurl
148+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
149+
150+
151+------------------------------------------------------------------------------
152+instance {-# OVERLAPPABLE #-}
153+ -- Note [Non-Empty Content Types]
154+ ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,
155+ ReflectMethod method, cts' ~ (ct ': cts),
156+ SupportsServantReflex t m,
157+ Traversable f
158+ ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where
159+ type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =
160+ Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))
161+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
162+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
163+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl triggers :: m (Event t (f (ReqResult tag a)))
164+ return $ fmap toHeaders <$> resp
165+ where
166+ reqs' = fmap (\r ->
167+ r { respHeaders =
168+ OnlyHeaders (Set.fromList
169+ (buildHeaderKeysTo (Proxy :: Proxy ls)))
170+ }) <$> reqs
171+
172+
173+------------------------------------------------------------------------------
174+instance {-# OVERLAPPABLE #-}
175+ ( BuildHeadersTo ls,
176+ BuildHeaderKeysTo ls,
177+ ReflectMethod method,
178+ SupportsServantReflex t m,
179+ Traversable f
180+ ) => HasClientMulti t m (Verb method status
181+ cts (Headers ls NoContent)) f tag where
182+ type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag
183+ = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))
184+ clientWithRouteMulti Proxy _ _ _ reqs baseurl triggers = do
185+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
186+ resp <- performRequestsNoBody method reqs' baseurl triggers
187+ return $ fmap toHeaders <$> resp
188+ where reqs' = fmap (\req ->
189+ req {respHeaders = OnlyHeaders (Set.fromList
190+ (buildHeaderKeysTo (Proxy :: Proxy ls)))
191+ }) <$> reqs
192+
193+
194+------------------------------------------------------------------------------
195+instance (KnownSymbol sym,
196+ ToHttpApiData a,
197+ HasClientMulti t m sublayout f tag,
198+ SupportsServantReflex t m,
199+ Traversable f,
200+ Applicative f)
201+ => HasClientMulti t m (Header sym a :> sublayout) f tag where
202+
203+ type ClientMulti t m (Header sym a :> sublayout) f tag =
204+ f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag
205+
206+ clientWithRouteMulti Proxy f q tag reqs baseurl eVals =
207+ clientWithRouteMulti (Proxy :: Proxy sublayout) f
208+ q tag
209+ reqs'
210+ baseurl
211+ where hname = T.pack $ symbolVal (Proxy :: Proxy sym)
212+ reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)
213+ <$> eVals <*>) <$> reqs
214+
215+
216+------------------------------------------------------------------------------
217+instance HasClientMulti t m sublayout f tag
218+ => HasClientMulti t m (HttpVersion :> sublayout) f tag where
219+
220+ type ClientMulti t m (HttpVersion :> sublayout) f tag =
221+ ClientMulti t m sublayout f tag
222+
223+ clientWithRouteMulti Proxy q f tag =
224+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
225+
226+
227+------------------------------------------------------------------------------
228+instance (KnownSymbol sym,
229+ ToHttpApiData a,
230+ HasClientMulti t m sublayout f tag,
231+ Reflex t,
232+ Applicative f)
233+ => HasClientMulti t m (QueryParam sym a :> sublayout) f tag where
234+
235+ type ClientMulti t m (QueryParam sym a :> sublayout) f tag =
236+ Dynamic t (f (QParam a)) -> ClientMulti t m sublayout f tag
237+
238+ -- if mparam = Nothing, we don't add it to the query string
239+ -- TODO: Check the above comment
240+ clientWithRouteMulti Proxy q f tag reqs baseurl mparams =
241+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
242+ reqs' baseurl
243+
244+ where pname = symbolVal (Proxy :: Proxy sym)
245+ p prm = QueryPartParam $ fmap qParamToQueryPart prm
246+ paramPair mp = (T.pack pname, p mp)
247+ -- reqs' = (\params reqs -> (\req param -> req {qParams = paramPair param : qParams req}) <$> reqs <*> params)
248+ -- <$> mparams <*> reqs
249+ reqs' = liftA2 (\(pr :: QParam a) (r :: Req t) -> r { qParams = paramPair (constDyn pr) : qParams r })
250+ <$> mparams <*> reqs
251+
252+
253+instance (KnownSymbol sym,
254+ ToHttpApiData a,
255+ HasClientMulti t m sublayout f tag,
256+ Reflex t,
257+ Applicative f)
258+ => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where
259+
260+ type ClientMulti t m (QueryParams sym a :> sublayout) f tag =
261+ Dynamic t (f [a]) -> ClientMulti t m sublayout f tag
262+
263+ clientWithRouteMulti Proxy q f tag reqs baseurl paramlists =
264+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
265+
266+ where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }
267+ pname = symbolVal (Proxy :: Proxy sym)
268+ params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)
269+ l
270+ reqs' = liftA2 req' <$> paramlists <*> reqs
271+
272+
273+instance (KnownSymbol sym,
274+ HasClientMulti t m sublayout f tag,
275+ Reflex t,
276+ Applicative f)
277+ => HasClientMulti t m (QueryFlag sym :> sublayout) f tag where
278+
279+ type ClientMulti t m (QueryFlag sym :> sublayout) f tag =
280+ Dynamic t (f Bool) -> ClientMulti t m sublayout f tag
281+
282+ clientWithRouteMulti Proxy q f' tag reqs baseurl flags =
283+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl
284+
285+ where req' f req = req { qParams = thisPair (constDyn f) : qParams req }
286+ thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)
287+ pName = symbolVal (Proxy :: Proxy sym)
288+ reqs' = liftA2 req' <$> flags <*> reqs
289+
290+
291+instance (SupportsServantReflex t m,
292+ Traversable f, Applicative f) => HasClientMulti t m Raw f tag where
293+ type ClientMulti t m Raw f tag = f (Dynamic t (Either Text (XhrRequest ())))
294+ -> Event t tag
295+ -> m (Event t (f (ReqResult tag ())))
296+
297+ clientWithRouteMulti _ _ _ _ _ _ rawReqs triggers = do
298+ let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))
299+ rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers
300+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync rawReqs''
301+ return resps
302+ where
303+ aux (tag, Right r) = ResponseSuccess tag () r
304+ aux (tag, Left e) = RequestFailure tag e
305+
306+
307+instance (MimeRender ct a,
308+ HasClientMulti t m sublayout f tag,
309+ Reflex t,
310+ Applicative f)
311+ => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where
312+
313+ type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =
314+ Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag
315+
316+ clientWithRouteMulti Proxy q f tag reqs baseurl bodies =
317+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl
318+ where req' b r = r { reqBody = bodyBytesCT (constDyn b) }
319+ ctProxy = Proxy :: Proxy ct
320+ ctString = T.pack $ show $ contentType ctProxy
321+ bodyBytesCT b = Just $ (fmap . fmap)
322+ (\b' -> (mimeRender ctProxy b', ctString))
323+ b
324+ reqs' = liftA2 req' <$> bodies <*> reqs
325+
326+
327+instance (KnownSymbol path,
328+ HasClientMulti t m sublayout f tag,
329+ Reflex t,
330+ Functor f) => HasClientMulti t m (path :> sublayout) f tag where
331+ type ClientMulti t m (path :> sublayout) f tag = ClientMulti t m sublayout f tag
332+
333+ clientWithRouteMulti Proxy q f tag reqs baseurl =
334+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag
335+ (fmap (prependToPathParts (pure (Right $ T.pack p))) <$> reqs)
336+ baseurl
337+
338+ where p = symbolVal (Proxy :: Proxy path)
339+
340+
341+instance HasClientMulti t m api f tag => HasClientMulti t m (Vault :> api) f tag where
342+ type ClientMulti t m (Vault :> api) f tag = ClientMulti t m api f tag
343+
344+ clientWithRouteMulti Proxy q f tag reqs baseurl =
345+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl
346+
347+
348+instance HasClientMulti t m api f tag => HasClientMulti t m (RemoteHost :> api) f tag where
349+ type ClientMulti t m (RemoteHost :> api) f tag = ClientMulti t m api f tag
350+
351+ clientWithRouteMulti Proxy q f tag reqs baseurl =
352+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl
353+
354+
355+instance HasClientMulti t m api f tag => HasClientMulti t m (IsSecure :> api) f tag where
356+ type ClientMulti t m (IsSecure :> api) f tag = ClientMulti t m api f tag
357+
358+ clientWithRouteMulti Proxy q f tag reqs baseurl =
359+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl
360+
361+
362+instance (HasClientMulti t m api f tag, Reflex t, Applicative f)
363+ => HasClientMulti t m (BasicAuth realm usr :> api) f tag where
364+
365+ type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))
366+ -> ClientMulti t m api f tag
367+
368+ clientWithRouteMulti Proxy q f tag reqs baseurl authdatas =
369+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl
370+ where
371+ req' a r = r { authData = Just (constDyn a) }
372+ reqs' = liftA2 req' <$> authdatas <*> reqs
stack.yamlnew file+56
@@ -0,0 +1,56 @@
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
testserver/Main.hs+20−10
@@ -5,24 +5,27 @@
5{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeOperators #-}
6{-# LANGUAGE TypeOperators #-}
7
7
8+import Control.Monad.IO.Class (liftIO)
8import Data.Aeson
9import Data.Aeson
9import Data.Bool
10import Data.Bool
10−import Data.Char (toUpper)
11+import Data.Char (toUpper)
11−import qualified Data.List as L
12+import qualified Data.List as L
12import Data.Monoid
13import Data.Monoid
13import Data.Proxy
14import Data.Proxy
14−import Data.Text hiding (length, null, map, head, toUpper)
15+import Data.Text hiding (head, length, map,
16+ null, toUpper)
15−import qualified Data.Text as T
17+import qualified Data.Text as T
18+import qualified Data.Text.IO as T
16import GHC.Generics
19import GHC.Generics
17−import Snap.Http.Server
18−import Snap.Core
19import Servant.Server.Internal.SnapShims
20import Servant.Server.Internal.SnapShims
21+import Snap.Core
22+import Snap.Http.Server
20
23
21−import Servant -- hiding (serveDirectory)
24+import Servant
22import Servant.Server
25import Servant.Server
23-- import Snap.Util.FileServe
26-- import Snap.Util.FileServe
24import API
27import API
25−import Snap
28+import Snap
26
29
27-- * Example
30-- * Example
28
31
@@ -45,7 +48,7 @@ data App = App
45--
48--
46-- Each handler runs in the 'ExceptT ServantErr IO' monad.
49-- Each handler runs in the 'ExceptT ServantErr IO' monad.
47server :: Server API (Handler App App)
50server :: Server API (Handler App App)
48−server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> serveDirectory "static"
51+server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> serveDirectory "static"
49 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
52 where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
50 sayhi nm greetings withGusto = case nm of
53 sayhi nm greetings withGusto = case nm of
51 Nothing -> return ("Sorry, who are you?" :: Text)
54 Nothing -> return ("Sorry, who are you?" :: Text)
@@ -57,8 +60,15 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> serveDire
57 | otherwise = T.intercalate ", " (L.init greetings)
60 | otherwise = T.intercalate ", " (L.init greetings)
58 <> ", and " <> L.last greetings <> ", "
61 <> ", and " <> L.last greetings <> ", "
59 return . modifier $ greetPart <> n
62 return . modifier $ greetPart <> n
63+ dbl x = if x `elem` [4,13]
64+ then throwError $ err500 { errBody = "No unlucky numbers please" }
60− dbl x = return $ x * 2
65+ else return $ x * 2
61 multi = return . bool "Box unchecked" "Box Checked"
66 multi = return . bool "Box unchecked" "Box Checked"
67+ qna q = do
68+ liftIO $ do
69+ putStrLn $ "qna got: " ++ show q
70+ T.putStrLn $ unQuestion q
71+ return $ Answer $ unQuestion q
62
72
63-- Turn the server into a WAI app. 'serve' is provided by servant,
73-- Turn the server into a WAI app. 'serve' is provided by servant,
64-- more precisely by the Servant.Server module.
74-- more precisely by the Servant.Server module.
testserver/testserver.cabal+11−11
@@ -1,31 +1,31 @@
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.1
22 build-depends: aeson >= 0.9 && < 1.1
23 , base >=4.8 && <4.10
23 , base >=4.8 && <4.10
24 , snap >= 1.0 && < 1.1
24 , snap >= 1.0 && < 1.1
25 , snap-server >= 1.0 && < 1.1
25 , snap-server >= 1.0 && < 1.1
26 , snap-core >= 1.0 && < 1.1
26 , snap-core >= 1.0 && < 1.1
27− , servant >= 0.7.1 && < 0.9
27+ , servant >= 0.8 && < 0.11
28− , servant-snap >= 0.7 && < 0.8
28+ , servant-snap >= 0.7.2 && < 0.8
29 , text >= 1.2 && < 1.3
29 , text >= 1.2 && < 1.3
30− -- hs-source-dirs:
30+ -- hs-source-dirs:
31 default-language: Haskell2010
31 default-language: Haskell2010