servant-reflex (empty) → 0.3.4
raw patch · 9 files changed
+1903/−0 lines, 9 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, case-insensitive, containers, data-default, exceptions, ghcjs-dom, http-api-data, http-media, jsaddle, mtl, network-uri, reflex, reflex-dom, reflex-dom-core, safe, scientific, servant, servant-auth, servant-reflex, string-conversions, text, transformers
Files
- LICENSE.md +30/−0
- Setup.hs +2/−0
- exec/API.hs +69/−0
- exec/Example.hs +218/−0
- servant-reflex.cabal +61/−0
- src/Servant/Common/BaseUrl.hs +99/−0
- src/Servant/Common/Req.hs +430/−0
- src/Servant/Reflex.hs +606/−0
- src/Servant/Reflex/Multi.hs +388/−0
+ LICENSE.md view
@@ -0,0 +1,30 @@+Copyright Greg Hale (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Greg Hale nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ exec/API.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module API where++import Data.Aeson+import Data.Aeson.Types (typeMismatch)+import Data.Text (Text)+import Servant.API++newtype Question = Question { unQuestion :: Text } deriving (Show)++instance ToJSON Question where+ toJSON (Question txt) = object ["question" .= txt]++instance FromJSON Question where+ parseJSON (Object v) = Question <$> v .: "question"+ parseJSON x = typeMismatch "Couldn't find key 'question'" x++newtype Answer = Answer { unAnswer :: Text } deriving (Show)++instance ToJSON Answer where+ toJSON (Answer txt) = object ["answer" .= txt]++instance FromJSON Answer where+ parseJSON (Object v) = Answer <$> v .: "answer"+ parseJSON x = typeMismatch "Couldn't find key 'answer'" x+++-- | API spec for server, client, and docs+type API = "getunit" :> Get '[JSON] ()+ :<|> "getint" :> Get '[JSON] Int+ :<|> "sayhi" :> QueryParam "username" Text+ :> QueryParams "greetings" Text+ :> QueryFlag "gusto"+ :> Get '[JSON] Text+ :<|> "double" :> ReqBody '[JSON] Double+ :> Post '[JSON] Double+ :<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text+ :<|> "qna" :> ReqBody '[JSON] Question+ :> Post '[JSON] Answer+ :<|> "secret" :> BasicAuth "realm" () :> Get '[JSON] Int+ :<|> Raw++type GET = Get '[JSON] ()++-- Imported the comprehensive API example for testing.+-- https://github.com/haskell-servant/servant/blob/master/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs+type ComprehensiveAPI =+ GET :<|>+ Get '[JSON] Int :<|>+ Capture "foo" Int :> GET :<|>+ Header "foo" Int :> GET :<|>+ HttpVersion :> GET :<|>+ IsSecure :> GET :<|>+ QueryParam "foo" Int :> GET :<|>+ QueryParams "foo" Int :> GET :<|>+ QueryFlag "foo" :> GET :<|>+-- Raw :<|>+ RemoteHost :> GET :<|>+ ReqBody '[JSON] Int :> GET :<|>+ Get '[JSON] (Headers '[Header "foo" Int] ()) :<|>+ "foo" :> GET :<|>+ Vault :> GET :<|>+ Verb 'POST 204 '[JSON] () :<|>+ Verb 'POST 204 '[JSON] Int+-- This one isn't in scope+-- :<|> WithNamedContext "foo" '[] GET
+ exec/Example.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++------------------------------------------------------------------------------+import Data.Bool+import Data.Maybe+import Control.Monad.Fix (MonadFix)+import Data.Monoid (First(..), (<>))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import GHC.TypeLits+import Servant.API+import API+import Data.Proxy+import Text.Read (readMaybe)+import Reflex.Dom hiding (run)+------------------------------------------------------------------------------+import Servant.Reflex+import Servant.Reflex.Multi+++api :: Proxy API+api = Proxy++main :: IO ()+main = mainWidget $ do+ divClass "example-base" run+ divClass "example-multi" runMulti+++runMulti :: forall t m. (SupportsServantReflex t m,+ DomBuilder t m,+ DomBuilderSpace m ~ GhcjsDomSpace,+ MonadFix m,+ PostBuild t m,+ MonadHold t m) => m ()+runMulti = do+ url <- baseUrlWidget+ el "br" blank+ let (_ :<|> _ :<|> sayHi :<|> dbl :<|> _ :<|> _ :<|> _ :<|> _ ) =+ clientA api (Proxy :: Proxy m) (Proxy :: Proxy []) (Proxy :: Proxy Int) url++ num :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def+ num2 :: Dynamic t (Either Text Double) <- fmap (note "No read" . readMaybe . T.unpack) . value <$> textInput def++ b <- button "Run dbl multi"+ reqCount :: Dynamic t Int <- count b+ r <- dbl ((\x y -> [x,y]) <$> num <*> num2) (tag (current reqCount) b)+ dynText =<< holdDyn "Waiting" (T.pack . show . fmap reqSuccess <$> r)++ lastInd <- holdDyn [] $ fmap reqTag <$> r+ display lastInd++ divClass "demo-group" $ do+ nms <- fmap (fmap T.words . value) $ divClass "" $ do+ text "Names"+ textInput def+ grts <- fmap (fmap T.words . value) $ divClass "" $ do+ text "Greetings"+ textInput def+ gust <- fmap (value) $ divClass "gusto-input" $ checkbox False def+ b <- button "Go"+ r' <- sayHi (fmap QParamSome <$> nms) (fmap (:[]) $ grts)+ (constDyn [True, False]) (1 <$ b)++ dynText =<< holdDyn "Waiting" (T.pack . show . catMaybes .+ fmap reqSuccess <$> r')+++ return ()++run :: forall t m. (SupportsServantReflex t m,+ DomBuilder t m,+ DomBuilderSpace m ~ GhcjsDomSpace,+ MonadFix m,+ PostBuild t m,+ MonadHold t m) => m ()+run = mdo++ reqCount <- count $ leftmost+ [() <$ unitBtn, () <$ intBtn, () <$ sayHiClicks, () <$ dblBtn, () <$ mpGo]+ -- Allow user to choose the url target for the request+ -- (alternatively we could just `let url = constDyn (BasePath "/")`)+ url <- baseUrlWidget+ el "br" (return ())+ dynText $ showBaseUrl <$> url++ el "br" (return ())++ -- Name the computed API client functions+ let tweakRequest = ClientOptions $ \r -> do+ return $ r & withCredentials .~ True+ let (getUnit :<|> getInt :<|> sayhi :<|> dbl+ :<|> multi :<|> qna :<|> secret :<|> doRaw) =+ clientWithOpts api (Proxy :: Proxy m) (Proxy :: Proxy Int) url tweakRequest++ c2 = client (Proxy :: Proxy ComprehensiveAPI) (Proxy :: Proxy m) (Proxy :: Proxy ()) url -- Just make sure this compiles for now++ (unitBtn, intBtn) <- elClass "div" "demo-group" $ do+ unitBtn <- divClass "unit-button" $ button "Get unit"+ intBtn <- divClass "int-button" $ button "Get int"++ unitResponse <- getUnit $ tag (current reqCount) unitBtn+ intResponse :: Event t (ReqResult Int Int) <- getInt $ tag (current reqCount) intBtn++ score <- foldDyn (+) 0 (fmapMaybe reqSuccess (intResponse))++ r <- holdDyn "Waiting" $ fmap showXhrResponse $+ leftmost [fmapMaybe response (unitResponse)+ ,fmapMaybe response (intResponse)+ ]+ divClass "unit-int-response" $ el "p" $ dynText r >> el "br" (return ()) >> text "Total: " >> display score+ return (unitBtn, intBtn)++ sayHiClicks <- elClass "div" "demo-group" $ do++ text "Name"+ el "br" $ return ()+ inp :: Dynamic t Text <- fmap value $ divClass "name-input" $ (textInput def)+ let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp+ el "br" $ return ()++ text "Greetings (space-separated)"+ el "br" $ return ()+ greetings <- fmap (fmap T.words . value) $+ divClass "greetings-input" $ (textInput def)++ el "br" $ return ()++ gusto <- fmap value $ divClass "gusto-input" $ checkbox False def++ el "br" $ return ()+ sayHiClicks :: Event t () <- divClass "hi-button" $ button "Say hi"+ let triggers = leftmost [sayHiClicks, () <$ updated inp]++ resp <- sayhi checkedName greetings gusto (tag (current reqCount) triggers)+ divClass "greeting-response" $ dynText =<<+ holdDyn "No hi yet" (leftmost [ fmapMaybe reqSuccess (resp)+ , fmapMaybe reqFailure (resp)])+ return sayHiClicks++ dblBtn <- elClass "div" "demo-group" $ do+ text "A Double to double"+ el "br" $ return ()+ dblinp <- fmap value $ divClass "double-input" $ textInput def+ (dblBtn) <- divClass "double-button" $ button "Double it"+ dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $+ dblinp) (tag (current reqCount) dblBtn)+ divClass "double-errors" $ dynText =<<+ holdDyn "(no errors)" (fmapMaybe reqFailure (dblResp))+ el "br" (return ())+ divClass "double-result" $ el "p" $ dynText =<<+ holdDyn "No number yet" (fmap tShow $+ fmapMaybe reqSuccess (dblResp))+ return dblBtn++ mpGo <- elClass "div" "demo-group" $ do+ text "Multi-part path"+ b <- value <$> checkbox False def+ mpGo <- button "Test"+ multiResp <- multi b (tag (current reqCount) mpGo)+ dynText =<< holdDyn "No res yet" (fmap tShow $+ fmapMaybe reqSuccess $+ (multiResp))+ return mpGo++ return ()++ el "br" $ return ()++ elClass "div" "demo-group" $ do+ text "JSON Unicode encoding test"+ txt <- value <$> textInput def+ ev <- fmap (1 <$) $ button "Question"+ let dQ = Right . Question <$> traceDyn "will send: " txt+ rr <- qna dQ ev+ el "p" $+ dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)++ divClass "demo-group" $ do+ un <- fmap value $ text "Username" >> textArea def+ pw <- fmap value $ text "Unhidden PW" >> textArea def+ let ba :: Dynamic t (BasicAuthData ) = BasicAuthData+ <$> fmap T.encodeUtf8 un+ <*> fmap T.encodeUtf8 pw+ b <- button "Get secret"+ r <- secret (Just <$> ba) (0 <$ b)+ res <- holdDyn Nothing (reqSuccess <$> r)+ display res+++showXhrResponse :: XhrResponse -> Text+showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =+ T.unlines ["stat: " <> tShow stat+ ,"stattxt: " <> tShow stattxt+ ,"resp: " <> maybe "" showRB rbmay+ ,"rtext: " <> tShow rtmay+ ,"rHeaders: " <> tShow respHeaders]++tShow :: Show a => a -> Text+tShow = T.pack . show++showRB :: XhrResponseBody -> Text+showRB (XhrResponseBody_Default t) = tShow t+showRB (XhrResponseBody_Text t) = tShow t+showRB (XhrResponseBody_Blob t) = "<Blob>"+showRB (XhrResponseBody_ArrayBuffer t) = tShow t++note :: e -> Maybe a -> Either e a+note e = maybe (Left e) Right
+ servant-reflex.cabal view
@@ -0,0 +1,61 @@+Name: servant-reflex+Version: 0.3.4+Synopsis: servant API generator for reflex apps+Description: Generate reflex-compatible client functions from servant API descriptions+License: BSD3+License-file: LICENSE.md+Author: Greg Hale, Doug Beardsley+Maintainer: imalsogreg@gmail.com+Stability: Experimental+Category: Web+Build-type: Simple+Cabal-version: >=1.10++Flag Example+ description: Enable example+ default: False++library+ exposed-modules:+ Servant.Common.BaseUrl+ Servant.Common.Req+ Servant.Reflex+ Servant.Reflex.Multi++ hs-source-dirs: src+ build-depends:+ base >= 4.8 && < 5,+ bytestring >= 0.10 && < 0.11,+ case-insensitive >= 1.2.0.4 && < 1.3,+ containers >= 0.5.6 && < 0.6,+ data-default >= 0.5 && < 0.8,+ exceptions >= 0.8 && < 0.11,+ ghcjs-dom >= 0.2 && < 0.10,+ http-api-data >= 0.3.6 && < 0.4,+ http-media >= 0.6 && < 0.8,+ jsaddle >= 0.8 && < 0.10,+ mtl >= 2.2.1 && < 2.3,+ network-uri >= 2.6 && < 2.7,+ reflex >= 0.5 && < 0.6,+ reflex-dom-core == 0.4 && < 0.5,+ safe >= 0.3.9 && < 0.4,+ servant >= 0.8 && < 0.15,+ servant-auth >= 0.2.1 && < 0.4,+ string-conversions >= 0.4 && < 0.5,+ text >= 1.2 && < 1.3,+ transformers >= 0.4 && < 0.6++ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields++ default-language: Haskell2010++executable example+ if flag(Example)+ buildable: True+ else+ buildable: False+ build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text+ default-language: Haskell2010+ main-is: Example.hs+ other-modules: API+ hs-source-dirs: exec
+ src/Servant/Common/BaseUrl.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Servant.Common.BaseUrl (+ -- * types+ BaseUrl (..)+ , Scheme (..)+ -- * functions+ , baseUrlWidget+ , showBaseUrl++ -- * constraints+ , SupportsServantReflex+) where++import Control.Monad (join)+-- import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Fix (MonadFix)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics+import Language.Javascript.JSaddle.Monad (MonadJSM)+import Reflex+import Reflex.Dom.Core+import Text.Read+++type SupportsServantReflex t m = (Reflex t, TriggerEvent t m, PerformEvent t m, HasWebView (Performable m), MonadJSM (Performable m))++-- | URI scheme to use+data Scheme =+ Http -- ^ http://+ | Https -- ^ https://+ deriving (Show, Read, Eq, Ord, Generic)++-- | Simple data type to represent the target of HTTP requests+-- for servant's automatically-generated clients.+data BaseUrl = BaseFullUrl Scheme Text Int Text+ | BasePath Text+ deriving (Ord, Read, Show, Generic)+++instance Eq BaseUrl where+ BasePath s == BasePath s' = s == s'+ BaseFullUrl a b c path == BaseFullUrl a' b' c' path'+ = a == a' && b == b' && c == c' && s path == s path'+ where s x = if T.isPrefixOf "/" x then T.tail x else x+ _ == _ = False++showBaseUrl :: BaseUrl -> Text+showBaseUrl (BasePath s) = s+showBaseUrl (BaseFullUrl urlscheme host port path) =+ schemeString <> "//" <> host <> (portString </> path)+ where+ a </> b = if "/" `T.isPrefixOf` b || T.null b then a <> b else a <> "/" <> b+ schemeString = case urlscheme of+ Http -> "http:"+ Https -> "https:"+ portString = case (urlscheme, port) of+ (Http, 80) -> ""+ (Https, 443) -> ""+ _ -> ":" <> T.pack (show port)++baseUrlWidget :: forall t m .(SupportsServantReflex t m,+ DomBuilderSpace m ~ GhcjsDomSpace,+ MonadFix m,+ PostBuild t m,+ MonadHold t m,+ DomBuilder t m)+ => m (Dynamic t BaseUrl)+baseUrlWidget = elClass "div" "base-url" $ do+ urlWidget <- dropdown (0 :: Int) (constDyn $ 0 =: "BasePath" <> 1 =: "BaseUrlFull") def+ let bUrlWidget = ffor (value urlWidget) $ \i -> case i of+ 0 -> pathWidget+ 1 -> fullUrlWidget+ _ -> error "Surprising value"+ join <$> widgetHold pathWidget (updated bUrlWidget)+ where pathWidget :: m (Dynamic t BaseUrl)+ pathWidget = do+ text "Url base path"+ t <- textInput (def {_textInputConfig_attributes =+ constDyn ("placeholder" =: "/a/b")})+ return $ BasePath <$> value t+ fullUrlWidget :: m (Dynamic t BaseUrl)+ fullUrlWidget = do+ schm <- dropdown Https (constDyn $ Https =: "https" <> Http =: "http") def+ srv <- textInput def {_textInputConfig_attributes = constDyn $ "placeholder" =: "example.com"}+ text ":"+ prt <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "80"}+ port :: Dynamic t Int <- holdDyn 80 (fmapMaybe (readMaybe . T.unpack) $ updated (value prt))+ path <- textInput def { _textInputConfig_attributes = constDyn $ "placeholder" =: "a/b" }+ return $ BaseFullUrl <$> value schm <*> value srv <*> port <*> value path
+ src/Servant/Common/Req.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Servant.Common.Req where++-------------------------------------------------------------------------------+import Control.Applicative (liftA2, liftA3)+import Control.Arrow ((&&&))+import Control.Concurrent+import Control.Monad (join)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Bifunctor (first)+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Map as Map+import Data.Maybe (catMaybes, fromMaybe)+import Data.Functor.Compose+import Data.Monoid ((<>))+import Data.Proxy (Proxy(..))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Traversable (forM)+import Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)+import qualified Network.URI as N+import Reflex.Dom.Core hiding (tag)+import Servant.Common.BaseUrl (BaseUrl, showBaseUrl,+ SupportsServantReflex)+import Servant.API.ContentTypes (MimeUnrender(..), NoContent(..))+import Web.HttpApiData (ToHttpApiData(..))+-------------------------------------------------------------------------------+import Servant.API.BasicAuth+++------------------------------------------------------------------------------+-- | The result of a request event+data ReqResult tag a+ = ResponseSuccess tag a XhrResponse+ -- ^ The succesfully decoded response from a request tagged with 'tag'+ | ResponseFailure tag Text XhrResponse+ -- ^ The failure response, which may have failed decoding or had+ -- a non-successful response code+ | RequestFailure tag Text+ -- ^ A failure to construct the request tagged with 'tag' at trigger time+ deriving (Functor)++data ClientOptions = ClientOptions+ { optsRequestFixup :: forall a. Show a => XhrRequest a -> JSM (XhrRequest a)+ -- ^ Aribtrarily modify requests just before they are sent.+ -- Warning: This escape hatch opens the possibility for your+ -- requests to diverge from what the server expects, when the+ -- server is also derived from a servant API+ }++defaultClientOptions :: ClientOptions+defaultClientOptions = ClientOptions { optsRequestFixup = return }++-- withCredentials :: Lens' (XhrRequest a) Bool+withCredentials :: (Show a, Functor f) => (Bool -> f Bool) -> XhrRequest a -> f (XhrRequest a)+withCredentials inj r@(XhrRequest _ _ cfg) =+ let cfg' = (\b -> cfg { _xhrRequestConfig_withCredentials = b}) <$>+ inj (_xhrRequestConfig_withCredentials cfg)+ in (\c' -> r {_xhrRequest_config = c' }) <$> cfg'++------------------------------------------------------------------------------+-- | Simple filter/accessor for successful responses, when you want to+-- ignore the error case. For example:+-- >> goodResponses <- fmapMaybe reqSuccess <$> clientFun triggers+reqSuccess :: ReqResult tag a -> Maybe a+reqSuccess (ResponseSuccess _ x _) = Just x+reqSuccess _ = Nothing+++------------------------------------------------------------------------------+-- | Simple filter/accessor like 'reqSuccess', but keeping the request tag+reqSuccess' :: ReqResult tag a -> Maybe (tag,a)+reqSuccess' (ResponseSuccess tag x _) = Just (tag,x)+reqSuccess' _ = Nothing+++------------------------------------------------------------------------------+-- | Simple filter/accessor for any failure case+reqFailure :: ReqResult tag a -> Maybe Text+reqFailure (ResponseFailure _ s _) = Just s+reqFailure (RequestFailure _ s) = Just s+reqFailure _ = Nothing++------------------------------------------------------------------------------+-- | Simple filter/accessor like 'reqFailure', but keeping the request tag+reqFailure' :: ReqResult tag a -> Maybe (tag,Text)+reqFailure' (ResponseFailure tag s _) = Just (tag,s)+reqFailure' (RequestFailure tag s) = Just (tag,s)+reqFailure' _ = Nothing+++------------------------------------------------------------------------------+-- | Simple filter/accessor for the raw XHR response+response :: ReqResult tag a -> Maybe XhrResponse+response (ResponseSuccess _ _ x) = Just x+response (ResponseFailure _ _ x) = Just x+response _ = Nothing++------------------------------------------------------------------------------+-- | Retrieve response tag+reqTag :: ReqResult tag a -> tag+reqTag (ResponseSuccess tag _ _) = tag+reqTag (ResponseFailure tag _ _) = tag+reqTag (RequestFailure tag _ ) = tag++-------------------------------------------------------------------------------+-- | You must wrap the parameter of a QueryParam endpoint with 'QParam' to+-- indicate whether the parameter is valid and present, validly absent, or+-- invalid+data QParam a = QParamSome a+ -- ^ A valid query parameter+ | QNone+ -- ^ Indication that the parameter is intentionally absent (the request is valid)+ | QParamInvalid Text+ -- ^ Indication that your validation failed (the request isn't valid)+++qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)+qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)+qParamToQueryPart QNone = Right Nothing+qParamToQueryPart (QParamInvalid e) = Left e+++data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))+ | QueryPartParams (Dynamic t [Text])+ | QueryPartFlag (Dynamic t Bool)+++-------------------------------------------------------------------------------+-- The data structure used to build up request information while traversing+-- the shape of a servant API+data Req t = Req+ { reqMethod :: Text+ , reqPathParts :: [Dynamic t (Either Text Text)]+ , qParams :: [(Text, QueryPart t)]+ , reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))+ , headers :: [(Text, Dynamic t (Either Text Text))]+ , respHeaders :: XhrResponseHeaders+ , authData :: Maybe (Dynamic t (Maybe BasicAuthData))+ }++defReq :: Req t+defReq = Req "GET" [] [] Nothing [] def Nothing++prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t+prependToPathParts p req =+ req { reqPathParts = p : reqPathParts req }++addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t+addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }+++reqToReflexRequest+ :: forall t. Reflex t+ => Text+ -> Dynamic t BaseUrl+ -> Req t+ -> Dynamic t (Either Text (XhrRequest XhrPayload))+reqToReflexRequest reqMeth reqHost req =+ let t :: Dynamic t [Either Text Text]+ t = sequence $ reverse $ reqPathParts req++ baseUrl :: Dynamic t (Either Text Text)+ baseUrl = Right . showBaseUrl <$> reqHost++ urlParts :: Dynamic t (Either Text [Text])+ urlParts = fmap sequence t++ urlPath :: Dynamic t (Either Text Text)+ urlPath = (fmap.fmap)+ (T.intercalate "/" . fmap escape)+ urlParts++ queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))+ queryPartString (pName, qp) = case qp of+ QueryPartParam p -> ffor p $ \case+ Left e -> Just (Left e)+ Right (Just a) -> Just (Right $ pName <> "=" <> escape a)+ Right Nothing -> Nothing+ QueryPartParams ps -> ffor ps $ \pStrings ->+ if null pStrings+ then Nothing+ else Just . Right+ . T.intercalate "&"+ $ fmap (\p -> pName <> "=" <> escape p) pStrings+ QueryPartFlag fl -> ffor fl $ \case+ True -> Just $ Right pName+ False -> Nothing+++ queryPartStrings :: [Dynamic t (Maybe (Either Text Text))]+ queryPartStrings = map queryPartString (qParams req)+ queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Dynamic t (Either Text [Text])+ queryString :: Dynamic t (Either Text Text) =+ ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs+ xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q)+ baseUrl urlPath queryString+ where+ (</>) :: Text -> Text -> Text+ x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y+ | otherwise = x <> "/" <> y+++ xhrHeaders :: Dynamic t (Either Text [(Text, Text)])+ xhrHeaders = (fmap sequence . sequence . fmap f . headers) req+ where+ f = \(headerName, dynam) ->+ fmap (fmap (\rightVal -> (headerName, rightVal))) dynam++ mkConfigBody :: Either Text [(Text,Text)]+ -> (Either Text (BL.ByteString, Text))+ -> Either Text (XhrRequestConfig XhrPayload)+ mkConfigBody ehs rb = case (ehs, rb) of+ (_, Left e) -> Left e+ (Left e, _) -> Left e+ (Right hs, Right (bBytes, bCT)) ->+ Right $ XhrRequestConfig+ { _xhrRequestConfig_sendData = bytesToPayload bBytes+ , _xhrRequestConfig_headers =+ Map.insert "Content-Type" bCT (Map.fromList hs)+ , _xhrRequestConfig_user = Nothing+ , _xhrRequestConfig_password = Nothing+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer+ , _xhrRequestConfig_withCredentials = False+ , _xhrRequestConfig_responseHeaders = def+ }++ xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))+ xhrOpts = case reqBody req of+ Nothing -> ffor xhrHeaders $ \case+ Left e -> Left e+ Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs+ , _xhrRequestConfig_user = Nothing+ , _xhrRequestConfig_password = Nothing+ , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer+ , _xhrRequestConfig_sendData = ""+ , _xhrRequestConfig_withCredentials = False+ }+ Just rBody -> liftA2 mkConfigBody xhrHeaders rBody++ mkAuth :: Maybe BasicAuthData -> Either Text (XhrRequestConfig x) -> Either Text (XhrRequestConfig x)+ mkAuth _ (Left e) = Left e+ mkAuth Nothing r = r+ mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config+ { _xhrRequestConfig_user = Just $ TE.decodeUtf8 u+ , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}++ addAuth :: Dynamic t (Either Text (XhrRequestConfig x))+ -> Dynamic t (Either Text (XhrRequestConfig x))+ addAuth xhr = case authData req of+ Nothing -> xhr+ Just auth -> liftA2 mkAuth auth xhr++ xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)++ in xhrReq++-- * performing requests++displayHttpRequest :: Text -> Text+displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"++-- | This function performs the request+performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)+ => Text+ -> Dynamic t (f (Req t))+ -> Dynamic t BaseUrl+ -> ClientOptions+ -> Event t tag+ -> m (Event t (tag, f (Either Text XhrResponse)))+performRequests reqMeth rs reqHost opts trigger = do+ let xhrReqs =+ join $ (\(fxhr :: f (Req t)) -> sequence $+ reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs++ -- xhrReqs = fmap snd <$> xhrReqsAndDebugs+ reqs = attachPromptlyDynWith+ (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger++ resps <- performSomeRequestsAsync opts reqs+ return $ getCompose <$> resps++-- | 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.+performSomeRequestsAsync+ :: (MonadIO (Performable m),+ MonadJSM (Performable m),+ HasWebView (Performable m),+ PerformEvent t m,+ TriggerEvent t m,+ Traversable f,+ IsXhrPayload a,+ Show a+ )+ => ClientOptions+ -> Event t (f (Either Text (XhrRequest a)))+ -> m (Event t (f (Either Text XhrResponse)))+performSomeRequestsAsync opts =+ performSomeRequestsAsync' opts newXMLHttpRequest . fmap return+++------------------------------------------------------------------------------+-- | A modified version or Reflex.Dom.Xhr.performRequestsAsync+-- that accepts 'f (Either e (XhrRequestb))' events+performSomeRequestsAsync'+ :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)+ => ClientOptions+ -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)+ -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))+performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do+ rs <- hrs+ resps <- forM rs $ \r -> case r of+ Left e -> do+ resp <- liftIO $ newMVar (Left e)+ return resp+ Right r' -> do+ resp <- liftIO newEmptyMVar+ r'' <- liftJSM $ (optsRequestFixup opts) r'+ _ <- newXhr r'' $ liftIO . putMVar resp . Right+ return resp+ _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar+ return ()++++type XhrPayload = T.Text+bytesToPayload :: BL.ByteString -> XhrPayload+bytesToPayload = TE.decodeUtf8 . BL.toStrict+++performRequestsCT+ :: (SupportsServantReflex t m,+ MimeUnrender ct a, Traversable f)+ => Proxy ct+ -> Text+ -> Dynamic t (f (Req t))+ -> Dynamic t BaseUrl+ -> ClientOptions+ -> Event t tag+ -> m (Event t (f (ReqResult tag a)))+performRequestsCT ct reqMeth reqs reqHost opts trigger = do+ resps <- performRequests reqMeth reqs reqHost opts trigger+ let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =+ first T.pack .+ mimeUnrender ct $+ BL.fromStrict x+ decodeResp _ = Left "No body"+ return $ fmap+ (\(t,rs) -> ffor rs $ \r -> case r of+ Left e -> RequestFailure t e+ Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)+ )+ resps+++performRequestsNoBody+ :: (SupportsServantReflex t m,+ Traversable f)+ => Text+ -> Dynamic t (f (Req t))+ -> Dynamic t BaseUrl+ -> ClientOptions+ -> Event t tag+ -> m (Event t (f (ReqResult tag NoContent)))+performRequestsNoBody reqMeth reqs reqHost opts trigger = do+ resps <- performRequests reqMeth reqs reqHost opts trigger+ let decodeResp = const $ Right NoContent+ return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of+ Left e -> RequestFailure tag e+ Right g -> evalResponse decodeResp (tag,g)+++------------------------------------------------------------------------------+evalResponse+ :: (XhrResponse -> Either Text a)+ -> (tag, XhrResponse)+ -> ReqResult tag a+evalResponse decode (tag, xhr) =+ let status = _xhrResponse_status xhr+ okStatus = status >= 200 && status < 400+ errMsg = fromMaybe+ ("Empty response with error code " <>+ T.pack (show $ _xhrResponse_status xhr))+ (_xhrResponse_responseText xhr)+ respPayld = if okStatus+ then either+ (\e -> ResponseFailure tag e xhr)+ (\v -> ResponseSuccess tag v xhr)+ (decode xhr)+ else ResponseFailure tag errMsg xhr+ in respPayld++------------------------------------------------------------------------------+-- | Utility for simultaneously accessing/filtering Success and Failure+-- response 'Event's,+fanReqResult :: Reflex t => Event t (ReqResult tag a) -> (Event t Text, Event t a)+fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess++------------------------------------------------------------------------------+-- | Utility for simultaneously accessing/filtering Success and Failure+-- response 'Event's, but keeping the request tag+fanReqResult' :: Reflex t => Event t (ReqResult tag a) -> (Event t (tag, Text), Event t (tag, a))+fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'+++note :: e -> Maybe a -> Either e a+note e = maybe (Left e) Right++fmapL :: (e -> e') -> Either e a -> Either e' a+fmapL _ (Right a) = Right a+fmapL f (Left e) = Left (f e)++builderToText :: Builder.Builder -> T.Text+builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString++escape :: T.Text -> T.Text+escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece+
+ src/Servant/Reflex.hs view
@@ -0,0 +1,606 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++#if MIN_VERSION_base(4,9,0)+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}+#endif++-- #include "overlapping-compat.h"+-- | This module provides 'client' which can automatically generate+-- querying functions for each endpoint just from the type representing your+-- API.+module Servant.Reflex+ ( client+ , clientWithOpts+ , clientWithOptsAndResultHandler+ , clientWithRoute+ , clientWithRouteAndResultHandler+ , BuildHeaderKeysTo(..)+ , toHeaders+ , HasClient+ , Client+ , module Servant.Common.Req+ , module Servant.Common.BaseUrl+ ) where++------------------------------------------------------------------------------+import Control.Applicative+import Data.Monoid ((<>))+import qualified Data.Set as Set+import qualified Data.Text.Encoding as E+import Data.CaseInsensitive (mk)+import Data.Functor.Identity+import Data.Proxy (Proxy (..))+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Exts (Constraint)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Servant.API ((:<|>)(..),(:>), BasicAuth,+ BasicAuthData, BuildHeadersTo(..),+ Capture, contentType, Header,+ Headers(..), HttpVersion, IsSecure,+ MimeRender(..), MimeUnrender,+ NoContent, QueryFlag, QueryParam,+ QueryParams, Raw, ReflectMethod(..),+ RemoteHost, ReqBody,+ ToHttpApiData(..), Vault, Verb)+import qualified Servant.Auth as Auth++import Reflex.Dom.Core (Dynamic, Event, Reflex,+ XhrRequest(..),+ XhrResponseHeaders(..),+ XhrResponse(..), attachPromptlyDynWith, constDyn, ffor, fmapMaybe,+ leftmost, performRequestsAsync,+ )+------------------------------------------------------------------------------+import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,+ showBaseUrl,+ SupportsServantReflex)+import Servant.Common.Req (ClientOptions(..),+ defaultClientOptions,+ Req, ReqResult(..), QParam(..),+ QueryPart(..), addHeader, authData,+ defReq, evalResponse, prependToPathParts,+ -- performRequestCT,+ performRequestsCT,+ -- performRequestNoBody,+ performRequestsNoBody,+ performSomeRequestsAsync,+ qParamToQueryPart, reqBody,+ reqSuccess, reqFailure,+ reqMethod, respHeaders,+ response,+ reqTag,+ qParams, withCredentials)+++-- * Accessing APIs as a Client++-- | 'client' allows you to produce operations to query an API from a client.+--+-- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books+-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books+-- >+-- > myApi :: Proxy MyApi+-- > myApi = Proxy+-- >+-- > getAllBooks :: Event t l -> m (Event t (l, ReqResult [Book]))+-- > postNewBook :: Dynamic t (Maybe Book) -> Event t l+-- -> m (Event t (l, ReqResult Book)))+-- > (getAllBooks :<|> postNewBook) = client myApi host+-- > where host = constDyn $ BaseUrl Http "localhost" 8080+client+ :: (HasClient t m layout tag)+ => Proxy layout+ -> Proxy m+ -> Proxy tag+ -> Dynamic t BaseUrl+ -> Client t m layout tag+client p q t baseurl = clientWithRoute p q t defReq baseurl defaultClientOptions++clientWithOpts+ :: (HasClient t m layout tag)+ => Proxy layout+ -> Proxy m+ -> Proxy tag+ -> Dynamic t BaseUrl+ -> ClientOptions+ -> Client t m layout tag+clientWithOpts p q t baseurl = clientWithRoute p q t defReq baseurl++-- | Like 'clientWithOpts' but allows passing a function which will process the+-- result event in some way. This can be used to handle errors in a uniform way+-- across call sites.+clientWithOptsAndResultHandler+ :: (HasClient t m layout tag)+ => Proxy layout+ -> Proxy m+ -> Proxy tag+ -> Dynamic t BaseUrl+ -> ClientOptions+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))+ -> Client t m layout tag+clientWithOptsAndResultHandler p q t = clientWithRouteAndResultHandler p q t defReq+++-- | This class lets us define how each API combinator+-- influences the creation of an HTTP request. It's mostly+-- an internal class, you can just use 'client'.+class Monad m => HasClient t m layout (tag :: *) where+ type Client t m layout tag :: *+ clientWithRoute+ :: Proxy layout+ -> Proxy m+ -> Proxy tag+ -> Req t+ -> Dynamic t BaseUrl+ -> ClientOptions+ -> Client t m layout tag+ clientWithRoute l m t r b o = clientWithRouteAndResultHandler l m t r b o return++ clientWithRouteAndResultHandler+ :: Proxy layout+ -> Proxy m+ -> Proxy tag+ -> Req t+ -> Dynamic t BaseUrl+ -> ClientOptions+ -> (forall a. Event t (ReqResult tag a) -> m (Event t (ReqResult tag a)))+ -> Client t m layout tag+++instance (HasClient t m a tag, HasClient t m b tag) => HasClient t m (a :<|> b) tag where+ type Client t m (a :<|> b) tag = Client t m a tag :<|> Client t m b tag++ clientWithRouteAndResultHandler Proxy q pTag req baseurl opts wrap =+ clientWithRouteAndResultHandler (Proxy :: Proxy a) q pTag req baseurl opts wrap :<|>+ clientWithRouteAndResultHandler (Proxy :: Proxy b) q pTag req baseurl opts wrap+++-- Capture. Example:+-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book+-- >+-- > myApi :: Proxy MyApi = Proxy+-- >+-- > getBook :: SupportsServantReflex t m+-- => Dynamic t BaseUrl+-- -> Dynamic t (Maybe Text)+-- -> Event t l+-- -> m (Event t (l, ReqResult Book))+-- > getBook = client myApi (constDyn host)++instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout tag)+ => HasClient t m (Capture capture a :> sublayout) tag where++ type Client t m (Capture capture a :> sublayout) tag =+ Dynamic t (Either Text a) -> Client t m sublayout tag++ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap val =+ clientWithRouteAndResultHandler+ (Proxy :: Proxy sublayout) q t (prependToPathParts p req) baseurl opts wrap+ where p = (fmap . fmap) (toUrlPiece) val+++-- VERB (Returning content) --+instance {-# OVERLAPPABLE #-}+ -- Note [Non-Empty Content Types]+ (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), SupportsServantReflex t m+ ) => HasClient t m (Verb method status cts' a) tag where+ type Client t m (Verb method status cts' a) tag =+ Event t tag -> m (Event t (ReqResult tag a))+ -- TODO how to access input types here?+ -- ExceptT ServantError IO a+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =+ wrap =<< fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity $ req') baseurl opts trigs+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)+ req' = req { reqMethod = method }+++-- -- VERB (No content) --+instance {-# OVERLAPPING #-}+ (ReflectMethod method, SupportsServantReflex t m) =>+ HasClient t m (Verb method status cts NoContent) tag where+ type Client t m (Verb method status cts NoContent) tag =+ Event t tag -> m (Event t (ReqResult tag NoContent))+ -- TODO: how to access input types here?+ -- ExceptT ServantError IO NoContent+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs =+ wrap =<< fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req) baseurl opts trigs+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)+++toHeaders :: BuildHeadersTo ls => ReqResult tag a -> ReqResult tag (Headers ls a)+toHeaders r =+ let toBS = E.encodeUtf8+ hdrs = maybe []+ (\xhr -> fmap (\(h,v) -> (mk (toBS h), toBS v))+ (Map.toList $ _xhrResponse_headers xhr))+ (response r)+ in ffor r $ \a -> Headers {getResponse = a ,getHeadersHList = buildHeadersTo hdrs}++class BuildHeaderKeysTo hs where+ buildHeaderKeysTo :: Proxy hs -> [T.Text]++instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]+ where buildHeaderKeysTo _ = []++instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)+ => BuildHeaderKeysTo ((Header h v) ': xs) where+ buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)++-- HEADERS Verb (Content) --+-- Headers combinator not treated in fully general case,+-- in order to deny instances for (Headers ls (Capture "id" Int)),+-- a combinator that wouldn't make sense+-- TODO Overlapping??+instance {-# OVERLAPPABLE #-}+ -- Note [Non-Empty Content Types]+ ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,+ ReflectMethod method, cts' ~ (ct ': cts),+ SupportsServantReflex t m+ ) => HasClient t m (Verb method status cts' (Headers ls a)) tag where+ type Client t m (Verb method status cts' (Headers ls a)) tag =+ Event t tag -> m (Event t (ReqResult tag (Headers ls a)))+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)+ resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs+ wrap $ toHeaders <$> resp+ where req' = req { respHeaders =+ OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))+ }+++-- HEADERS Verb (No content) --+instance {-# OVERLAPPABLE #-}+ ( BuildHeadersTo ls, BuildHeaderKeysTo ls, ReflectMethod method,+ SupportsServantReflex t m+ ) => HasClient t m (Verb method status cts (Headers ls NoContent)) tag where+ type Client t m (Verb method status cts (Headers ls NoContent)) tag+ = Event t tag -> m (Event t (ReqResult tag (Headers ls NoContent)))+ clientWithRouteAndResultHandler Proxy _ _ req baseurl opts wrap trigs = do+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)+ resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs+ wrap $ toHeaders <$> resp+ where req' = req {respHeaders =+ OnlyHeaders (Set.fromList (buildHeaderKeysTo (Proxy :: Proxy ls)))+ }++++-- HEADER+-- > newtype Referer = Referer { referrer :: Text }+-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData)+-- >+-- > -- GET /view-my-referer+-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer+-- >+-- >+-- > viewReferer :: Maybe Referer -> ExceptT String IO Book+-- > viewReferer = client myApi host+-- > where host = BaseUrl Http "localhost" 8080+-- > -- then you can just use "viewRefer" to query that endpoint+-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments+instance (KnownSymbol sym, ToHttpApiData a,+ HasClient t m sublayout tag, SupportsServantReflex t m)+ => HasClient t m (Header sym a :> sublayout) tag where++ type Client t m (Header sym a :> sublayout) tag =+ Dynamic t (Either Text a) -> Client t m sublayout tag++ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap eVal =+ clientWithRouteAndResultHandler+ (Proxy :: Proxy sublayout) q t+ (Servant.Common.Req.addHeader hname eVal req)+ baseurl opts wrap+ where hname = T.pack $ symbolVal (Proxy :: Proxy sym)+++++-- | Using a 'HttpVersion' combinator in your API doesn't affect the client+-- functions.+instance HasClient t m sublayout tag+ => HasClient t m (HttpVersion :> sublayout) tag where++ type Client t m (HttpVersion :> sublayout) tag =+ Client t m sublayout tag++ clientWithRouteAndResultHandler Proxy =+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout)+++-- | If you use a 'QueryParam' in one of your endpoints in your API,+-- the corresponding querying function will automatically take+-- an additional argument of the type specified by your 'QueryParam',+-- enclosed in Maybe.+--+-- If you give Nothing, nothing will be added to the query string.+--+-- If you give a non-'Nothing' value, this function will take care+-- of inserting a textual representation of this value in the query string.+--+-- You can control how values for your type are turned into+-- text by specifying a 'ToHttpApiData' instance for your type.+--+-- Example:+--+-- > type MyApi = "books" :> QueryParam "author" Text :> Get '[JSON] [Book]+-- >+-- > myApi :: Proxy MyApi+-- > myApi = Proxy+-- >+-- > getBooksBy :: Maybe Text -> ExceptT String IO [Book]+-- > getBooksBy = client myApi host+-- > where host = BaseUrl Http "localhost" 8080+-- > -- then you can just use "getBooksBy" to query that endpoint.+-- > -- 'getBooksBy Nothing' for all books+-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)+ => HasClient t m (QueryParam sym a :> sublayout) tag where++ type Client t m (QueryParam sym a :> sublayout) tag =+ Dynamic t (QParam a) -> Client t m sublayout tag++ -- if mparam = Nothing, we don't add it to the query string+ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap mparam =+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t+ (req {qParams = paramPair : qParams req}) baseurl opts wrap++ where pname = symbolVal (Proxy :: Proxy sym)+ --p prm = QueryPartParam $ (fmap . fmap) (toQueryParam) prm+ --paramPair = (T.pack pname, p mparam)+ p prm = QueryPartParam $ fmap qParamToQueryPart prm -- (fmap . fmap) (unpack . toQueryParam) prm+ paramPair = (T.pack pname, p mparam)++++-- | If you use a 'QueryParams' in one of your endpoints in your API,+-- the corresponding querying function will automatically take+-- an additional argument, a list of values of the type specified+-- by your 'QueryParams'.+--+-- If you give an empty list, nothing will be added to the query string.+--+-- Otherwise, this function will take care+-- of inserting a textual representation of your values in the query string,+-- under the same query string parameter name.+--+-- You can control how values for your type are turned into+-- text by specifying a 'ToHttpApiData' instance for your type.+--+-- Example:+--+-- > type MyApi = "books" :> QueryParams "authors" Text :> Get '[JSON] [Book]+-- >+-- > myApi :: Proxy MyApi+-- > myApi = Proxy+-- >+-- > getBooksBy :: [Text] -> ExceptT String IO [Book]+-- > getBooksBy = client myApi host+-- > where host = BaseUrl Http "localhost" 8080+-- > -- then you can just use "getBooksBy" to query that endpoint.+-- > -- 'getBooksBy []' for all books+-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'+-- > -- to get all books by Asimov and Heinlein+instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout tag, Reflex t)+ => HasClient t m (QueryParams sym a :> sublayout) tag where++ type Client t m (QueryParams sym a :> sublayout) tag =+ Dynamic t [a] -> Client t m sublayout tag++ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap paramlist =+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap++ where req' = req { qParams = (T.pack pname, params') : qParams req }+ pname = symbolVal (Proxy :: Proxy sym)+ params' = QueryPartParams $ (fmap . fmap) toQueryParam+ paramlist++++-- | If you use a 'QueryFlag' in one of your endpoints in your API,+-- the corresponding querying function will automatically take+-- an additional 'Bool' argument.+--+-- If you give 'False', nothing will be added to the query string.+--+-- Otherwise, this function will insert a value-less query string+-- parameter under the name associated to your 'QueryFlag'.+--+-- Example:+--+-- > type MyApi = "books" :> QueryFlag "published" :> Get '[JSON] [Book]+-- >+-- > myApi :: Proxy MyApi+-- > myApi = Proxy+-- >+-- > getBooks :: Bool -> ExceptT String IO [Book]+-- > getBooks = client myApi host+-- > where host = BaseUrl Http "localhost" 8080+-- > -- then you can just use "getBooks" to query that endpoint.+-- > -- 'getBooksBy False' for all books+-- > -- 'getBooksBy True' to only get _already published_ books++-- TODO Bring back+instance (KnownSymbol sym, HasClient t m sublayout tag, Reflex t)+ => HasClient t m (QueryFlag sym :> sublayout) tag where++ type Client t m (QueryFlag sym :> sublayout) tag =+ Dynamic t Bool -> Client t m sublayout tag++ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap flag =+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap++ where req' = req { qParams = thisPair : qParams req }+ thisPair = (T.pack pName, QueryPartFlag flag) :: (Text, QueryPart t)+ pName = symbolVal (Proxy :: Proxy sym)++++-- | Send a raw 'XhrRequest ()' directly to 'baseurl'+instance SupportsServantReflex t m => HasClient t m Raw tag where+ type Client t m Raw tag = Dynamic t (Either Text (XhrRequest ()))+ -> Event t tag+ -> m (Event t (ReqResult tag ()))++ clientWithRouteAndResultHandler _ _ _ _ baseurl _ wrap xhrs triggers = do++ let xhrs' = liftA2 (\x path -> case x of+ Left e -> Left e+ Right jx -> Right $ jx { _xhrRequest_url = path <> _xhrRequest_url jx }+ ) xhrs (showBaseUrl <$> baseurl)+ xhrs'' = attachPromptlyDynWith (flip (,)) xhrs' triggers :: Event t (tag, Either Text (XhrRequest ()))+ badReq = fmapMaybe (\(t,x) -> either (Just . (t,)) (const Nothing) x) xhrs'' :: Event t (tag, Text)+ okReq = fmapMaybe (\(t,x) -> either (const Nothing) (Just . (t,)) x) xhrs'' :: Event t (tag, XhrRequest ())++ resps <- performRequestsAsync okReq+ wrap $ leftmost [ uncurry RequestFailure <$> badReq+ , evalResponse (const $ Right ()) <$> resps+ ]+++-- | If you use a 'ReqBody' in one of your endpoints in your API,+-- the corresponding querying function will automatically take+-- an additional argument of the type specified by your 'ReqBody'.+-- That function will take care of encoding this argument as JSON and+-- of using it as the request body.+--+-- All you need is for your type to have a 'ToJSON' instance.+--+-- Example:+--+-- > type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book+-- >+-- > myApi :: Proxy MyApi+-- > myApi = Proxy+-- >+-- > addBook :: Book -> ExceptT String IO Book+-- > addBook = client myApi host+-- > where host = BaseUrl Http "localhost" 8080+-- > -- then you can just use "addBook" to query that endpoint++instance (MimeRender ct a, HasClient t m sublayout tag, Reflex t)+ => HasClient t m (ReqBody (ct ': cts) a :> sublayout) tag where++ type Client t m (ReqBody (ct ': cts) a :> sublayout) tag =+ Dynamic t (Either Text a) -> Client t m sublayout tag++ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap body =+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t req' baseurl opts wrap+ where req' = req { reqBody = bodyBytesCT }+ ctProxy = Proxy :: Proxy ct+ ctString = T.pack $ show $ contentType ctProxy+ bodyBytesCT = Just $ (fmap . fmap)+ (\b -> (mimeRender ctProxy b, ctString))+ body++++-- | Make the querying function append @path@ to the request path.+instance (KnownSymbol path, HasClient t m sublayout tag, Reflex t) => HasClient t m (path :> sublayout) tag where+ type Client t m (path :> sublayout) tag = Client t m sublayout tag++ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap =+ clientWithRouteAndResultHandler (Proxy :: Proxy sublayout) q t+ (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts wrap++ where p = symbolVal (Proxy :: Proxy path)+++instance HasClient t m api tag => HasClient t m (Vault :> api) tag where+ type Client t m (Vault :> api) tag = Client t m api tag++ clientWithRouteAndResultHandler Proxy =+ clientWithRouteAndResultHandler (Proxy :: Proxy api)+++instance HasClient t m api tag => HasClient t m (RemoteHost :> api) tag where+ type Client t m (RemoteHost :> api) tag = Client t m api tag++ clientWithRouteAndResultHandler Proxy =+ clientWithRouteAndResultHandler (Proxy :: Proxy api)++++instance HasClient t m api tag => HasClient t m (IsSecure :> api) tag where+ type Client t m (IsSecure :> api) tag = Client t m api tag++ clientWithRouteAndResultHandler Proxy =+ clientWithRouteAndResultHandler (Proxy :: Proxy api)+++instance (HasClient t m api tag, Reflex t)+ => HasClient t m (BasicAuth realm usr :> api) tag where++ type Client t m (BasicAuth realm usr :> api) tag = Dynamic t (Maybe BasicAuthData)+ -> Client t m api tag++ clientWithRouteAndResultHandler Proxy q t req baseurl opts wrap authdata =+ clientWithRouteAndResultHandler (Proxy :: Proxy api) q t req' baseurl opts wrap+ where+ req' = req { authData = Just authdata }++-- instance HasClient t m subapi =>+-- HasClient t m (WithNamedConfig name config subapi) where++-- type Client t m (WithNamedConfig name config subapi) = Client t m subapi+-- clientWithRoute Proxy q = clientWithRoute (Proxy :: Proxy subapi) q+++{- Note [Non-Empty Content Types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Rather than have++ instance (..., cts' ~ (ct ': cts)) => ... cts' ...++It may seem to make more sense to have:++ instance (...) => ... (ct ': cts) ...++But this means that if another instance exists that does *not* require+non-empty lists, but is otherwise more specific, no instance will be overall+more specific. This in turn generally means adding yet another instance (one+for empty and one for non-empty lists).+-}+++-- SUPPORT FOR servant-auth --++-- For JavaScript clients we should be sending/storing JSON web tokens in a+-- way that is inaccessible to JavaScript.+--+-- For @servant-auth@ this is done with HTTP-only cookies. In a Reflex-DOM+-- app this means the @servant-auth@ client should only verify that the API+-- supports Cookie-based authentication but do nothing with the token+-- directly.++-- @HasCookieAuth auths@ is nominally a redundant constraint, but ensures+-- we're not trying to rely on cookies when the API does not use them.+instance (HasCookieAuth auths, HasClient t m api tag) => HasClient t m (Auth.Auth auths a :> api) tag where++ type Client t m (Auth.Auth auths a :> api) tag = Client t m api tag+ clientWithRouteAndResultHandler Proxy = clientWithRouteAndResultHandler (Proxy :: Proxy api)+++type family HasCookieAuth xs :: Constraint where+ HasCookieAuth (Auth.Cookie ': xs) = ()+ HasCookieAuth (x ': xs) = HasCookieAuth xs+ HasCookieAuth '[] = CookieAuthNotEnabled++class CookieAuthNotEnabled+
+ src/Servant/Reflex/Multi.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Servant.Reflex.Multi (+ -- * Compute servant client functions+ clientA+ , clientWithOptsA+ , BaseUrl(..)+ , Scheme(..)++ -- * Build QueryParam arguments+ , QParam(..)++ -- * Access response data+ , withCredentials++ -- * Access response data+ , ReqResult(..)+ , reqSuccess+ , reqSuccess'+ , reqFailure+ , response++ , HasClientMulti(..)+ ) where++------------------------------------------------------------------------------+import Control.Applicative (liftA2)+import Data.Functor.Compose (Compose (..), getCompose)+import Data.Proxy (Proxy (..))+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import GHC.TypeLits (KnownSymbol, symbolVal)+import Servant.API ((:<|>) (..), (:>), BasicAuth,+ BasicAuthData, BuildHeadersTo (..),+ Capture, Header, Headers (..),+ HttpVersion, IsSecure, MimeRender (..),+ MimeUnrender, NoContent, QueryFlag,+ QueryParam, QueryParams, Raw,+ ReflectMethod (..), RemoteHost,+ ReqBody, ToHttpApiData (..), Vault,+ Verb, contentType)++import Reflex.Dom.Core (Dynamic, Event, Reflex,+ XhrRequest (..),+ XhrResponseHeaders (..),+ attachPromptlyDynWith, constDyn)+------------------------------------------------------------------------------+import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),+ SupportsServantReflex)+import Servant.Common.Req (ClientOptions,+ QParam (..), QueryPart (..), Req,+ ReqResult (..), addHeader, authData,+ defReq,+ defaultClientOptions,+ performRequestsCT,+ performRequestsNoBody,+ performSomeRequestsAsync,+ prependToPathParts, qParamToQueryPart,+ qParams, reqBody, reqFailure,+ reqMethod, reqSuccess, reqSuccess',+ respHeaders, response, withCredentials)+import Servant.Reflex (BuildHeaderKeysTo (..), toHeaders)+++------------------------------------------------------------------------------+clientA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)+ => Proxy layout -> Proxy m -> Proxy f -> Proxy tag+ -> Dynamic t BaseUrl -> ClientMulti t m layout f tag+clientA p q f tag baseurl =+ clientWithRouteMulti p q f tag (constDyn (pure defReq)) baseurl+ defaultClientOptions+++-- | A version of @client@ that sets the withCredentials flag+-- on requests. Use this function for clients of CORS API's+clientWithOptsA :: (HasClientMulti t m layout f tag, Applicative f, Reflex t)+ => Proxy layout -> Proxy m -> Proxy f -> Proxy tag+ -> Dynamic t BaseUrl -> ClientOptions -> ClientMulti t m layout f tag+clientWithOptsA p q f tag baseurl opts =+ clientWithRouteMulti p q f tag+ (constDyn (pure defReq)) baseurl opts++------------------------------------------------------------------------------+class HasClientMulti t m layout f (tag :: *) where+ type ClientMulti t m layout f tag :: *+ clientWithRouteMulti :: Proxy layout -> Proxy m -> Proxy f -> Proxy tag+ -> Dynamic t (f (Req t)) -> Dynamic t BaseUrl+ -> ClientOptions -> ClientMulti t m layout f tag+++------------------------------------------------------------------------------+instance (HasClientMulti t m a f tag, HasClientMulti t m b f tag) =>+ HasClientMulti t m (a :<|> b) f tag where+ type ClientMulti t m (a :<|> b) f tag = ClientMulti t m a f tag :<|>+ ClientMulti t m b f tag+ clientWithRouteMulti Proxy q f tag reqs baseurl opts =+ clientWithRouteMulti (Proxy :: Proxy a) q f tag reqs baseurl opts :<|>+ clientWithRouteMulti (Proxy :: Proxy b) q f tag reqs baseurl opts+++------------------------------------------------------------------------------+instance (SupportsServantReflex t m,+ ToHttpApiData a,+ HasClientMulti t m sublayout f tag,+ Applicative f)+ => HasClientMulti t m (Capture capture a :> sublayout) f tag where++ type ClientMulti t m (Capture capture a :> sublayout) f tag =+ f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag++ clientWithRouteMulti _ q f tag reqs baseurl opts vals =+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts+ where+ reqs' = (prependToPathParts <$> ps <*>) <$> reqs+ ps = (fmap . fmap . fmap) toUrlPiece vals+++------------------------------------------------------------------------------+-- VERB (Returning content) --+instance {-# OVERLAPPABLE #-}+ -- Note [Non-Empty Content Types]+ (MimeUnrender ct a,+ ReflectMethod method, cts' ~ (ct ': cts),+ SupportsServantReflex t m,+ Applicative f,+ Traversable f+ ) => HasClientMulti t m (Verb method status cts' a) f tag where++ type ClientMulti t m (Verb method status cts' a) f tag =+ Event t tag -> m (Event t (f (ReqResult tag a)))++ clientWithRouteMulti _ _ _ _ reqs baseurl opts =+ performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)+ reqs' = fmap (\r -> r { reqMethod = method }) <$> reqs+++------------------------------------------------------------------------------+-- -- VERB (No content) --+instance {-# OVERLAPPING #-}+ (ReflectMethod method, SupportsServantReflex t m, Traversable f) =>+ HasClientMulti t m (Verb method status cts NoContent) f tag where+ type ClientMulti t m (Verb method status cts NoContent) f tag =+ Event t tag -> m (Event t (f (ReqResult tag NoContent)))+ -- TODO: how to access input types here?+ -- ExceptT ServantError IO NoContent+ clientWithRouteMulti Proxy _ _ _ req baseurl opts =+ performRequestsNoBody method req baseurl opts+ where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)+++------------------------------------------------------------------------------+instance {-# OVERLAPPABLE #-}+ -- Note [Non-Empty Content Types]+ ( MimeUnrender ct a, BuildHeadersTo ls, BuildHeaderKeysTo ls,+ ReflectMethod method, cts' ~ (ct ': cts),+ SupportsServantReflex t m,+ Traversable f+ ) => HasClientMulti t m (Verb method status cts' (Headers ls a)) f tag where+ type ClientMulti t m (Verb method status cts' (Headers ls a)) f tag =+ Event t tag -> m (Event t (f (ReqResult tag (Headers ls a))))+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)+ resp <- performRequestsCT (Proxy :: Proxy ct) method reqs' baseurl opts triggers :: m (Event t (f (ReqResult tag a)))+ return $ fmap toHeaders <$> resp+ where+ reqs' = fmap (\r ->+ r { respHeaders =+ OnlyHeaders (Set.fromList+ (buildHeaderKeysTo (Proxy :: Proxy ls)))+ }) <$> reqs+++------------------------------------------------------------------------------+instance {-# OVERLAPPABLE #-}+ ( BuildHeadersTo ls,+ BuildHeaderKeysTo ls,+ ReflectMethod method,+ SupportsServantReflex t m,+ Traversable f+ ) => HasClientMulti t m (Verb method status+ cts (Headers ls NoContent)) f tag where+ type ClientMulti t m (Verb method status cts (Headers ls NoContent)) f tag+ = Event t tag -> m (Event t (f (ReqResult tag (Headers ls NoContent))))+ clientWithRouteMulti Proxy _ _ _ reqs baseurl opts triggers = do+ let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)+ resp <- performRequestsNoBody method reqs' baseurl opts triggers+ return $ fmap toHeaders <$> resp+ where reqs' = fmap (\req ->+ req {respHeaders = OnlyHeaders (Set.fromList+ (buildHeaderKeysTo (Proxy :: Proxy ls)))+ }) <$> reqs+++------------------------------------------------------------------------------+instance (KnownSymbol sym,+ ToHttpApiData a,+ HasClientMulti t m sublayout f tag,+ SupportsServantReflex t m,+ Traversable f,+ Applicative f)+ => HasClientMulti t m (Header sym a :> sublayout) f tag where++ type ClientMulti t m (Header sym a :> sublayout) f tag =+ f (Dynamic t (Either Text a)) -> ClientMulti t m sublayout f tag++ clientWithRouteMulti Proxy f q tag reqs baseurl opts eVals =+ clientWithRouteMulti (Proxy :: Proxy sublayout) f+ q tag+ reqs'+ baseurl opts+ where hname = T.pack $ symbolVal (Proxy :: Proxy sym)+ reqs' = ((\eVal req -> Servant.Common.Req.addHeader hname eVal req)+ <$> eVals <*>) <$> reqs+++------------------------------------------------------------------------------+instance HasClientMulti t m sublayout f tag+ => HasClientMulti t m (HttpVersion :> sublayout) f tag where++ type ClientMulti t m (HttpVersion :> sublayout) f tag =+ ClientMulti t m sublayout f tag++ clientWithRouteMulti Proxy q f tag =+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag+++------------------------------------------------------------------------------+instance (KnownSymbol sym,+ ToHttpApiData a,+ HasClientMulti t m sublayout f tag,+ Reflex t,+ Applicative f)+ => HasClientMulti t m (QueryParam sym a :> sublayout) f tag where++ type ClientMulti t m (QueryParam sym a :> sublayout) f tag =+ Dynamic t (f (QParam a)) -> ClientMulti t m sublayout f tag++ -- if mparam = Nothing, we don't add it to the query string+ -- TODO: Check the above comment+ clientWithRouteMulti Proxy q f tag reqs baseurl opts mparams =+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag+ reqs' baseurl opts++ where pname = symbolVal (Proxy :: Proxy sym)+ p prm = QueryPartParam $ fmap qParamToQueryPart prm+ paramPair mp = (T.pack pname, p mp)+ -- reqs' = (\params reqs -> (\req param -> req {qParams = paramPair param : qParams req}) <$> reqs <*> params)+ -- <$> mparams <*> reqs+ reqs' = liftA2 (\(pr :: QParam a) (r :: Req t) -> r { qParams = paramPair (constDyn pr) : qParams r })+ <$> mparams <*> reqs+++instance (KnownSymbol sym,+ ToHttpApiData a,+ HasClientMulti t m sublayout f tag,+ Reflex t,+ Applicative f)+ => HasClientMulti t m (QueryParams sym a :> sublayout) f tag where++ type ClientMulti t m (QueryParams sym a :> sublayout) f tag =+ Dynamic t (f [a]) -> ClientMulti t m sublayout f tag++ clientWithRouteMulti Proxy q f tag reqs baseurl opts paramlists =+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts++ where req' l r = r { qParams = (T.pack pname, params' (constDyn l)) : qParams r }+ pname = symbolVal (Proxy :: Proxy sym)+ params' l = QueryPartParams $ (fmap . fmap) (toQueryParam)+ l+ reqs' = liftA2 req' <$> paramlists <*> reqs+++instance (KnownSymbol sym,+ HasClientMulti t m sublayout f tag,+ Reflex t,+ Applicative f)+ => HasClientMulti t m (QueryFlag sym :> sublayout) f tag where++ type ClientMulti t m (QueryFlag sym :> sublayout) f tag =+ Dynamic t (f Bool) -> ClientMulti t m sublayout f tag++ clientWithRouteMulti Proxy q f' tag reqs baseurl opts flags =+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f' tag reqs' baseurl opts++ where req' f req = req { qParams = thisPair (constDyn f) : qParams req }+ thisPair f = (T.pack pName, QueryPartFlag f) :: (Text, QueryPart t)+ pName = symbolVal (Proxy :: Proxy sym)+ reqs' = liftA2 req' <$> flags <*> reqs+++instance (SupportsServantReflex t m,+ Traversable f, Applicative f) => HasClientMulti t m Raw f tag where+ type ClientMulti t m Raw f tag = f (Dynamic t (Either Text (XhrRequest ())))+ -> Event t tag+ -> m (Event t (f (ReqResult tag ())))++ clientWithRouteMulti _ _ _ _ _ _ opts rawReqs triggers = do+ let rawReqs' = sequence rawReqs :: Dynamic t (f (Either Text (XhrRequest ())))+ rawReqs'' = attachPromptlyDynWith (\fxhr t -> Compose (t, fxhr)) rawReqs' triggers+ resps <- fmap (fmap aux . sequenceA . getCompose) <$> performSomeRequestsAsync opts rawReqs''+ return resps+ where+ aux (tag, Right r) = ResponseSuccess tag () r+ aux (tag, Left e) = RequestFailure tag e+++instance (MimeRender ct a,+ HasClientMulti t m sublayout f tag,+ Reflex t,+ Applicative f)+ => HasClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag where++ type ClientMulti t m (ReqBody (ct ': cts) a :> sublayout) f tag =+ Dynamic t (f (Either Text a)) -> ClientMulti t m sublayout f tag++ clientWithRouteMulti Proxy q f tag reqs baseurl opts bodies =+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag reqs' baseurl opts+ where req' b r = r { reqBody = bodyBytesCT (constDyn b) }+ ctProxy = Proxy :: Proxy ct+ ctString = T.pack $ show $ contentType ctProxy+ bodyBytesCT b = Just $ (fmap . fmap)+ (\b' -> (mimeRender ctProxy b', ctString))+ b+ reqs' = liftA2 req' <$> bodies <*> reqs+++instance (KnownSymbol path,+ HasClientMulti t m sublayout f tag,+ Reflex t,+ Functor f) => HasClientMulti t m (path :> sublayout) f tag where+ type ClientMulti t m (path :> sublayout) f tag = ClientMulti t m sublayout f tag++ clientWithRouteMulti Proxy q f tag reqs baseurl =+ clientWithRouteMulti (Proxy :: Proxy sublayout) q f tag+ (fmap (prependToPathParts (pure (Right $ T.pack p))) <$> reqs)+ baseurl++ where p = symbolVal (Proxy :: Proxy path)+++instance HasClientMulti t m api f tag => HasClientMulti t m (Vault :> api) f tag where+ type ClientMulti t m (Vault :> api) f tag = ClientMulti t m api f tag++ clientWithRouteMulti Proxy q f tag reqs baseurl =+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl+++instance HasClientMulti t m api f tag => HasClientMulti t m (RemoteHost :> api) f tag where+ type ClientMulti t m (RemoteHost :> api) f tag = ClientMulti t m api f tag++ clientWithRouteMulti Proxy q f tag reqs baseurl =+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl+++instance HasClientMulti t m api f tag => HasClientMulti t m (IsSecure :> api) f tag where+ type ClientMulti t m (IsSecure :> api) f tag = ClientMulti t m api f tag++ clientWithRouteMulti Proxy q f tag reqs baseurl =+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs baseurl+++instance (HasClientMulti t m api f tag, Reflex t, Applicative f)+ => HasClientMulti t m (BasicAuth realm usr :> api) f tag where++ type ClientMulti t m (BasicAuth realm usr :> api) f tag = Dynamic t (f (Maybe BasicAuthData))+ -> ClientMulti t m api f tag++ clientWithRouteMulti Proxy q f tag reqs baseurl opts authdatas =+ clientWithRouteMulti (Proxy :: Proxy api) q f tag reqs' baseurl opts+ where+ req' a r = r { authData = Just (constDyn a) }+ reqs' = liftA2 req' <$> authdatas <*> reqs