mirror of
https://github.com/ilyakooo0/servant-reflex.git
synced 2024-08-15 18:20:25 +03:00
initial checkin
This commit is contained in:
Greg Hale
parent
2996dbc8e0
commit
59156f977b
16
default.nix
Normal file
16
default.nix
Normal file
@ -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
|
||||
219
exec/Example.hs
219
exec/Example.hs
@ -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) = "<Blob>"
|
||||
showRB (XhrResponseBody_ArrayBuffer t) = tShow t
|
||||
|
||||
note :: e -> Maybe a -> Either e a
|
||||
note e = maybe (Left e) Right
|
||||
7
nix/reflex-platform.json
Normal file
7
nix/reflex-platform.json
Normal file
@ -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
|
||||
}
|
||||
15
nix/reflex-platform.nix
Normal file
15
nix/reflex-platform.nix
Normal file
@ -0,0 +1,15 @@
|
||||
let
|
||||
initialNixpkgs = import <nixpkgs> {};
|
||||
|
||||
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
|
||||
6
nix/servant-src.nix
Normal file
6
nix/servant-src.nix
Normal file
@ -0,0 +1,6 @@
|
||||
(import <nixpkgs> {}).fetchFromGitHub {
|
||||
owner = "haskell-servant";
|
||||
repo = "servant";
|
||||
rev = "4824fbd961b2fcecef25bd02dae171ab17fe1cac";
|
||||
sha256 = "1mdv91x5i9qfh6vs3w30vl4imjxycy6zyridp4d084k5blyfrspq";
|
||||
}
|
||||
0
nix/servant.nix
Normal file
0
nix/servant.nix
Normal file
@ -2,10 +2,16 @@
|
||||
let
|
||||
c2n = reflex-platform.cabal2nixResult;
|
||||
dc = reflex-platform.lib.dontCheck;
|
||||
mypkgs = (import <nixpkgs> {}).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") {};
|
||||
};
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
25
servant-reflex.nix
Normal file
25
servant-reflex.nix
Normal file
@ -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;
|
||||
}
|
||||
9
shell.nix
Normal file
9
shell.nix
Normal file
@ -0,0 +1,9 @@
|
||||
{ nixpkgs ? import <nixpkgs> {}
|
||||
, 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
|
||||
51
src/Servant/Client/Internal/ReflexClient.hs
Normal file
51
src/Servant/Client/Internal/ReflexClient.hs
Normal file
@ -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
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
Loading…
Reference in New Issue
Block a user