mirror of
https://github.com/ilyakooo0/servant-reflex.git
synced 2024-09-11 07:15:29 +03:00
initial checkin
This commit is contained in:
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
|
let
|
||||||
c2n = reflex-platform.cabal2nixResult;
|
c2n = reflex-platform.cabal2nixResult;
|
||||||
dc = reflex-platform.lib.dontCheck;
|
dc = reflex-platform.lib.dontCheck;
|
||||||
|
mypkgs = (import <nixpkgs> {}).haskellPackages;
|
||||||
in reflex-platform.ghc.override {
|
in reflex-platform.ghc.override {
|
||||||
overrides = self: super: {
|
overrides = self: super: {
|
||||||
servant-snap = dc (self.callPackage (c2n deps/servant-snap) {});
|
servant-snap = dc (self.callPackage (c2n deps/servant-snap) {});
|
||||||
heist = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});
|
heist = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/heist) {});
|
||||||
xmlhtml = dc (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
|
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
|
Name: servant-reflex
|
||||||
Version: 0.3.3
|
Version: 0.4
|
||||||
Synopsis: Servant reflex API generator
|
Synopsis: Servant reflex API generator
|
||||||
Description: Servant reflex API generator
|
Description: Servant reflex API generator
|
||||||
License: BSD3
|
License: BSD3
|
||||||
@ -18,11 +18,7 @@ Flag Example
|
|||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
Servant.Reflex
|
Servant.Reflex
|
||||||
Servant.Reflex.Multi
|
Servant.Client.Internal.ReflexClient
|
||||||
|
|
||||||
other-modules:
|
|
||||||
Servant.Common.BaseUrl
|
|
||||||
Servant.Common.Req
|
|
||||||
|
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
build-depends:
|
build-depends:
|
||||||
@ -39,13 +35,16 @@ library
|
|||||||
mtl >= 2.2.1 && < 2.3,
|
mtl >= 2.2.1 && < 2.3,
|
||||||
network-uri >= 2.6 && < 2.7,
|
network-uri >= 2.6 && < 2.7,
|
||||||
reflex >= 0.5 && < 0.6,
|
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,
|
safe >= 0.3.9 && < 0.4,
|
||||||
servant >= 0.8 && < 0.12,
|
semigroupoids >= 5.2.1 && < 5.3,
|
||||||
servant-auth >= 0.2.1 && < 0.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,
|
string-conversions >= 0.4 && < 0.5,
|
||||||
text >= 1.2 && < 1.3,
|
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
|
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 #-}
|
module Servant.Reflex (
|
||||||
{-# LANGUAGE CPP #-}
|
a
|
||||||
{-# LANGUAGE DataKinds #-}
|
, ClientEnv (..)
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
, HasClient (..)
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
) where
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE InstanceSigs #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE PolyKinds #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TupleSections #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
|
|
||||||
#if MIN_VERSION_base(4,9,0)
|
import Servant.Client.Core.Reexport
|
||||||
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
|
import Servant.Client.Internal.ReflexClient
|
||||||
#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
|
|
||||||
|
|
||||||
|
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