{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#include "overlapping-compat.h"
module Servant.Client.Core.Internal.HasClient where
import Prelude ()
import Prelude.Compat
import Control.Concurrent (newMVar, modifyMVar)
import Data.Foldable (toList)
import qualified Data.ByteString.Lazy as BL
import Data.List (foldl')
import Data.Proxy (Proxy (Proxy))
import Data.Semigroup ((<>))
import Data.Sequence (fromList)
import Data.String (fromString)
import Data.Text (Text, pack)
import GHC.TypeLits (KnownSymbol, symbolVal)
import qualified Network.HTTP.Types as H
import Servant.API ((:<|>) ((:<|>)), (:>),
AuthProtect, BasicAuth,
BasicAuthData,
BuildHeadersTo (..),
BuildFromStream (..),
ByteStringParser (..),
Capture', CaptureAll,
Description, EmptyAPI,
FramingUnrender (..),
Header', Headers (..),
HttpVersion, IsSecure,
MimeRender (mimeRender),
MimeUnrender (mimeUnrender),
NoContent (NoContent),
QueryFlag, QueryParam',
QueryParams, Raw,
ReflectMethod (..),
RemoteHost, ReqBody',
ResultStream(..),
SBoolI,
Stream,
Summary, ToHttpApiData,
Vault, Verb,
WithNamedContext,
contentType,
getHeadersHList,
getResponse,
toQueryParam,
toUrlPiece)
import Servant.API.ContentTypes (contentTypes)
import Servant.API.Modifiers (FoldRequired,
RequiredArgument,
foldRequiredArgument)
import Servant.Client.Core.Internal.Auth
import Servant.Client.Core.Internal.BasicAuth
import Servant.Client.Core.Internal.Request
import Servant.Client.Core.Internal.RunClient
clientIn :: HasClient m api => Proxy api -> Proxy m -> Client m api
clientIn p pm = clientWithRoute pm p defaultRequest
class RunClient m => HasClient m api where
type Client (m :: * -> *) (api :: *) :: *
clientWithRoute :: Proxy m -> Proxy api -> Request -> Client m api
hoistClientMonad
:: Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
instance (HasClient m a, HasClient m b) => HasClient m (a :<|> b) where
type Client m (a :<|> b) = Client m a :<|> Client m b
clientWithRoute pm Proxy req =
clientWithRoute pm (Proxy :: Proxy a) req :<|>
clientWithRoute pm (Proxy :: Proxy b) req
hoistClientMonad pm _ f (ca :<|> cb) =
hoistClientMonad pm (Proxy :: Proxy a) f ca :<|>
hoistClientMonad pm (Proxy :: Proxy b) f cb
data EmptyClient = EmptyClient deriving (Eq, Show, Bounded, Enum)
instance RunClient m => HasClient m EmptyAPI where
type Client m EmptyAPI = EmptyClient
clientWithRoute _pm Proxy _ = EmptyClient
hoistClientMonad _ _ _ EmptyClient = EmptyClient
instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
=> HasClient m (Capture' mods capture a :> api) where
type Client m (Capture' mods capture a :> api) =
a -> Client m api
clientWithRoute pm Proxy req val =
clientWithRoute pm (Proxy :: Proxy api)
(appendToPath p req)
where p = (toUrlPiece val)
hoistClientMonad pm _ f cl = \a ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
=> HasClient m (CaptureAll capture a :> sublayout) where
type Client m (CaptureAll capture a :> sublayout) =
[a] -> Client m sublayout
clientWithRoute pm Proxy req vals =
clientWithRoute pm (Proxy :: Proxy sublayout)
(foldl' (flip appendToPath) req ps)
where ps = map (toUrlPiece) vals
hoistClientMonad pm _ f cl = \as ->
hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
instance OVERLAPPABLE_
( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient m (Verb method status cts' a) where
type Client m (Verb method status cts' a) = m a
clientWithRoute _pm Proxy req = do
response <- runRequest req
{ requestAccept = fromList $ toList accept
, requestMethod = method
}
response `decodedAs` (Proxy :: Proxy ct)
where
accept = contentTypes (Proxy :: Proxy ct)
method = reflectMethod (Proxy :: Proxy method)
hoistClientMonad _ _ f ma = f ma
instance OVERLAPPING_
( RunClient m, ReflectMethod method
) => HasClient m (Verb method status cts NoContent) where
type Client m (Verb method status cts NoContent)
= m NoContent
clientWithRoute _pm Proxy req = do
_response <- runRequest req { requestMethod = method }
return NoContent
where method = reflectMethod (Proxy :: Proxy method)
hoistClientMonad _ _ f ma = f ma
instance OVERLAPPING_
( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient m (Verb method status cts' (Headers ls a)) where
type Client m (Verb method status cts' (Headers ls a))
= m (Headers ls a)
clientWithRoute _pm Proxy req = do
response <- runRequest req
{ requestMethod = method
, requestAccept = fromList $ toList accept
}
case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of
Left err -> throwServantError $ DecodeFailure (pack err) response
Right val -> return $ Headers
{ getResponse = val
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response
}
where method = reflectMethod (Proxy :: Proxy method)
accept = contentTypes (Proxy :: Proxy ct)
hoistClientMonad _ _ f ma = f ma
instance OVERLAPPING_
( RunClient m, BuildHeadersTo ls, ReflectMethod method
) => HasClient m (Verb method status cts (Headers ls NoContent)) where
type Client m (Verb method status cts (Headers ls NoContent))
= m (Headers ls NoContent)
clientWithRoute _pm Proxy req = do
let method = reflectMethod (Proxy :: Proxy method)
response <- runRequest req { requestMethod = method }
return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo . toList $ responseHeaders response
}
hoistClientMonad _ _ f ma = f ma
instance OVERLAPPABLE_
( RunClient m, MimeUnrender ct a, ReflectMethod method,
FramingUnrender framing a, BuildFromStream a (f a)
) => HasClient m (Stream method status framing ct (f a)) where
type Client m (Stream method status framing ct (f a)) = m (f a)
clientWithRoute _pm Proxy req = do
sresp <- streamingRequest req
{ requestAccept = fromList [contentType (Proxy :: Proxy ct)]
, requestMethod = reflectMethod (Proxy :: Proxy method)
}
return . buildFromStream $ ResultStream $ \k ->
runStreamingResponse sresp $ \gres -> do
let reader = responseBody gres
let unrender = unrenderFrames (Proxy :: Proxy framing) (Proxy :: Proxy a)
loop bs = do
res <- BL.fromStrict <$> reader
if BL.null res
then return $ parseEOF unrender res
else let sofar = (bs <> res)
in case parseIncremental unrender sofar of
Just x -> return x
Nothing -> loop sofar
(frameParser, remainder) <- loop BL.empty
state <- newMVar remainder
let frameLoop bs = do
res <- BL.fromStrict <$> reader
let addIsEmptyInfo (a, r) = (r, (a, BL.null r && BL.null res))
if BL.null res
then if BL.null bs
then return ("", (Right "", True))
else return . addIsEmptyInfo $ parseEOF frameParser bs
else let sofar = (bs <> res)
in case parseIncremental frameParser sofar of
Just x -> return $ addIsEmptyInfo x
Nothing -> frameLoop sofar
go = processResult <$> modifyMVar state frameLoop
processResult (Right bs,isDone) =
if BL.null bs && isDone
then Nothing
else Just $ case mimeUnrender (Proxy :: Proxy ct) bs :: Either String a of
Left err -> Left err
Right x -> Right x
processResult (Left err, _) = Just (Left err)
k go
hoistClientMonad _ _ f ma = f ma
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
=> HasClient m (Header' mods sym a :> api) where
type Client m (Header' mods sym a :> api) =
RequiredArgument mods a -> Client m api
clientWithRoute pm Proxy req mval =
clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
(Proxy :: Proxy mods) add (maybe req add) mval
where
hname = fromString $ symbolVal (Proxy :: Proxy sym)
add :: a -> Request
add value = addHeader hname value req
hoistClientMonad pm _ f cl = \arg ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
instance HasClient m api
=> HasClient m (HttpVersion :> api) where
type Client m (HttpVersion :> api) =
Client m api
clientWithRoute pm Proxy =
clientWithRoute pm (Proxy :: Proxy api)
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
instance HasClient m api => HasClient m (Summary desc :> api) where
type Client m (Summary desc :> api) = Client m api
clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
instance HasClient m api => HasClient m (Description desc :> api) where
type Client m (Description desc :> api) = Client m api
clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequired mods))
=> HasClient m (QueryParam' mods sym a :> api) where
type Client m (QueryParam' mods sym a :> api) =
RequiredArgument mods a -> Client m api
clientWithRoute pm Proxy req mparam =
clientWithRoute pm (Proxy :: Proxy api) $ foldRequiredArgument
(Proxy :: Proxy mods) add (maybe req add) mparam
where
add :: a -> Request
add param = appendToQueryString pname (Just $ toQueryParam param) req
pname :: Text
pname = pack $ symbolVal (Proxy :: Proxy sym)
hoistClientMonad pm _ f cl = \arg ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
=> HasClient m (QueryParams sym a :> api) where
type Client m (QueryParams sym a :> api) =
[a] -> Client m api
clientWithRoute pm Proxy req paramlist =
clientWithRoute pm (Proxy :: Proxy api)
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
req
paramlist'
)
where pname = pack $ symbolVal (Proxy :: Proxy sym)
paramlist' = map (Just . toQueryParam) paramlist
hoistClientMonad pm _ f cl = \as ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
instance (KnownSymbol sym, HasClient m api)
=> HasClient m (QueryFlag sym :> api) where
type Client m (QueryFlag sym :> api) =
Bool -> Client m api
clientWithRoute pm Proxy req flag =
clientWithRoute pm (Proxy :: Proxy api)
(if flag
then appendToQueryString paramname Nothing req
else req
)
where paramname = pack $ symbolVal (Proxy :: Proxy sym)
hoistClientMonad pm _ f cl = \b ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl b)
instance RunClient m => HasClient m Raw where
type Client m Raw
= H.Method -> m Response
clientWithRoute :: Proxy m -> Proxy Raw -> Request -> Client m Raw
clientWithRoute _pm Proxy req httpMethod = do
runRequest req { requestMethod = httpMethod }
hoistClientMonad _ _ f cl = \meth -> f (cl meth)
instance (MimeRender ct a, HasClient m api)
=> HasClient m (ReqBody' mods (ct ': cts) a :> api) where
type Client m (ReqBody' mods (ct ': cts) a :> api) =
a -> Client m api
clientWithRoute pm Proxy req body =
clientWithRoute pm (Proxy :: Proxy api)
(let ctProxy = Proxy :: Proxy ct
in setRequestBodyLBS (mimeRender ctProxy body)
(contentType ctProxy)
req
)
hoistClientMonad pm _ f cl = \a ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
type Client m (path :> api) = Client m api
clientWithRoute pm Proxy req =
clientWithRoute pm (Proxy :: Proxy api)
(appendToPath p req)
where p = pack $ symbolVal (Proxy :: Proxy path)
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
instance HasClient m api => HasClient m (Vault :> api) where
type Client m (Vault :> api) = Client m api
clientWithRoute pm Proxy req =
clientWithRoute pm (Proxy :: Proxy api) req
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
instance HasClient m api => HasClient m (RemoteHost :> api) where
type Client m (RemoteHost :> api) = Client m api
clientWithRoute pm Proxy req =
clientWithRoute pm (Proxy :: Proxy api) req
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
instance HasClient m api => HasClient m (IsSecure :> api) where
type Client m (IsSecure :> api) = Client m api
clientWithRoute pm Proxy req =
clientWithRoute pm (Proxy :: Proxy api) req
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
instance HasClient m subapi =>
HasClient m (WithNamedContext name context subapi) where
type Client m (WithNamedContext name context subapi) = Client m subapi
clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
instance ( HasClient m api
) => HasClient m (AuthProtect tag :> api) where
type Client m (AuthProtect tag :> api)
= AuthenticatedRequest (AuthProtect tag) -> Client m api
clientWithRoute pm Proxy req (AuthenticatedRequest (val,func)) =
clientWithRoute pm (Proxy :: Proxy api) (func val req)
hoistClientMonad pm _ f cl = \authreq ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
type Client m (BasicAuth realm usr :> api) = BasicAuthData -> Client m api
clientWithRoute pm Proxy req val =
clientWithRoute pm (Proxy :: Proxy api) (basicAuthReq val req)
hoistClientMonad pm _ f cl = \bauth ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)