@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE ConstraintKinds #-}
22{-# LANGUAGE DataKinds #-}
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
@@ -6,60 +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+module Servant.Client.Core.HasClient (
18+ clientIn,
19+ HasClient (..),
20+ EmptyClient (..),
21+ AsClientT,
22+ (//),
23+ (/:),
24+ foldMapUnion,
25+ matchUnion,
26+ ) where
1727
1828import Prelude ()
1929import Prelude.Compat
2030
21−import Control.Concurrent
22− (modifyMVar, newMVar)
23−import Control.Monad.IO.Class
24− (MonadIO (..))
25−import qualified Data.ByteString.Lazy as BL
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(..))
2640import Data.Foldable
2741 (toList)
2842import Data.List
2943 (foldl')
30−import Data.Proxy
31− (Proxy (Proxy))
32−import Data.Semigroup
33− ((<>))
3444import Data.Sequence
3545 (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))
3659import Data.String
3760 (fromString)
3861import Data.Text
3962 (Text, pack)
63+import Data.Proxy
64+ (Proxy (Proxy))
4065import GHC.TypeLits
41− (KnownSymbol, symbolVal)
42−import qualified Network.HTTP.Types as H
66+ (KnownNat, KnownSymbol, TypeError, symbolVal)
67+import Network.HTTP.Types
68+ (Status)
69+import qualified Network.HTTP.Types as H
4370import Servant.API
4471 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
45− BuildHeadersTo (..), ByteStringParser (..), Capture',
46− CaptureAll, Description, EmptyAPI, FramingUnrender (..),
47− FromResultStream (..), Header', Headers (..), HttpVersion,
72+ BuildHeadersTo (..), Capture', CaptureAll, Description,
73+ EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
74+ FromSourceIO (..), Header', Headers (..), HttpVersion,
4875 IsSecure, MimeRender (mimeRender),
49− MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
50− QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
51− ReqBody', ResultStream (..), SBoolI, Stream, Summary,
52− ToHttpApiData, Vault, Verb, WithNamedContext, contentType,
53− getHeadersHList, getResponse, toQueryParam, toUrlPiece)
76+ MimeUnrender (mimeUnrender), NoContent (NoContent),
77+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw, RawM,
78+ ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
79+ StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
80+ Verb, WithNamedContext, WithResource, WithStatus (..), contentType, getHeadersHList,
81+ getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
82+import Servant.API.Generic
83+ (GenericMode(..), ToServant, ToServantApi
84+ , GenericServant, toServant, fromServant)
5485import Servant.API.ContentTypes
55− (contentTypes)
86+ (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
87+import Servant.API.Status
88+ (statusFromNat)
89+import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
5690import Servant.API.Modifiers
5791 (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)
5895
59−import Servant.Client.Core.Internal.Auth
60−import Servant.Client.Core.Internal.BasicAuth
61−import Servant.Client.Core.Internal.Request
62−import Servant.Client.Core.Internal.RunClient
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
63102
64103-- * Accessing APIs as a Client
65104
@@ -169,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
169208 clientWithRoute pm (Proxy :: Proxy api)
170209 (appendToPath p req)
171210
172− where p = (toUrlPiece val)
211+ where p = toEncodedUrlPiece val
173212
174213 hoistClientMonad pm _ f cl = \a ->
175214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@@ -204,18 +243,19 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
204243 clientWithRoute pm (Proxy :: Proxy sublayout)
205244 (foldl' (flip appendToPath) req ps)
206245
207− where ps = map (toUrlPiece) vals
246+ where ps = map toEncodedUrlPiece vals
208247
209248 hoistClientMonad pm _ f cl = \as ->
210249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
211250
212−instance OVERLAPPABLE_
251+instance {-# OVERLAPPABLE #-}
213252 -- Note [Non-Empty Content Types]
214253 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
254+ , KnownNat status
215255 ) => HasClient m (Verb method status cts' a) where
216256 type Client m (Verb method status cts' a) = m a
217257 clientWithRoute _pm Proxy req = do
218− response <- runRequest req
258+ response <- runRequestAcceptStatus (Just [status]) req
219259 { requestAccept = fromList $ toList accept
220260 , requestMethod = method
221261 }
@@ -223,14 +263,27 @@ instance OVERLAPPABLE_
223263 where
224264 accept = contentTypes (Proxy :: Proxy ct)
225265 method = reflectMethod (Proxy :: Proxy method)
266+ status = statusFromNat (Proxy :: Proxy status)
226267
227268 hoistClientMonad _ _ f ma = f ma
228269
229−instance OVERLAPPING_
230− ( RunClient m, ReflectMethod method
270+instance {-# OVERLAPPING #-}
271+ ( RunClient m, ReflectMethod method, KnownNat status
231272 ) => HasClient m (Verb method status cts NoContent) where
232273 type Client m (Verb method status cts NoContent)
233274 = 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
234287 clientWithRoute _pm Proxy req = do
235288 _response <- runRequest req { requestMethod = method }
236289 return NoContent
@@ -238,93 +291,175 @@ instance OVERLAPPING_
238291
239292 hoistClientMonad _ _ f ma = f ma
240293
241−instance OVERLAPPING_
294+instance {-# OVERLAPPING #-}
242295 -- Note [Non-Empty Content Types]
243− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
296+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
244297 , ReflectMethod method, cts' ~ (ct ': cts)
245298 ) => HasClient m (Verb method status cts' (Headers ls a)) where
246299 type Client m (Verb method status cts' (Headers ls a))
247300 = m (Headers ls a)
248301 clientWithRoute _pm Proxy req = do
249− response <- runRequest req
302+ response <- runRequestAcceptStatus (Just [status]) req
250303 { requestMethod = method
251304 , requestAccept = fromList $ toList accept
252305 }
253− case mimeUnrender (Proxy :: Proxy ct) $ responseBody response of
254− Left err -> throwServantError $ DecodeFailure (pack err) response
255− Right val -> return $ Headers
256− { getResponse = val
257− , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
258− }
259− where method = reflectMethod (Proxy :: Proxy method)
260− 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)
261314
262315 hoistClientMonad _ _ f ma = f ma
263316
264−instance OVERLAPPING_
265− ( RunClient m, BuildHeadersTo ls, ReflectMethod method
317+instance {-# OVERLAPPING #-}
318+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
266319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
267320 type Client m (Verb method status cts (Headers ls NoContent))
268321 = m (Headers ls NoContent)
269322 clientWithRoute _pm Proxy req = do
270− let method = reflectMethod (Proxy :: Proxy method)
271− response <- runRequest req { requestMethod = method }
323+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
272324 return $ Headers { getResponse = NoContent
273325 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
274326 }
327+ where
328+ method = reflectMethod (Proxy :: Proxy method)
329+ status = statusFromNat (Proxy :: Proxy status)
275330
276331 hoistClientMonad _ _ f ma = f ma
277332
278−instance OVERLAPPABLE_
279− ( RunClient m, MonadIO m, MimeUnrender ct a, ReflectMethod method,
280− FramingUnrender framing a, FromResultStream a b
281− ) => HasClient m (Stream method status framing ct b) where
333+data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
334+ deriving (Eq, Show)
282335
283− 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]
284339
285− clientWithRoute _pm Proxy req = do
286− sresp <- streamingRequest req
287− { requestAccept = fromList [contentType (Proxy :: Proxy ct)]
288− , requestMethod = reflectMethod (Proxy :: Proxy method)
289− }
290− liftIO $ fromResultStream $ ResultStream $ \k ->
291− runStreamingResponse sresp $ \gres -> do
292− let reader = responseBody gres
293− let unrender = unrenderFrames (Proxy :: Proxy framing) (Proxy :: Proxy a)
294− loop bs = do
295− res <- BL.fromStrict <$> reader
296− if BL.null res
297− then return $ parseEOF unrender res
298− else let sofar = (bs <> res)
299− in case parseIncremental unrender sofar of
300− Just x -> return x
301− Nothing -> loop sofar
302− (frameParser, remainder) <- loop BL.empty
303− state <- newMVar remainder
304− let frameLoop bs = do
305− res <- BL.fromStrict <$> reader
306− let addIsEmptyInfo (a, r) = (r, (a, BL.null r && BL.null res))
307− if BL.null res
308− then if BL.null bs
309− then return ("", (Right "", True))
310− else return . addIsEmptyInfo $ parseEOF frameParser bs
311− else let sofar = (bs <> res)
312− in case parseIncremental frameParser sofar of
313− Just x -> return $ addIsEmptyInfo x
314− Nothing -> frameLoop sofar
315−
316− go = processResult <$> modifyMVar state frameLoop
317− processResult (Right bs,isDone) =
318− if BL.null bs && isDone
319− then Nothing
320− else Just $ case mimeUnrender (Proxy :: Proxy ct) bs :: Either String a of
321− Left err -> Left err
322− Right x -> Right x
323− processResult (Left err, _) = Just (Left err)
324− 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)
325445
326446 hoistClientMonad _ _ f ma = f ma
327447
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+
328463-- | If you use a 'Header' in one of your endpoints in your API,
329464-- the corresponding querying function will automatically take
330465-- an additional argument of the type specified by your 'Header',
@@ -434,7 +569,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
434569 (Proxy :: Proxy mods) add (maybe req add) mparam
435570 where
436571 add :: a -> Request
437− add param = appendToQueryString pname (Just $ toQueryParam param) req
572+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
438573
439574 pname :: Text
440575 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -483,7 +618,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
483618 )
484619
485620 where pname = pack $ symbolVal (Proxy :: Proxy sym)
486− paramlist' = map (Just . toQueryParam) paramlist
621+ paramlist' = map (Just . encodeQueryParamValue) paramlist
487622
488623 hoistClientMonad pm _ f cl = \as ->
489624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@@ -539,6 +674,16 @@ instance RunClient m => HasClient m Raw where
539674
540675 hoistClientMonad _ _ f cl = \meth -> f (cl meth)
541676
677+instance RunClient m => HasClient m RawM where
678+ type Client m RawM
679+ = H.Method -> m Response
680+
681+ clientWithRoute :: Proxy m -> Proxy RawM -> Request -> Client m RawM
682+ clientWithRoute _pm Proxy req httpMethod = do
683+ runRequest req { requestMethod = httpMethod }
684+
685+ hoistClientMonad _ _ f cl = \meth -> f (cl meth)
686+
542687-- | If you use a 'ReqBody' in one of your endpoints in your API,
543688-- the corresponding querying function will automatically take
544689-- an additional argument of the type specified by your 'ReqBody'.
@@ -575,6 +720,28 @@ instance (MimeRender ct a, HasClient m api)
575720 hoistClientMonad pm _ f cl = \a ->
576721 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
577722
723+instance
724+ ( HasClient m api, MimeRender ctype chunk, FramingRender framing, ToSourceIO chunk a
725+ ) => HasClient m (StreamBody' mods framing ctype a :> api)
726+ where
727+
728+ type Client m (StreamBody' mods framing ctype a :> api) = a -> Client m api
729+
730+ hoistClientMonad pm _ f cl = \a ->
731+ hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
732+
733+ clientWithRoute pm Proxy req body
734+ = clientWithRoute pm (Proxy :: Proxy api)
735+ $ setRequestBody (RequestBodySource sourceIO) (contentType ctypeP) req
736+ where
737+ ctypeP = Proxy :: Proxy ctype
738+ framingP = Proxy :: Proxy framing
739+
740+ sourceIO = framingRender
741+ framingP
742+ (mimeRender ctypeP :: chunk -> BL.ByteString)
743+ (toSourceIO body)
744+
578745-- | Make the querying function append @path@ to the request path.
579746instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
580747 type Client m (path :> api) = Client m api
@@ -583,7 +750,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
583750 clientWithRoute pm (Proxy :: Proxy api)
584751 (appendToPath p req)
585752
586− where p = pack $ symbolVal (Proxy :: Proxy path)
753+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
587754
588755 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
589756
@@ -619,6 +786,14 @@ instance HasClient m subapi =>
619786
620787 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
621788
789+instance HasClient m subapi =>
790+ HasClient m (WithResource res :> subapi) where
791+
792+ type Client m (WithResource res :> subapi) = Client m subapi
793+ clientWithRoute pm Proxy = clientWithRoute pm (Proxy :: Proxy subapi)
794+
795+ hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
796+
622797instance ( HasClient m api
623798 ) => HasClient m (AuthProtect tag :> api) where
624799 type Client m (AuthProtect tag :> api)
@@ -630,6 +805,29 @@ instance ( HasClient m api
630805 hoistClientMonad pm _ f cl = \authreq ->
631806 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
632807
808+-- | Ignore @'Fragment'@ in client functions.
809+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
810+--
811+-- Example:
812+--
813+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
814+-- >
815+-- > myApi :: Proxy MyApi
816+-- > myApi = Proxy
817+-- >
818+-- > getBooks :: ClientM [Book]
819+-- > getBooks = client myApi
820+-- > -- then you can just use "getBooksBy" to query that endpoint.
821+-- > -- 'getBooks' for all books.
822+instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
823+ ) => HasClient m (Fragment a :> api) where
824+
825+ type Client m (Fragment a :> api) = Client m api
826+
827+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
828+
829+ hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
830+
633831-- * Basic Authentication
634832
635833instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
@@ -641,6 +839,120 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
641839 hoistClientMonad pm _ f cl = \bauth ->
642840 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
643841
842+-- | A type that specifies that an API record contains a client implementation.
843+data AsClientT (m :: * -> *)
844+instance GenericMode (AsClientT m) where
845+ type AsClientT m :- api = Client m api
846+
847+
848+type GClientConstraints api m =
849+ ( GenericServant api (AsClientT m)
850+ , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
851+ )
852+
853+class GClient (api :: * -> *) m where
854+ gClientProof :: Dict (GClientConstraints api m)
855+
856+instance GClientConstraints api m => GClient api m where
857+ gClientProof = Dict
858+
859+instance
860+ ( forall n. GClient api n
861+ , HasClient m (ToServantApi api)
862+ , RunClient m
863+ )
864+ => HasClient m (NamedRoutes api) where
865+ type Client m (NamedRoutes api) = api (AsClientT m)
866+
867+ clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
868+ clientWithRoute pm _ request =
869+ case gClientProof @api @m of
870+ Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
871+
872+ hoistClientMonad
873+ :: forall ma mb.
874+ Proxy m
875+ -> Proxy (NamedRoutes api)
876+ -> (forall x. ma x -> mb x)
877+ -> Client ma (NamedRoutes api)
878+ -> Client mb (NamedRoutes api)
879+ hoistClientMonad _ _ nat clientA =
880+ case (gClientProof @api @ma, gClientProof @api @mb) of
881+ (Dict, Dict) ->
882+ fromServant @api @(AsClientT mb) $
883+ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
884+ toServant @api @(AsClientT ma) clientA
885+
886+infixl 1 //
887+infixl 2 /:
888+
889+-- | Helper to make code using records of clients more readable.
890+--
891+-- Can be mixed with (/:) for supplying arguments.
892+--
893+-- Example:
894+--
895+-- @
896+-- type Api = NamedRoutes RootApi
897+--
898+-- data RootApi mode = RootApi
899+-- { subApi :: mode :- NamedRoutes SubApi
900+-- , …
901+-- } deriving Generic
902+--
903+-- data SubApi mode = SubApi
904+-- { endpoint :: mode :- Get '[JSON] Person
905+-- , …
906+-- } deriving Generic
907+--
908+-- api :: Proxy API
909+-- api = Proxy
910+--
911+-- rootClient :: RootApi (AsClientT ClientM)
912+-- rootClient = client api
913+--
914+-- endpointClient :: ClientM Person
915+-- endpointClient = client \/\/ subApi \/\/ endpoint
916+-- @
917+(//) :: a -> (a -> b) -> b
918+x // f = f x
919+
920+-- | Convenience function for supplying arguments to client functions when
921+-- working with records of clients.
922+--
923+-- Intended to be used in conjunction with '(//)'.
924+--
925+-- Example:
926+--
927+-- @
928+-- type Api = NamedRoutes RootApi
929+--
930+-- data RootApi mode = RootApi
931+-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
932+-- , hello :: mode :- Capture "name" String :> Get '[JSON] String
933+-- , …
934+-- } deriving Generic
935+--
936+-- data SubApi mode = SubApi
937+-- { endpoint :: mode :- Get '[JSON] Person
938+-- , …
939+-- } deriving Generic
940+--
941+-- api :: Proxy API
942+-- api = Proxy
943+--
944+-- rootClient :: RootApi (AsClientT ClientM)
945+-- rootClient = client api
946+--
947+-- hello :: String -> ClientM String
948+-- hello name = rootClient \/\/ hello \/: name
949+--
950+-- endpointClient :: ClientM Person
951+-- endpointClient = client \/\/ subApi \/: "foobar123" \/\/ endpoint
952+-- @
953+(/:) :: (a -> b -> c) -> b -> a -> c
954+(/:) = flip
955+
644956
645957{- Note [Non-Empty Content Types]
646958~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -657,3 +969,43 @@ non-empty lists, but is otherwise more specific, no instance will be overall
657969more specific. This in turn generally means adding yet another instance (one
658970for empty and one for non-empty lists).
659971-}
972+
973+-------------------------------------------------------------------------------
974+-- helpers
975+-------------------------------------------------------------------------------
976+
977+checkContentTypeHeader :: RunClient m => Response -> m MediaType
978+checkContentTypeHeader response =
979+ case lookup "Content-Type" $ toList $ responseHeaders response of
980+ Nothing -> return $ "application" Media.// "octet-stream"
981+ Just t -> case parseAccept t of
982+ Nothing -> throwClientError $ InvalidContentTypeHeader response
983+ Just t' -> return t'
984+
985+decodedAs :: forall ct a m. (MimeUnrender ct a, RunClient m)
986+ => Response -> Proxy ct -> m a
987+decodedAs response ct = do
988+ responseContentType <- checkContentTypeHeader response
989+ unless (any (matches responseContentType) accept) $
990+ throwClientError $ UnsupportedContentType responseContentType response
991+ case mimeUnrender ct $ responseBody response of
992+ Left err -> throwClientError $ DecodeFailure (T.pack err) response
993+ Right val -> return val
994+ where
995+ accept = toList $ contentTypes ct
996+
997+-------------------------------------------------------------------------------
998+-- Custom type errors
999+-------------------------------------------------------------------------------
1000+
1001+-- Erroring instance for HasClient' when a combinator is not fully applied
1002+instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)
1003+ where
1004+ type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)
1005+ clientWithRoute _ _ _ = error "unreachable"
1006+ hoistClientMonad _ _ _ _ = error "unreachable"
1007+
1008+-- Erroring instances for 'HasClient' for unknown API combinators
1009+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)
1010+
1011+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api