From 59156f977bbd4929b2083b5bc48aa914ca5a1421 Mon Sep 17 00:00:00 2001 From: Greg Hale Date: Sat, 17 Mar 2018 16:13:15 -0400 Subject: [PATCH] initial checkin --- default.nix | 16 + exec/Example.hs | 219 -------- nix/reflex-platform.json | 7 + nix/reflex-platform.nix | 15 + nix/servant-src.nix | 6 + nix/servant.nix | 0 overrides-ghc.nix | 6 + servant-reflex.cabal | 19 +- servant-reflex.nix | 25 + shell.nix | 9 + src/Servant/Client/Internal/ReflexClient.hs | 51 ++ src/Servant/Common/BaseUrl.hs | 99 ---- src/Servant/Common/Req.hs | 409 -------------- src/Servant/Reflex.hs | 580 +------------------- src/Servant/Reflex/Multi.hs | 388 ------------- 15 files changed, 153 insertions(+), 1696 deletions(-) create mode 100644 default.nix delete mode 100644 exec/Example.hs create mode 100644 nix/reflex-platform.json create mode 100644 nix/reflex-platform.nix create mode 100644 nix/servant-src.nix create mode 100644 nix/servant.nix create mode 100644 servant-reflex.nix create mode 100644 shell.nix create mode 100644 src/Servant/Client/Internal/ReflexClient.hs delete mode 100644 src/Servant/Common/BaseUrl.hs delete mode 100644 src/Servant/Common/Req.hs delete mode 100644 src/Servant/Reflex/Multi.hs diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..9d91d2d --- /dev/null +++ b/default.nix @@ -0,0 +1,16 @@ +{ reflex-platform ? import ./nix/reflex-platform.nix +, compiler ? "ghc" +} : +let + + ghc = (reflex-platform.${compiler}.override { + overrides = self: super: { + servant = self.callCabal2nix "servant" (import ./nix/servant-src.nix + "/servant") {}; + servant-client-core = self.callCabal2nix "servant-client-core" (import ./nix/servant-src.nix + "/servant-client-core") {}; + }; + }); + + drv = ghc.callPackage ./servant-reflex.nix {}; + +in + drv \ No newline at end of file diff --git a/exec/Example.hs b/exec/Example.hs deleted file mode 100644 index ebc11a8..0000000 --- a/exec/Example.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# 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 - putStrLn ("Got req: " ++ show r) - 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) = "" -showRB (XhrResponseBody_ArrayBuffer t) = tShow t - -note :: e -> Maybe a -> Either e a -note e = maybe (Left e) Right diff --git a/nix/reflex-platform.json b/nix/reflex-platform.json new file mode 100644 index 0000000..df74552 --- /dev/null +++ b/nix/reflex-platform.json @@ -0,0 +1,7 @@ +{ + "url": "https://github.com/reflex-frp/reflex-platform", + "rev": "f003577699ad5a47f8275dad4f05cdb15c4bcdf5", + "date": "2018-03-09T20:45:25-05:00", + "sha256": "1fwg9cfz6p6zrlk1j5648r9hc5s2m62cwwv036sc7byb3pdhlxdr", + "fetchSubmodules": true +} diff --git a/nix/reflex-platform.nix b/nix/reflex-platform.nix new file mode 100644 index 0000000..1f67f80 --- /dev/null +++ b/nix/reflex-platform.nix @@ -0,0 +1,15 @@ +let + initialNixpkgs = import {}; + + sources = rec { + reflex-platform-info-pinned = initialNixpkgs.pkgs.lib.importJSON ./reflex-platform.json; + reflex-platform = initialNixpkgs.pkgs.fetchFromGitHub { + owner = "reflex-frp"; + repo = "reflex-platform"; + inherit (reflex-platform-info-pinned) rev sha256; + }; + }; + + reflex-platform = import sources.reflex-platform {}; +in + reflex-platform diff --git a/nix/servant-src.nix b/nix/servant-src.nix new file mode 100644 index 0000000..2f84814 --- /dev/null +++ b/nix/servant-src.nix @@ -0,0 +1,6 @@ +(import {}).fetchFromGitHub { + owner = "haskell-servant"; + repo = "servant"; + rev = "4824fbd961b2fcecef25bd02dae171ab17fe1cac"; + sha256 = "1mdv91x5i9qfh6vs3w30vl4imjxycy6zyridp4d084k5blyfrspq"; +} \ No newline at end of file diff --git a/nix/servant.nix b/nix/servant.nix new file mode 100644 index 0000000..e69de29 diff --git a/overrides-ghc.nix b/overrides-ghc.nix index 33dd4fb..3b543e3 100644 --- a/overrides-ghc.nix +++ b/overrides-ghc.nix @@ -2,10 +2,16 @@ let c2n = reflex-platform.cabal2nixResult; dc = reflex-platform.lib.dontCheck; + mypkgs = (import {}).haskellPackages; in reflex-platform.ghc.override { overrides = self: super: { servant-snap = dc (self.callPackage (c2n deps/servant-snap) {}); heist = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {}); xmlhtml = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {}); + servant = self.callHackage "servant" "0.12" {}; + servant-auth = self.callHackage "servant-auth" "0.3.0.1" {}; + servant-client-core = self.callHackage "servant-client-core" "0.12" {}; + # servant = self.callCabal2nix "servant" (import ./nix/servant-src.nix + "/servant") {}; + # servant-client-core = self.callCabal2nix "servant-client-core" (import ./nix/servant-src.nix + "/servant-client-core") {}; }; } diff --git a/servant-reflex.cabal b/servant-reflex.cabal index efd94dc..5b6db04 100644 --- a/servant-reflex.cabal +++ b/servant-reflex.cabal @@ -1,5 +1,5 @@ Name: servant-reflex -Version: 0.3.3 +Version: 0.4 Synopsis: Servant reflex API generator Description: Servant reflex API generator License: BSD3 @@ -18,11 +18,7 @@ Flag Example library exposed-modules: Servant.Reflex - Servant.Reflex.Multi - - other-modules: - Servant.Common.BaseUrl - Servant.Common.Req + Servant.Client.Internal.ReflexClient hs-source-dirs: src build-depends: @@ -39,13 +35,16 @@ library mtl >= 2.2.1 && < 2.3, network-uri >= 2.6 && < 2.7, reflex >= 0.5 && < 0.6, - reflex-dom-core == 0.4 && < 0.5, + reflex-dom-core >= 0.4 && < 0.5, safe >= 0.3.9 && < 0.4, - servant >= 0.8 && < 0.12, - servant-auth >= 0.2.1 && < 0.3, + semigroupoids >= 5.2.1 && < 5.3, + servant >= 0.8 && < 0.13, + servant-auth >= 0.2.1 && < 0.4, + servant-client-core >= 0.12 && < 0.13, string-conversions >= 0.4 && < 0.5, text >= 1.2 && < 1.3, - transformers >= 0.4 && < 0.6 + transformers >= 0.4 && < 0.6, + transformers-base >= 0.4 && < 0.5 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 diff --git a/servant-reflex.nix b/servant-reflex.nix new file mode 100644 index 0000000..7ce47da --- /dev/null +++ b/servant-reflex.nix @@ -0,0 +1,25 @@ +{ mkDerivation, 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-client-core, stdenv, string-conversions, text +, transformers +}: +mkDerivation { + pname = "servant-reflex"; + version = "0.3.3"; + src = ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + base bytestring case-insensitive containers data-default exceptions + ghcjs-dom http-api-data http-media jsaddle mtl network-uri reflex + reflex-dom-core safe servant servant-auth servant-client-core + string-conversions text transformers + ]; + executableHaskellDepends = [ + aeson base reflex reflex-dom scientific servant text + ]; + description = "Servant reflex API generator"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..87d06b8 --- /dev/null +++ b/shell.nix @@ -0,0 +1,9 @@ +{ nixpkgs ? import {} +, compiler ? "ghc" +} : +let + inherit (nixpkgs) pkgs; + reflex-platform = import ./nix/reflex-platform.nix; + drv = import ./. { inherit reflex-platform compiler; }; +in + if pkgs.lib.inNixShell then drv.env else drv diff --git a/src/Servant/Client/Internal/ReflexClient.hs b/src/Servant/Client/Internal/ReflexClient.hs new file mode 100644 index 0000000..21fa63e --- /dev/null +++ b/src/Servant/Client/Internal/ReflexClient.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Servant.Client.Internal.ReflexClient where + +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Catch (MonadCatch, MonadThrow) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Except (ExceptT (..), runExceptT ) +import Control.Monad.Reader(MonadReader, ReaderT (..)) +import Data.Functor.Alt (Alt(..)) +-- import Control.Monad.Trans.Control +import GHC.Generics +import Servant.Client.Core +import Reflex + + +data ClientEnv = ClientEnv + { baseUrl :: BaseUrl } + +newtype ClientM t a = ClientM { unClientM :: ReaderT ClientEnv (ExceptT ServantError IO) (Event t a) } + deriving ( Functor, Applicative, Monad, MonadIO, Generic + , MonadReader ClientEnv, MonadError ServantError, MonadThrow + , MonadCatch ) + +-- instance MonadBase IO ClientM where +-- liftBase = ClientM . liftBase + +-- instance MonadBaseControl IO ClientM where +-- type StM ClientM a = Either ServantError a +-- liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . unClientM))) +-- restoreM st = ClientM (restoreM st) + +instance Alt (ClientM t) where + a b = a `catchError` \_ -> b + +instance ClientLike (ClientM t a) (ClientM t a) where + mkClient = id + +runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) +runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm + diff --git a/src/Servant/Common/BaseUrl.hs b/src/Servant/Common/BaseUrl.hs deleted file mode 100644 index ae31f93..0000000 --- a/src/Servant/Common/BaseUrl.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# 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 diff --git a/src/Servant/Common/Req.hs b/src/Servant/Common/Req.hs deleted file mode 100644 index d7558f6..0000000 --- a/src/Servant/Common/Req.hs +++ /dev/null @@ -1,409 +0,0 @@ -{-# 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.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 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 = Nothing - , _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 = Nothing - , _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 x = first T.pack . - mimeUnrender ct . - BL.fromStrict . - TE.encodeUtf8 =<< note "No body text" - (_xhrResponse_responseText x) - return $ fmap - (\(t,rs) -> ffor rs $ \r -> case r of - Left e -> RequestFailure t e - Right g -> evalResponse decodeResp (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 - - -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 diff --git a/src/Servant/Reflex.hs b/src/Servant/Reflex.hs index a1cc47a..b0ee1eb 100644 --- a/src/Servant/Reflex.hs +++ b/src/Servant/Reflex.hs @@ -1,573 +1,11 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +module Servant.Reflex ( + a + , ClientEnv (..) + , HasClient (..) +) where -#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 - , clientWithRoute - , 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 - - --- | 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 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 - - -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 - - clientWithRoute Proxy q pTag req baseurl opts = - clientWithRoute (Proxy :: Proxy a) q pTag req baseurl opts :<|> - clientWithRoute (Proxy :: Proxy b) q pTag req baseurl opts - - --- 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 - - clientWithRoute Proxy q t req baseurl opts val = - clientWithRoute (Proxy :: Proxy sublayout) - q t - (prependToPathParts p req) - baseurl opts - 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 - clientWithRoute Proxy _ _ req baseurl opts trigs = - 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 - clientWithRoute Proxy _ _ req baseurl opts = - (fmap . fmap) runIdentity . performRequestsNoBody method (constDyn $ Identity req) baseurl opts - 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))) - clientWithRoute Proxy _ _ req baseurl opts trigs = do - let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method) - resp <- fmap runIdentity <$> performRequestsCT (Proxy :: Proxy ct) method (constDyn $ Identity req') baseurl opts trigs - return $ 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))) - clientWithRoute Proxy _ _ req baseurl opts trigs = do - let method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method) - resp <- fmap runIdentity <$> performRequestsNoBody method (constDyn $ Identity req') baseurl opts trigs - return $ 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 - - clientWithRoute Proxy q t req baseurl opts eVal = - clientWithRoute (Proxy :: Proxy sublayout) - q t - (Servant.Common.Req.addHeader hname eVal req) - baseurl opts - 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 - - clientWithRoute Proxy q t = - clientWithRoute (Proxy :: Proxy sublayout) q t - - --- | 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 - clientWithRoute Proxy q t req baseurl opts mparam = - clientWithRoute (Proxy :: Proxy sublayout) q t - (req {qParams = paramPair : qParams req}) baseurl opts - - 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 - - clientWithRoute Proxy q t req baseurl opts paramlist = - clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts - - 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 - - clientWithRoute Proxy q t req baseurl opts flag = - clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts - - 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 ())) - - clientWithRoute _ _ _ _ baseurl _ 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 - return $ 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 - - clientWithRoute Proxy q t req baseurl opts body = - clientWithRoute (Proxy :: Proxy sublayout) q t req' baseurl opts - 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 - - clientWithRoute Proxy q t req baseurl opts = - clientWithRoute (Proxy :: Proxy sublayout) q t - (prependToPathParts (pure (Right $ T.pack p)) req) baseurl opts - - 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 - - clientWithRoute Proxy q t req baseurl = - clientWithRoute (Proxy :: Proxy api) q t req baseurl - - -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 - - clientWithRoute Proxy q t req baseurl = - clientWithRoute (Proxy :: Proxy api) q t req baseurl - - - -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 - - clientWithRoute Proxy q t req baseurl = - clientWithRoute (Proxy :: Proxy api) q t req baseurl - - -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 - - clientWithRoute Proxy q t req baseurl opts authdata = - clientWithRoute (Proxy :: Proxy api) q t req' baseurl opts - 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 - clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api) - - -type family HasCookieAuth xs :: Constraint where - HasCookieAuth (Auth.Cookie ': xs) = () - HasCookieAuth (x ': xs) = HasCookieAuth xs - HasCookieAuth '[] = CookieAuthNotEnabled - -class CookieAuthNotEnabled +import Servant.Client.Core.Reexport +import Servant.Client.Internal.ReflexClient +a :: Int +a = 3 diff --git a/src/Servant/Reflex/Multi.hs b/src/Servant/Reflex/Multi.hs deleted file mode 100644 index 744388f..0000000 --- a/src/Servant/Reflex/Multi.hs +++ /dev/null @@ -1,388 +0,0 @@ -{-# 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