@@ -1,3 +1,4 @@
1+{-# LANGUAGE ConstraintKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
@@ -5,8 +6,10 @@
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE PolyKinds #-}
8{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE QuantifiedConstraints #-}
8{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeApplications #-}
10{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
@@ -15,48 +18,80 @@ module Servant.Client.Core.HasClient (
16 HasClient (..),
19 HasClient (..),
17 EmptyClient (..),
20 EmptyClient (..),
20import Prelude ()
28import Prelude ()
21import Prelude.Compat
29import Prelude.Compat
23import Control.Monad
33import Control.Monad
25−import qualified Data.ByteString.Lazy as BL
35+import qualified Data.ByteString as BS
36+import qualified Data.ByteString.Lazy as BL
39+import Data.Constraint (Dict(..))
26import Data.Foldable
40import Data.Foldable
28import Data.List
42import Data.List
32import Data.Sequence
44import Data.Sequence
33 (fromList)
45 (fromList)
34import qualified Data.Text as T
46import qualified Data.Text as T
35import Network.HTTP.Media
47import Network.HTTP.Media
36− (MediaType, matches, parseAccept, (//))
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
37import Data.String
59import Data.String
38 (fromString)
60 (fromString)
39import Data.Text
61import Data.Text
40 (Text, pack)
62 (Text, pack)
41import GHC.TypeLits
65import GHC.TypeLits
42− (KnownSymbol, symbolVal)
66+ (KnownNat, KnownSymbol, TypeError, symbolVal)
67+import Network.HTTP.Types
43import qualified Network.HTTP.Types as H
69import qualified Network.HTTP.Types as H
44import Servant.API
70import Servant.API
45 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
71 ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
46 BuildHeadersTo (..), Capture', CaptureAll, Description,
72 BuildHeadersTo (..), Capture', CaptureAll, Description,
47− EmptyAPI, FramingRender (..), FramingUnrender (..),
73+ EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..),
48 FromSourceIO (..), Header', Headers (..), HttpVersion,
74 FromSourceIO (..), Header', Headers (..), HttpVersion,
49 IsSecure, MimeRender (mimeRender),
75 IsSecure, MimeRender (mimeRender),
50− MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
76+ MimeUnrender (mimeUnrender), NoContent (NoContent),
51− QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
77+ NoContentVerb, QueryFlag, QueryParam', QueryParams, Raw,
78+ ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
52− ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData,
79+ StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
53− ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext,
54− contentType, getHeadersHList, getResponse, toQueryParam,
80+ Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
55− toUrlPiece)
81+ getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
82+import Servant.API.Generic
83+ (GenericMode(..), ToServant, ToServantApi
84+ , GenericServant, toServant, fromServant)
56import Servant.API.ContentTypes
85import Servant.API.ContentTypes
57− (contentTypes)
86+ (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
87+import Servant.API.Status
89+import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
58import Servant.API.Modifiers
90import Servant.API.Modifiers
59 (FoldRequired, RequiredArgument, foldRequiredArgument)
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)
61import Servant.Client.Core.Auth
96import Servant.Client.Core.Auth
62import Servant.Client.Core.BasicAuth
97import Servant.Client.Core.BasicAuth
@@ -173,7 +208,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
173 clientWithRoute pm (Proxy :: Proxy api)
208 clientWithRoute pm (Proxy :: Proxy api)
174 (appendToPath p req)
209 (appendToPath p req)
176− where p = (toUrlPiece val)
211+ where p = toEncodedUrlPiece val
178 hoistClientMonad pm _ f cl = \a ->
213 hoistClientMonad pm _ f cl = \a ->
179 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@@ -208,7 +243,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
208 clientWithRoute pm (Proxy :: Proxy sublayout)
243 clientWithRoute pm (Proxy :: Proxy sublayout)
209 (foldl' (flip appendToPath) req ps)
244 (foldl' (flip appendToPath) req ps)
211− where ps = map (toUrlPiece) vals
246+ where ps = map toEncodedUrlPiece vals
213 hoistClientMonad pm _ f cl = \as ->
248 hoistClientMonad pm _ f cl = \as ->
214 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
@@ -216,10 +251,11 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
216instance {-# OVERLAPPABLE #-}
251instance {-# OVERLAPPABLE #-}
217 -- Note [Non-Empty Content Types]
252 -- Note [Non-Empty Content Types]
218 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
253 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
219 ) => HasClient m (Verb method status cts' a) where
255 ) => HasClient m (Verb method status cts' a) where
220 type Client m (Verb method status cts' a) = m a
256 type Client m (Verb method status cts' a) = m a
221 clientWithRoute _pm Proxy req = do
257 clientWithRoute _pm Proxy req = do
222− response <- runRequest req
258+ response <- runRequestAcceptStatus (Just [status]) req
223 { requestAccept = fromList $ toList accept
259 { requestAccept = fromList $ toList accept
224 , requestMethod = method
260 , requestMethod = method
@@ -227,18 +263,20 @@ instance {-# OVERLAPPABLE #-}
228 accept = contentTypes (Proxy :: Proxy ct)
264 accept = contentTypes (Proxy :: Proxy ct)
229 method = reflectMethod (Proxy :: Proxy method)
265 method = reflectMethod (Proxy :: Proxy method)
266+ status = statusFromNat (Proxy :: Proxy status)
231 hoistClientMonad _ _ f ma = f ma
268 hoistClientMonad _ _ f ma = f ma
233instance {-# OVERLAPPING #-}
270instance {-# OVERLAPPING #-}
234− ( RunClient m, ReflectMethod method
271+ ( RunClient m, ReflectMethod method, KnownNat status
235 ) => HasClient m (Verb method status cts NoContent) where
272 ) => HasClient m (Verb method status cts NoContent) where
236 type Client m (Verb method status cts NoContent)
273 type Client m (Verb method status cts NoContent)
237 = m NoContent
274 = m NoContent
238 clientWithRoute _pm Proxy req = do
275 clientWithRoute _pm Proxy req = do
239− _response <- runRequest req { requestMethod = method }
276+ _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
240 return NoContent
277 return NoContent
241 where method = reflectMethod (Proxy :: Proxy method)
278 where method = reflectMethod (Proxy :: Proxy method)
279+ status = statusFromNat (Proxy :: Proxy status)
243 hoistClientMonad _ _ f ma = f ma
281 hoistClientMonad _ _ f ma = f ma
@@ -255,13 +293,13 @@ instance (RunClient m, ReflectMethod method) =>
256instance {-# OVERLAPPING #-}
294instance {-# OVERLAPPING #-}
257 -- Note [Non-Empty Content Types]
295 -- Note [Non-Empty Content Types]
258− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
296+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
259 , ReflectMethod method, cts' ~ (ct ': cts)
297 , ReflectMethod method, cts' ~ (ct ': cts)
260 ) => HasClient m (Verb method status cts' (Headers ls a)) where
298 ) => HasClient m (Verb method status cts' (Headers ls a)) where
261 type Client m (Verb method status cts' (Headers ls a))
299 type Client m (Verb method status cts' (Headers ls a))
262 = m (Headers ls a)
300 = m (Headers ls a)
263 clientWithRoute _pm Proxy req = do
301 clientWithRoute _pm Proxy req = do
264− response <- runRequest req
302+ response <- runRequestAcceptStatus (Just [status]) req
265 { requestMethod = method
303 { requestMethod = method
266 , requestAccept = fromList $ toList accept
304 , requestAccept = fromList $ toList accept
@@ -269,25 +307,115 @@ instance {-# OVERLAPPING #-}
269 return $ Headers { getResponse = val
307 return $ Headers { getResponse = val
270 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
308 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
272− where method = reflectMethod (Proxy :: Proxy method)
311+ method = reflectMethod (Proxy :: Proxy method)
273− accept = contentTypes (Proxy :: Proxy ct)
312+ accept = contentTypes (Proxy :: Proxy ct)
313+ status = statusFromNat (Proxy :: Proxy status)
275 hoistClientMonad _ _ f ma = f ma
315 hoistClientMonad _ _ f ma = f ma
277instance {-# OVERLAPPING #-}
317instance {-# OVERLAPPING #-}
278− ( RunClient m, BuildHeadersTo ls, ReflectMethod method
318+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
279 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
280 type Client m (Verb method status cts (Headers ls NoContent))
320 type Client m (Verb method status cts (Headers ls NoContent))
281 = m (Headers ls NoContent)
321 = m (Headers ls NoContent)
282 clientWithRoute _pm Proxy req = do
322 clientWithRoute _pm Proxy req = do
283− let method = reflectMethod (Proxy :: Proxy method)
284− response <- runRequest req { requestMethod = method }
323+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
285 return $ Headers { getResponse = NoContent
324 return $ Headers { getResponse = NoContent
286 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
325 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
328+ method = reflectMethod (Proxy :: Proxy method)
329+ status = statusFromNat (Proxy :: Proxy status)
289 hoistClientMonad _ _ f ma = f ma
331 hoistClientMonad _ _ f ma = f ma
333+data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
336+class UnrenderResponse (cts :: [*]) (a :: *) where
337+ unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts
338+ -> [Either (MediaType, String) a]
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)
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
348+ setHeaders :: a -> Headers h a
349+ setHeaders x = Headers x (buildHeadersTo (toList hs))
351+instance {-# OVERLAPPING #-} UnrenderResponse cts a
352+ => UnrenderResponse cts (WithStatus n a) where
353+ unrenderResponse hs body = (map . fmap) WithStatus . unrenderResponse hs body
355+instance {-# OVERLAPPING #-}
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.)
361+ AllMime contentTypes,
362+ ReflectMethod method,
363+ All (UnrenderResponse contentTypes) as,
364+ All HasStatus as, HasStatuses as',
365+ Unique (Statuses as)
367+ HasClient m (UVerb method contentTypes as)
369+ type Client m (UVerb method contentTypes as) = m (Union as)
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.
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
384+ let status = responseStatusCode response
385+ body = responseBody response
386+ headers = responseHeaders response
387+ res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body
389+ Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
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
405+ -- | Given a list of types, parses the given response body as each type
408+ All (UnrenderResponse cts) xs =>
412+ NP ([] :.: Either (MediaType, String)) xs
413+ mimeUnrenders ctp headers body = cpure_NP
414+ (Proxy @(UnrenderResponse cts))
415+ (Comp . unrenderResponse headers body $ ctp)
417+ hoistClientMonad _ _ nt s = nt s
291instance {-# OVERLAPPABLE #-}
419instance {-# OVERLAPPABLE #-}
292 ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
420 ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
293 FramingUnrender framing, FromSourceIO chunk a
421 FramingUnrender framing, FromSourceIO chunk a
@@ -441,7 +569,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
441 (Proxy :: Proxy mods) add (maybe req add) mparam
569 (Proxy :: Proxy mods) add (maybe req add) mparam
443 add :: a -> Request
571 add :: a -> Request
444− add param = appendToQueryString pname (Just $ toQueryParam param) req
572+ add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
446 pname :: Text
574 pname :: Text
447 pname = pack $ symbolVal (Proxy :: Proxy sym)
575 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -490,7 +618,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
492 where pname = pack $ symbolVal (Proxy :: Proxy sym)
620 where pname = pack $ symbolVal (Proxy :: Proxy sym)
493− paramlist' = map (Just . toQueryParam) paramlist
621+ paramlist' = map (Just . encodeQueryParamValue) paramlist
495 hoistClientMonad pm _ f cl = \as ->
623 hoistClientMonad pm _ f cl = \as ->
496 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@@ -612,7 +740,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
612 clientWithRoute pm (Proxy :: Proxy api)
740 clientWithRoute pm (Proxy :: Proxy api)
613 (appendToPath p req)
741 (appendToPath p req)
615− where p = pack $ symbolVal (Proxy :: Proxy path)
743+ where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
617 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
745 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
@@ -659,6 +787,29 @@ instance ( HasClient m api
659 hoistClientMonad pm _ f cl = \authreq ->
787 hoistClientMonad pm _ f cl = \authreq ->
660 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
788 hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq)
790+-- | Ignore @'Fragment'@ in client functions.
791+-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
795+-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
797+-- > myApi :: Proxy MyApi
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
807+ type Client m (Fragment a :> api) = Client m api
809+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
811+ hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
662-- * Basic Authentication
813-- * Basic Authentication
664instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
815instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
@@ -670,6 +821,119 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
670 hoistClientMonad pm _ f cl = \bauth ->
821 hoistClientMonad pm _ f cl = \bauth ->
671 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
822 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
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
830+type GClientConstraints api m =
831+ ( GenericServant api (AsClientT m)
832+ , Client m (ToServantApi api) ~ ToServant api (AsClientT m)
835+class GClient (api :: * -> *) m where
836+ gClientProof :: Dict (GClientConstraints api m)
838+instance GClientConstraints api m => GClient api m where
842+ ( forall n. GClient api n
843+ , HasClient m (ToServantApi api)
846+ => HasClient m (NamedRoutes api) where
847+ type Client m (NamedRoutes api) = api (AsClientT m)
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
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
864+ fromServant @api @(AsClientT mb) $
865+ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
866+ toServant @api @(AsClientT ma) clientA
871+-- | Helper to make code using records of clients more readable.
873+-- Can be mixed with (/:) for supplying arguments.
878+-- type Api = NamedRoutes RootApi
880+-- data RootApi mode = RootApi
881+-- { subApi :: mode :- NamedRoutes SubApi
883+-- } deriving Generic
885+-- data SubApi mode = SubApi
886+-- { endpoint :: mode :- Get '[JSON] Person
888+-- } deriving Generic
893+-- rootClient :: RootApi (AsClientT ClientM)
894+-- rootClient = client api
896+-- endpointClient :: ClientM Person
897+-- endpointClient = client // subApi // endpoint
899+(//) :: a -> (a -> b) -> b
902+-- | Convenience function for supplying arguments to client functions when
903+-- working with records of clients.
905+-- Intended to be used in conjunction with '(//)'.
910+-- type Api = NamedRoutes RootApi
912+-- data RootApi mode = RootApi
913+-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
914+-- , hello :: mode :- Capture "name" String :> Get '[JSON] String
916+-- } deriving Generic
918+-- data SubApi mode = SubApi
919+-- { endpoint :: mode :- Get '[JSON] Person
921+-- } deriving Generic
926+-- rootClient :: RootApi (AsClientT ClientM)
927+-- rootClient = client api
929+-- hello :: String -> ClientM String
930+-- hello name = rootClient // hello /: name
932+-- endpointClient :: ClientM Person
933+-- endpointClient = client // subApi /: "foobar123" // endpoint
935+(/:) :: (a -> b -> c) -> b -> a -> c
675{- Note [Non-Empty Content Types]
939{- Note [Non-Empty Content Types]
@@ -695,7 +959,7 @@ for empty and one for non-empty lists).
695checkContentTypeHeader :: RunClient m => Response -> m MediaType
959checkContentTypeHeader :: RunClient m => Response -> m MediaType
696checkContentTypeHeader response =
960checkContentTypeHeader response =
697 case lookup "Content-Type" $ toList $ responseHeaders response of
961 case lookup "Content-Type" $ toList $ responseHeaders response of
698− Nothing -> return $ "application"//"octet-stream"
962+ Nothing -> return $ "application" Media.// "octet-stream"
699 Just t -> case parseAccept t of
963 Just t -> case parseAccept t of
700 Nothing -> throwClientError $ InvalidContentTypeHeader response
964 Nothing -> throwClientError $ InvalidContentTypeHeader response
701 Just t' -> return t'
965 Just t' -> return t'
@@ -710,4 +974,20 @@ decodedAs response ct = do
710 Left err -> throwClientError $ DecodeFailure (T.pack err) response
974 Left err -> throwClientError $ DecodeFailure (T.pack err) response
711 Right val -> return val
975 Right val -> return val
713− accept = toList $ contentTypes ct
977+ accept = toList $ contentTypes ct
979+-------------------------------------------------------------------------------
980+-- Custom type errors
981+-------------------------------------------------------------------------------
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)
986+ type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)
987+ clientWithRoute _ _ _ = error "unreachable"
988+ hoistClientMonad _ _ _ _ = error "unreachable"
990+-- Erroring instances for 'HasClient' for unknown API combinators
991+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)
993+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api