@@ -1,4 +1,4 @@
1−{-# LANGUAGE ConstraintKinds #-}
1+{-# LANGUAGE CPP #-}
22{-# LANGUAGE DataKinds #-}
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
@@ -6,99 +6,68 @@
66{-# LANGUAGE MultiParamTypeClasses #-}
77{-# LANGUAGE OverloadedStrings #-}
88{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE QuantifiedConstraints #-}
109{-# LANGUAGE RankNTypes #-}
1110{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeApplications #-}
1311{-# LANGUAGE TypeFamilies #-}
1412{-# LANGUAGE TypeOperators #-}
1513{-# LANGUAGE UndecidableInstances #-}
1614
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 ()
15+#include "overlapping-compat.h"
16+module Servant.Client.Core.Internal.HasClient where
17+
18+import Prelude ()
2919import Prelude.Compat
3020
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, 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)
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
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
10271
10372-- * Accessing APIs as a Client
10473
@@ -208,7 +177,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
208177 clientWithRoute pm (Proxy :: Proxy api)
209178 (appendToPath p req)
210179
211− where p = toEncodedUrlPiece val
180+ where p = (toUrlPiece val)
212181
213182 hoistClientMonad pm _ f cl = \a ->
214183 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@@ -243,19 +212,18 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
243212 clientWithRoute pm (Proxy :: Proxy sublayout)
244213 (foldl' (flip appendToPath) req ps)
245214
246− where ps = map toEncodedUrlPiece vals
215+ where ps = map (toUrlPiece) vals
247216
248217 hoistClientMonad pm _ f cl = \as ->
249218 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
250219
251−instance {-# OVERLAPPABLE #-}
220+instance OVERLAPPABLE_
252221 -- Note [Non-Empty Content Types]
253222 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
254− , KnownNat status
255223 ) => HasClient m (Verb method status cts' a) where
256224 type Client m (Verb method status cts' a) = m a
257225 clientWithRoute _pm Proxy req = do
258− response <- runRequestAcceptStatus (Just [status]) req
226+ response <- runRequest req
259227 { requestAccept = fromList $ toList accept
260228 , requestMethod = method
261229 }
@@ -263,27 +231,14 @@ instance {-# OVERLAPPABLE #-}
263231 where
264232 accept = contentTypes (Proxy :: Proxy ct)
265233 method = reflectMethod (Proxy :: Proxy method)
266− status = statusFromNat (Proxy :: Proxy status)
267234
268235 hoistClientMonad _ _ f ma = f ma
269236
270−instance {-# OVERLAPPING #-}
271− ( RunClient m, ReflectMethod method, KnownNat status
237+instance OVERLAPPING_
238+ ( RunClient m, ReflectMethod method
272239 ) => HasClient m (Verb method status cts NoContent) where
273240 type Client m (Verb method status cts NoContent)
274241 = 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
287242 clientWithRoute _pm Proxy req = do
288243 _response <- runRequest req { requestMethod = method }
289244 return NoContent
@@ -291,175 +246,93 @@ instance (RunClient m, ReflectMethod method) =>
291246
292247 hoistClientMonad _ _ f ma = f ma
293248
294−instance {-# OVERLAPPING #-}
249+instance OVERLAPPING_
295250 -- Note [Non-Empty Content Types]
296− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
251+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
297252 , ReflectMethod method, cts' ~ (ct ': cts)
298253 ) => HasClient m (Verb method status cts' (Headers ls a)) where
299254 type Client m (Verb method status cts' (Headers ls a))
300255 = m (Headers ls a)
301256 clientWithRoute _pm Proxy req = do
302− response <- runRequestAcceptStatus (Just [status]) req
257+ response <- runRequest req
303258 { requestMethod = method
304259 , requestAccept = fromList $ toList accept
305260 }
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)
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)
314269
315270 hoistClientMonad _ _ f ma = f ma
316271
317−instance {-# OVERLAPPING #-}
318− ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
272+instance OVERLAPPING_
273+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method
319274 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
320275 type Client m (Verb method status cts (Headers ls NoContent))
321276 = m (Headers ls NoContent)
322277 clientWithRoute _pm Proxy req = do
323− response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
278+ let method = reflectMethod (Proxy :: Proxy method)
279+ response <- runRequest req { requestMethod = method }
324280 return $ Headers { getResponse = NoContent
325281 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
326282 }
327− where
328− method = reflectMethod (Proxy :: Proxy method)
329− status = statusFromNat (Proxy :: Proxy status)
330−
331− hoistClientMonad _ _ f ma = f ma
332−
333−data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
334− deriving (Eq, Show)
335−
336−class UnrenderResponse (cts :: [*]) (a :: *) where
337− unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts
338− -> [Either (MediaType, String) a]
339−
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
425283
426284 hoistClientMonad _ _ f ma = f ma
427285
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− }
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
437290
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
291+ type Client m (Stream method status framing ct b) = m b
443292
444− type Client m (Stream method status framing ct (Headers hs a)) = m (Headers hs a)
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
445333
446334 hoistClientMonad _ _ f ma = f ma
447335
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−
463336-- | If you use a 'Header' in one of your endpoints in your API,
464337-- the corresponding querying function will automatically take
465338-- an additional argument of the type specified by your 'Header',
@@ -569,7 +442,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
569442 (Proxy :: Proxy mods) add (maybe req add) mparam
570443 where
571444 add :: a -> Request
572− add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
445+ add param = appendToQueryString pname (Just $ toQueryParam param) req
573446
574447 pname :: Text
575448 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -618,7 +491,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
618491 )
619492
620493 where pname = pack $ symbolVal (Proxy :: Proxy sym)
621− paramlist' = map (Just . encodeQueryParamValue) paramlist
494+ paramlist' = map (Just . toQueryParam) paramlist
622495
623496 hoistClientMonad pm _ f cl = \as ->
624497 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@@ -674,16 +547,6 @@ instance RunClient m => HasClient m Raw where
674547
675548 hoistClientMonad _ _ f cl = \meth -> f (cl meth)
676549
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−
687550-- | If you use a 'ReqBody' in one of your endpoints in your API,
688551-- the corresponding querying function will automatically take
689552-- an additional argument of the type specified by your 'ReqBody'.
@@ -720,28 +583,6 @@ instance (MimeRender ct a, HasClient m api)
720583 hoistClientMonad pm _ f cl = \a ->
721584 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
722585
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−
745586-- | Make the querying function append @path@ to the request path.
746587instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
747588 type Client m (path :> api) = Client m api
@@ -750,7 +591,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
750591 clientWithRoute pm (Proxy :: Proxy api)
751592 (appendToPath p req)
752593
753− where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
594+ where p = pack $ symbolVal (Proxy :: Proxy path)
754595
755596 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
756597
@@ -786,14 +627,6 @@ instance HasClient m subapi =>
786627
787628 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy subapi) f cl
788629
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−
797630instance ( HasClient m api
798631 ) => HasClient m (AuthProtect tag :> api) where
799632 type Client m (AuthProtect tag :> api)
@@ -805,29 +638,6 @@ instance ( HasClient m api
805638 hoistClientMonad pm _ f cl = \authreq ->
806639 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
807640
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−
831641-- * Basic Authentication
832642
833643instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
@@ -839,120 +649,6 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
839649 hoistClientMonad pm _ f cl = \bauth ->
840650 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
841651
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−
956652
957653{- Note [Non-Empty Content Types]
958654~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -969,43 +665,3 @@ non-empty lists, but is otherwise more specific, no instance will be overall
969665more specific. This in turn generally means adding yet another instance (one
970666for empty and one for non-empty lists).
971667-}
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