{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Servant.Client.Core.Internal.HasClient where
import Prelude ()
import Prelude.Compat
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Foldable
(toList)
import Data.List
(foldl')
import Data.Proxy
(Proxy (Proxy))
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 (..), Capture', CaptureAll, Description,
EmptyAPI, FramingUnrender (..), FromSourceIO (..), Header',
Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender),
MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
Vault, Verb, WithNamedContext, contentType, getHeadersHList,
getResponse, toQueryParam, toUrlPiece)
import Servant.API.ContentTypes
(contentTypes)
import Servant.API.Modifiers
(FoldRequired, RequiredArgument, foldRequiredArgument)
import qualified Servant.Types.SourceT as S
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 #-}
( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
FramingUnrender framing, FromSourceIO chunk a
) => HasClient m (Stream method status framing ct a) where
type Client m (Stream method status framing ct a) = m a
hoistClientMonad _ _ f ma = f ma
clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
return $ fromSourceIO $ framingUnrender' $ S.fromAction BS.null (responseBody gres)
where
req' = req
{ requestAccept = fromList [contentType (Proxy :: Proxy ct)]
, requestMethod = reflectMethod (Proxy :: Proxy method)
}
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
( HasClient m api
) => HasClient m (StreamBody' mods framing ctype a :> api)
where
type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api
hoistClientMonad pm _ f cl = \a ->
hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
clientWithRoute _pm Proxy _req _body = error "HasClient @StreamBody"
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)