@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE ConstraintKinds #-}
22{-# LANGUAGE DataKinds #-}
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
@@ -6,68 +6,99 @@
66{-# LANGUAGE MultiParamTypeClasses #-}
77{-# LANGUAGE OverloadedStrings #-}
88{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE QuantifiedConstraints #-}
910{-# LANGUAGE RankNTypes #-}
1011{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeApplications #-}
1113{-# LANGUAGE TypeFamilies #-}
1214{-# LANGUAGE TypeOperators #-}
1315{-# LANGUAGE UndecidableInstances #-}
1416
15−#include "overlapping-compat.h"
16−module Servant.Client.Core.Internal.HasClient where
17−
18−import Prelude ()
17+module Servant.Client.Core.HasClient (
18+ clientIn,
19+ HasClient (..),
20+ EmptyClient (..),
21+ AsClientT,
22+ (//),
23+ (/:),
24+ foldMapUnion,
25+ matchUnion,
26+ ) where
27+
28+import Prelude ()
1929import Prelude.Compat
2030
21−import Control.Concurrent (newMVar, modifyMVar)
22−import Data.Foldable (toList)
23−import qualified Data.ByteString.Lazy as BL
24−import Control.Monad.IO.Class (MonadIO (..))
25−import Data.List (foldl')
26−import Data.Proxy (Proxy (Proxy))
27−import Data.Semigroup ((<>))
28−import Data.Sequence (fromList)
29−import Data.String (fromString)
30−import Data.Text (Text, pack)
31−import GHC.TypeLits (KnownSymbol, symbolVal)
32−import qualified Network.HTTP.Types as H
33−import Servant.API ((:<|>) ((:<|>)), (:>),
34− AuthProtect, BasicAuth,
35− BasicAuthData,
36− BuildHeadersTo (..),
37− FromResultStream (..),
38− ByteStringParser (..),
39− Capture', CaptureAll,
40− Description, EmptyAPI,
41− FramingUnrender (..),
42− Header', Headers (..),
43− HttpVersion, IsSecure,
44− MimeRender (mimeRender),
45− MimeUnrender (mimeUnrender),
46− NoContent (NoContent),
47− QueryFlag, QueryParam',
48− QueryParams, Raw,
49− ReflectMethod (..),
50− RemoteHost, ReqBody',
51− ResultStream(..),
52− SBoolI,
53− Stream,
54− Summary, ToHttpApiData,
55− Vault, Verb,
56− WithNamedContext,
57− contentType,
58− getHeadersHList,
59− getResponse,
60− toQueryParam,
61− toUrlPiece)
62−import Servant.API.ContentTypes (contentTypes)
63−import Servant.API.Modifiers (FoldRequired,
64− RequiredArgument,
65− foldRequiredArgument)
66−
67−import Servant.Client.Core.Internal.Auth
68−import Servant.Client.Core.Internal.BasicAuth
69−import Servant.Client.Core.Internal.Request
70−import Servant.Client.Core.Internal.RunClient
31+import Control.Arrow
32+ (left, (+++))
33+import Control.Monad
34+ (unless)
35+import qualified Data.ByteString as BS
36+import qualified Data.ByteString.Lazy as BL
37+import Data.Either
38+ (partitionEithers)
39+import Data.Constraint (Dict(..))
40+import Data.Foldable
41+ (toList)
42+import Data.List
43+ (foldl')
44+import Data.Sequence
45+ (fromList)
46+import qualified Data.Text as T
47+import Network.HTTP.Media
48+ (MediaType, matches, parseAccept)
49+import qualified Network.HTTP.Media as Media
50+import qualified Data.Sequence as Seq
51+import Data.SOP.BasicFunctors
52+ (I (I), (:.:) (Comp))
53+import Data.SOP.Constraint
54+ (All)
55+import Data.SOP.NP
56+ (NP (..), cpure_NP)
57+import Data.SOP.NS
58+ (NS (S))
59+import Data.String
60+ (fromString)
61+import Data.Text
62+ (Text, pack)
63+import Data.Proxy
64+ (Proxy (Proxy))
65+import GHC.TypeLits
66+ (KnownNat, KnownSymbol, TypeError, symbolVal)
67+import Network.HTTP.Types
68+ (Status)
69+import qualified Network.HTTP.Types as H
70+import Servant.API
71+ ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
72+ BuildHeadersTo (..), Capture', CaptureAll, Description,
73+ EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
74+ FromSourceIO (..), Header', Headers (..), HttpVersion,
75+ IsSecure, MimeRender (mimeRender),
76+ MimeUnrender (mimeUnrender), NoContent (NoContent),
77+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
78+ ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
79+ StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
80+ Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
81+ getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
82+import Servant.API.Generic
83+ (GenericMode(..), ToServant, ToServantApi
84+ , GenericServant, toServant, fromServant)
85+import Servant.API.ContentTypes
86+ (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
87+import Servant.API.Status
88+ (statusFromNat)
89+import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
90+import Servant.API.Modifiers
91+ (FoldRequired, RequiredArgument, foldRequiredArgument)
92+import Servant.API.TypeErrors
93+import Servant.API.UVerb
94+ (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
95+
96+import Servant.Client.Core.Auth
97+import Servant.Client.Core.BasicAuth
98+import Servant.Client.Core.ClientError
99+import Servant.Client.Core.Request
100+import Servant.Client.Core.Response
101+import Servant.Client.Core.RunClient
71102
72103-- * Accessing APIs as a Client
73104
@@ -177,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
177208 clientWithRoute pm (Proxy :: Proxy api)
178209 (appendToPath p req)
179210
180− where p = (toUrlPiece val)
211+ where p = toEncodedUrlPiece val
181212
182213 hoistClientMonad pm _ f cl = \a ->
183214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@@ -212,18 +243,19 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
212243 clientWithRoute pm (Proxy :: Proxy sublayout)
213244 (foldl' (flip appendToPath) req ps)
214245
215− where ps = map (toUrlPiece) vals
246+ where ps = map toEncodedUrlPiece vals
216247
217248 hoistClientMonad pm _ f cl = \as ->
218249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
219250
220−instance OVERLAPPABLE_
251+instance {-# OVERLAPPABLE #-}
221252 -- Note [Non-Empty Content Types]
222253 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
254+ , KnownNat status
223255 ) => HasClient m (Verb method status cts' a) where
224256 type Client m (Verb method status cts' a) = m a
225257 clientWithRoute _pm Proxy req = do
226− response <- runRequest req
258+ response <- runRequestAcceptStatus (Just [status]) req
227259 { requestAccept = fromList $ toList accept
228260 , requestMethod = method
229261 }
@@ -231,14 +263,27 @@ instance OVERLAPPABLE_
231263 where
232264 accept = contentTypes (Proxy :: Proxy ct)
233265 method = reflectMethod (Proxy :: Proxy method)
266+ status = statusFromNat (Proxy :: Proxy status)
234267
235268 hoistClientMonad _ _ f ma = f ma
236269
237−instance OVERLAPPING_
238− ( RunClient m, ReflectMethod method
270+instance {-# OVERLAPPING #-}
271+ ( RunClient m, ReflectMethod method, KnownNat status
239272 ) => HasClient m (Verb method status cts NoContent) where
240273 type Client m (Verb method status cts NoContent)
241274 = m NoContent
275+ clientWithRoute _pm Proxy req = do
276+ _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
277+ return NoContent
278+ where method = reflectMethod (Proxy :: Proxy method)
279+ status = statusFromNat (Proxy :: Proxy status)
280+
281+ hoistClientMonad _ _ f ma = f ma
282+
283+instance (RunClient m, ReflectMethod method) =>
284+ HasClient m (NoContentVerb method) where
285+ type Client m (NoContentVerb method)
286+ = m NoContent
242287 clientWithRoute _pm Proxy req = do
243288 _response <- runRequest req { requestMethod = method }
244289 return NoContent
@@ -246,93 +291,175 @@ instance OVERLAPPING_
246291
247292 hoistClientMonad _ _ f ma = f ma
248293
249−instance OVERLAPPING_
294+instance {-# OVERLAPPING #-}
250295 -- Note [Non-Empty Content Types]
251− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
296+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
252297 , ReflectMethod method, cts' ~ (ct ': cts)
253298 ) => HasClient m (Verb method status cts' (Headers ls a)) where
254299 type Client m (Verb method status cts' (Headers ls a))
255300 = m (Headers ls a)
256301 clientWithRoute _pm Proxy req = do
257− response <- runRequest req
302+ response <- runRequestAcceptStatus (Just [status]) req
258303 { requestMethod = method
259304 , requestAccept = fromList $ toList accept
260305 }
261− case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of
262− Left err -> throwServantError $ DecodeFailure (pack err) response
263− Right val -> return $ Headers
264− { getResponse = val
265− , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
266− }
267− where method = reflectMethod (Proxy :: Proxy method)
268− accept = contentTypes (Proxy :: Proxy ct)
306+ val <- response `decodedAs` (Proxy :: Proxy ct)
307+ return $ Headers { getResponse = val
308+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
309+ }
310+ where
311+ method = reflectMethod (Proxy :: Proxy method)
312+ accept = contentTypes (Proxy :: Proxy ct)
313+ status = statusFromNat (Proxy :: Proxy status)
269314
270315 hoistClientMonad _ _ f ma = f ma
271316
272−instance OVERLAPPING_
273− ( RunClient m, BuildHeadersTo ls, ReflectMethod method
317+instance {-# OVERLAPPING #-}
318+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
274319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
275320 type Client m (Verb method status cts (Headers ls NoContent))
276321 = m (Headers ls NoContent)
277322 clientWithRoute _pm Proxy req = do
278− let method = reflectMethod (Proxy :: Proxy method)
279− response <- runRequest req { requestMethod = method }
323+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
280324 return $ Headers { getResponse = NoContent
281325 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
282326 }
327+ where
328+ method = reflectMethod (Proxy :: Proxy method)
329+ status = statusFromNat (Proxy :: Proxy status)
283330
284331 hoistClientMonad _ _ f ma = f ma
285332
286−instance OVERLAPPABLE_
287− ( RunClient m, MonadIO m, MimeUnrender ct a, ReflectMethod method,
288− FramingUnrender framing a, FromResultStream a b
289− ) => HasClient m (Stream method status framing ct b) where
333+data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
334+ deriving (Eq, Show)
290335
291− type Client m (Stream method status framing ct b) = m b
336+class UnrenderResponse (cts :: [*]) (a :: *) where
337+ unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts
338+ -> [Either (MediaType, String) a]
292339
293− clientWithRoute _pm Proxy req = do
294− sresp <- streamingRequest req
295− { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
296− , requestMethod = reflectMethod (Proxy :: Proxy method)
297− }
298− liftIO $ fromResultStream $ ResultStream $ \k ->
299− runStreamingResponse sresp $ \gres -> do
300− let reader = responseBody gres
301− let unrender = unrenderFrames (Proxy :: Proxy framing) (Proxy :: Proxy a)
302− loop bs = do
303− res <- BL.fromStrict <$> reader
304− if BL.null res
305− then return $ parseEOF unrender res
306− else let sofar = (bs <> res)
307− in case parseIncremental unrender sofar of
308− Just x -> return x
309− Nothing -> loop sofar
310− (frameParser, remainder) <- loop BL.empty
311− state <- newMVar remainder
312− let frameLoop bs = do
313− res <- BL.fromStrict <$> reader
314− let addIsEmptyInfo (a, r) = (r, (a, BL.null r && BL.null res))
315− if BL.null res
316− then if BL.null bs
317− then return ("", (Right "", True))
318− else return . addIsEmptyInfo $ parseEOF frameParser bs
319− else let sofar = (bs <> res)
320− in case parseIncremental frameParser sofar of
321− Just x -> return $ addIsEmptyInfo x
322− Nothing -> frameLoop sofar
323−
324− go = processResult <$> modifyMVar state frameLoop
325− processResult (Right bs,isDone) =
326− if BL.null bs && isDone
327− then Nothing
328− else Just $ case mimeUnrender (Proxy :: Proxy ct) bs :: Either String a of
329− Left err -> Left err
330− Right x -> Right x
331− processResult (Left err, _) = Just (Left err)
332− k go
340+instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where
341+ unrenderResponse _ body = map parse . allMimeUnrender
342+ where parse (mediaType, parser) = left ((,) mediaType) (parser body)
343+
344+instance {-# OVERLAPPING #-} forall cts a h . (UnrenderResponse cts a, BuildHeadersTo h)
345+ => UnrenderResponse cts (Headers h a) where
346+ unrenderResponse hs body = (map . fmap) setHeaders . unrenderResponse hs body
347+ where
348+ setHeaders :: a -> Headers h a
349+ setHeaders x = Headers x (buildHeadersTo (toList hs))
350+
351+instance {-# OVERLAPPING #-} UnrenderResponse cts a
352+ => UnrenderResponse cts (WithStatus n a) where
353+ unrenderResponse hs body = (map . fmap) WithStatus . unrenderResponse hs body
354+
355+instance {-# OVERLAPPING #-}
356+ ( RunClient m,
357+ contentTypes ~ (contentType ': otherContentTypes),
358+ -- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem
359+ -- allow this in instance types as of 8.8.3.)
360+ as ~ (a ': as'),
361+ AllMime contentTypes,
362+ ReflectMethod method,
363+ All (UnrenderResponse contentTypes) as,
364+ All HasStatus as, HasStatuses as',
365+ Unique (Statuses as)
366+ ) =>
367+ HasClient m (UVerb method contentTypes as)
368+ where
369+ type Client m (UVerb method contentTypes as) = m (Union as)
370+
371+ clientWithRoute _ _ request = do
372+ let accept = Seq.fromList . allMime $ Proxy @contentTypes
373+ -- offering to accept all mime types listed in the api gives best compatibility. eg.,
374+ -- we might not own the server implementation, and the server may choose to support
375+ -- only part of the api.
376+
377+ method = reflectMethod $ Proxy @method
378+ acceptStatus = statuses (Proxy @as)
379+ response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}
380+ responseContentType <- checkContentTypeHeader response
381+ unless (any (matches responseContentType) accept) $ do
382+ throwClientError $ UnsupportedContentType responseContentType response
383+
384+ let status = responseStatusCode response
385+ body = responseBody response
386+ headers = responseHeaders response
387+ res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body
388+ case res of
389+ Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
390+ Right x -> return x
391+ where
392+ -- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the
393+ -- failures it encountered along the way
394+ -- TODO; better name, rewrite haddocs.
395+ tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs)
396+ tryParsers _ Nil = Left [ClientNoMatchingStatus]
397+ tryParsers status (Comp x :* xs)
398+ | status == statusOf (Comp x) =
399+ case partitionEithers x of
400+ (err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs
401+ (_, (res : _)) -> Right . inject . I $ res
402+ | otherwise = -- no reason to parse in the first place. This ain't the one we're looking for
403+ (ClientStatusMismatch :) +++ S $ tryParsers status xs
404+
405+ -- | Given a list of types, parses the given response body as each type
406+ mimeUnrenders ::
407+ forall cts xs.
408+ All (UnrenderResponse cts) xs =>
409+ Proxy cts ->
410+ Seq.Seq H.Header ->
411+ BL.ByteString ->
412+ NP ([] :.: Either (MediaType, String)) xs
413+ mimeUnrenders ctp headers body = cpure_NP
414+ (Proxy @(UnrenderResponse cts))
415+ (Comp . unrenderResponse headers body $ ctp)
416+
417+ hoistClientMonad _ _ nt s = nt s
418+
419+instance {-# OVERLAPPABLE #-}
420+ ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
421+ FramingUnrender framing, FromSourceIO chunk a
422+ ) => HasClient m (Stream method status framing ct a) where
423+
424+ type Client m (Stream method status framing ct a) = m a
425+
426+ hoistClientMonad _ _ f ma = f ma
427+
428+ clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
429+ let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
430+ framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
431+ return $ fromSourceIO $ framingUnrender' $ responseBody gres
432+ where
433+ req' = req
434+ { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
435+ , requestMethod = reflectMethod (Proxy :: Proxy method)
436+ }
437+
438+instance {-# OVERLAPPING #-}
439+ ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
440+ FramingUnrender framing, FromSourceIO chunk a,
441+ BuildHeadersTo hs
442+ ) => HasClient m (Stream method status framing ct (Headers hs a)) where
443+
444+ type Client m (Stream method status framing ct (Headers hs a)) = m (Headers hs a)
333445
334446 hoistClientMonad _ _ f ma = f ma
335447
448+ clientWithRoute _pm Proxy req = withStreamingRequest req' $ \gres -> do
449+ let mimeUnrender' = mimeUnrender (Proxy :: Proxy ct) :: BL.ByteString -> Either String chunk
450+ framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender'
451+ val = fromSourceIO $ framingUnrender' $ responseBody gres
452+ return $ Headers
453+ { getResponse = val
454+ , getHeadersHList = buildHeadersTo . toList $ responseHeaders gres
455+ }
456+
457+ where
458+ req' = req
459+ { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
460+ , requestMethod = reflectMethod (Proxy :: Proxy method)
461+ }
462+
336463-- | If you use a 'Header' in one of your endpoints in your API,
337464-- the corresponding querying function will automatically take
338465-- an additional argument of the type specified by your 'Header',
@@ -442,7 +569,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
442569 (Proxy :: Proxy mods) add (maybe req add) mparam
443570 where
444571 add :: a -> Request
445− add param = appendToQueryString pname (Just $ toQueryParam param) req
572+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
446573
447574 pname :: Text
448575 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -491,7 +618,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
491618 )
492619
493620 where pname = pack $ symbolVal (Proxy :: Proxy sym)
494− paramlist' = map (Just . toQueryParam) paramlist
621+ paramlist' = map (Just . encodeQueryParamValue) paramlist
495622
496623 hoistClientMonad pm _ f cl = \as ->
497624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@@ -583,6 +710,28 @@ instance (MimeRender ct a, HasClient m api)
583710 hoistClientMonad pm _ f cl = \a ->
584711 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
585712
713+instance
714+ ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a
715+ ) => HasClient m (StreamBody' mods framing ctype a :> api)
716+ where
717+
718+ type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api
719+
720+ hoistClientMonad pm _ f cl = \a ->
721+ hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
722+
723+ clientWithRoute pm Proxy req body
724+ = clientWithRoute pm (Proxy :: Proxy api)
725+ $ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req
726+ where
727+ ctypeP = Proxy :: Proxy ctype
728+ framingP = Proxy :: Proxy framing
729+
730+ sourceIO = framingRender
731+ framingP
732+ (mimeRender ctypeP :: chunk -> BL.ByteString)
733+ (toSourceIO body)
734+
586735-- | Make the querying function append @path@ to the request path.
587736instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
588737 type Client m (path :> api) = Client m api
@@ -591,7 +740,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
591740 clientWithRoute pm (Proxy :: Proxy api)
592741 (appendToPath p req)
593742
594− where p = pack $ symbolVal (Proxy :: Proxy path)
743+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
595744
596745 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
597746
@@ -638,6 +787,29 @@ instance ( HasClient m api
638787 hoistClientMonad pm _ f cl = \authreq ->
639788 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
640789
790+-- | Ignore @'Fragment'@ in client functions.
791+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
792+--
793+-- Example:
794+--
795+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
796+-- >
797+-- > myApi :: Proxy MyApi
798+-- > myApi = Proxy
799+-- >
800+-- > getBooks :: ClientM [Book]
801+-- > getBooks = client myApi
802+-- > -- then you can just use "getBooksBy" to query that endpoint.
803+-- > -- 'getBooks' for all books.
804+instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
805+ ) => HasClient m (Fragment a :> api) where
806+
807+ type Client m (Fragment a :> api) = Client m api
808+
809+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
810+
811+ hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
812+
641813-- * Basic Authentication
642814
643815instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
@@ -649,6 +821,120 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
649821 hoistClientMonad pm _ f cl = \bauth ->
650822 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
651823
824+-- | A type that specifies that an API record contains a client implementation.
825+data AsClientT (m :: * -> *)
826+instance GenericMode (AsClientT m) where
827+ type AsClientT m :- api = Client m api
828+
829+
830+type GClientConstraints api m =
831+ ( GenericServant api (AsClientT m)
832+ , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
833+ )
834+
835+class GClient (api :: * -> *) m where
836+ gClientProof :: Dict (GClientConstraints api m)
837+
838+instance GClientConstraints api m => GClient api m where
839+ gClientProof = Dict
840+
841+instance
842+ ( forall n. GClient api n
843+ , HasClient m (ToServantApi api)
844+ , RunClient m
845+ )
846+ => HasClient m (NamedRoutes api) where
847+ type Client m (NamedRoutes api) = api (AsClientT m)
848+
849+ clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
850+ clientWithRoute pm _ request =
851+ case gClientProof @api @m of
852+ Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
853+
854+ hoistClientMonad
855+ :: forall ma mb.
856+ Proxy m
857+ -> Proxy (NamedRoutes api)
858+ -> (forall x. ma x -> mb x)
859+ -> Client ma (NamedRoutes api)
860+ -> Client mb (NamedRoutes api)
861+ hoistClientMonad _ _ nat clientA =
862+ case (gClientProof @api @ma, gClientProof @api @mb) of
863+ (Dict, Dict) ->
864+ fromServant @api @(AsClientT mb) $
865+ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
866+ toServant @api @(AsClientT ma) clientA
867+
868+infixl 1 //
869+infixl 2 /:
870+
871+-- | Helper to make code using records of clients more readable.
872+--
873+-- Can be mixed with (/:) for supplying arguments.
874+--
875+-- Example:
876+--
877+-- @
878+-- type Api = NamedRoutes RootApi
879+--
880+-- data RootApi mode = RootApi
881+-- { subApi :: mode :- NamedRoutes SubApi
882+-- , …
883+-- } deriving Generic
884+--
885+-- data SubApi mode = SubApi
886+-- { endpoint :: mode :- Get '[JSON] Person
887+-- , …
888+-- } deriving Generic
889+--
890+-- api :: Proxy API
891+-- api = Proxy
892+--
893+-- rootClient :: RootApi (AsClientT ClientM)
894+-- rootClient = client api
895+--
896+-- endpointClient :: ClientM Person
897+-- endpointClient = client // subApi // endpoint
898+-- @
899+(//) :: a -> (a -> b) -> b
900+x // f = f x
901+
902+-- | Convenience function for supplying arguments to client functions when
903+-- working with records of clients.
904+--
905+-- Intended to be used in conjunction with '(//)'.
906+--
907+-- Example:
908+--
909+-- @
910+-- type Api = NamedRoutes RootApi
911+--
912+-- data RootApi mode = RootApi
913+-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
914+-- , hello :: mode :- Capture "name" String :> Get '[JSON] String
915+-- , …
916+-- } deriving Generic
917+--
918+-- data SubApi mode = SubApi
919+-- { endpoint :: mode :- Get '[JSON] Person
920+-- , …
921+-- } deriving Generic
922+--
923+-- api :: Proxy API
924+-- api = Proxy
925+--
926+-- rootClient :: RootApi (AsClientT ClientM)
927+-- rootClient = client api
928+--
929+-- hello :: String -> ClientM String
930+-- hello name = rootClient // hello /: name
931+--
932+-- endpointClient :: ClientM Person
933+-- endpointClient = client // subApi /: "foobar123" // endpoint
934+-- @
935+(/:) :: (a -> b -> c) -> b -> a -> c
936+(/:) = flip
937+
652938
653939{- Note [Non-Empty Content Types]
654940~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -665,3 +951,43 @@ non-empty lists, but is otherwise more specific, no instance will be overall
665951more specific. This in turn generally means adding yet another instance (one
666952for empty and one for non-empty lists).
667953-}
954+
955+-------------------------------------------------------------------------------
956+-- helpers
957+-------------------------------------------------------------------------------
958+
959+checkContentTypeHeader :: RunClient m => Response -> m MediaType
960+checkContentTypeHeader response =
961+ case lookup "Content-Type" $ toList $ responseHeaders response of
962+ Nothing -> return $ "application" Media.// "octet-stream"
963+ Just t -> case parseAccept t of
964+ Nothing -> throwClientError $ InvalidContentTypeHeader response
965+ Just t' -> return t'
966+
967+decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
968+ => Response -> Proxy ct -> m a
969+decodedAs response ct = do
970+ responseContentType <- checkContentTypeHeader response
971+ unless (any (matches responseContentType) accept) $
972+ throwClientError $ UnsupportedContentType responseContentType response
973+ case mimeUnrender ct $ responseBody response of
974+ Left err -> throwClientError $ DecodeFailure (T.pack err) response
975+ Right val -> return val
976+ where
977+ accept = toList $ contentTypes ct
978+
979+-------------------------------------------------------------------------------
980+-- Custom type errors
981+-------------------------------------------------------------------------------
982+
983+-- Erroring instance for HasClient' when a combinator is not fully applied
984+instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)
985+ where
986+ type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)
987+ clientWithRoute _ _ _ = error "unreachable"
988+ hoistClientMonad _ _ _ _ = error "unreachable"
989+
990+-- Erroring instances for 'HasClient' for unknown API combinators
991+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)
992+
993+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api