@@ -1,4 +1,5 @@
1{-# LANGUAGE ConstraintKinds #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
@@ -6,7 +7,6 @@
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
9−{-# LANGUAGE QuantifiedConstraints #-}
10{-# LANGUAGE RankNTypes #-}
10{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeApplications #-}
12{-# LANGUAGE TypeApplications #-}
@@ -14,13 +14,14 @@
14{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE UndecidableInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
17+#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
18+#define HAS_TYPE_ERROR
17module Servant.Client.Core.HasClient (
21module Servant.Client.Core.HasClient (
19 HasClient (..),
23 HasClient (..),
20 EmptyClient (..),
24 EmptyClient (..),
24 foldMapUnion,
25 foldMapUnion,
25 matchUnion,
26 matchUnion,
@@ -32,11 +33,9 @@ import Control.Arrow
32 (left, (+++))
33 (left, (+++))
33import Control.Monad
34import Control.Monad
35−import qualified Data.ByteString as BS
36+import qualified Data.ByteString.Lazy as BL
36−import qualified Data.ByteString.Lazy as BL
37import Data.Either
37import Data.Either
38 (partitionEithers)
38 (partitionEithers)
39−import Data.Constraint (Dict(..))
40import Data.Foldable
39import Data.Foldable
42import Data.List
41import Data.List
@@ -45,8 +44,7 @@ import Data.Sequence
45 (fromList)
44 (fromList)
46import qualified Data.Text as T
45import qualified Data.Text as T
47import Network.HTTP.Media
46import Network.HTTP.Media
48− (MediaType, matches, parseAccept)
47+ (MediaType, matches, parseAccept, (//))
49−import qualified Network.HTTP.Media as Media
50import qualified Data.Sequence as Seq
48import qualified Data.Sequence as Seq
51import Data.SOP.BasicFunctors
49import Data.SOP.BasicFunctors
52 (I (I), (:.:) (Comp))
50 (I (I), (:.:) (Comp))
@@ -63,7 +61,7 @@ import Data.Text
63import Data.Proxy
61import Data.Proxy
64 (Proxy (Proxy))
62 (Proxy (Proxy))
65import GHC.TypeLits
63import GHC.TypeLits
66− (KnownNat, KnownSymbol, TypeError, symbolVal)
64+ (KnownSymbol, symbolVal)
67import Network.HTTP.Types
65import Network.HTTP.Types
69import qualified Network.HTTP.Types as H
67import qualified Network.HTTP.Types as H
@@ -78,18 +76,12 @@ import Servant.API
78 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
76 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
79 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
77 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
80 Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
78 Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
81− getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
79+ getResponse, toQueryParam, toUrlPiece)
82−import Servant.API.Generic
83− (GenericMode(..), ToServant, ToServantApi
84− , GenericServant, toServant, fromServant)
85import Servant.API.ContentTypes
80import Servant.API.ContentTypes
86 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
81 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
87−import Servant.API.Status
89import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
82import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
90import Servant.API.Modifiers
83import Servant.API.Modifiers
91 (FoldRequired, RequiredArgument, foldRequiredArgument)
84 (FoldRequired, RequiredArgument, foldRequiredArgument)
92−import Servant.API.TypeErrors
93import Servant.API.UVerb
85import Servant.API.UVerb
94 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
86 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
@@ -208,7 +200,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
208 clientWithRoute pm (Proxy :: Proxy api)
200 clientWithRoute pm (Proxy :: Proxy api)
209 (appendToPath p req)
201 (appendToPath p req)
211− where p = toEncodedUrlPiece val
203+ where p = (toUrlPiece val)
213 hoistClientMonad pm _ f cl = \a ->
205 hoistClientMonad pm _ f cl = \a ->
214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
206 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@@ -243,7 +235,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
243 clientWithRoute pm (Proxy :: Proxy sublayout)
235 clientWithRoute pm (Proxy :: Proxy sublayout)
244 (foldl' (flip appendToPath) req ps)
236 (foldl' (flip appendToPath) req ps)
246− where ps = map toEncodedUrlPiece vals
238+ where ps = map (toUrlPiece) vals
248 hoistClientMonad pm _ f cl = \as ->
240 hoistClientMonad pm _ f cl = \as ->
249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
241 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
@@ -251,11 +243,10 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
251instance {-# OVERLAPPABLE #-}
243instance {-# OVERLAPPABLE #-}
252 -- Note [Non-Empty Content Types]
244 -- Note [Non-Empty Content Types]
253 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
245 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
255 ) => HasClient m (Verb method status cts' a) where
246 ) => HasClient m (Verb method status cts' a) where
256 type Client m (Verb method status cts' a) = m a
247 type Client m (Verb method status cts' a) = m a
257 clientWithRoute _pm Proxy req = do
248 clientWithRoute _pm Proxy req = do
258− response <- runRequestAcceptStatus (Just [status]) req
249+ response <- runRequest req
259 { requestAccept = fromList $ toList accept
250 { requestAccept = fromList $ toList accept
260 , requestMethod = method
251 , requestMethod = method
@@ -263,20 +254,18 @@ instance {-# OVERLAPPABLE #-}
264 accept = contentTypes (Proxy :: Proxy ct)
255 accept = contentTypes (Proxy :: Proxy ct)
265 method = reflectMethod (Proxy :: Proxy method)
256 method = reflectMethod (Proxy :: Proxy method)
266− status = statusFromNat (Proxy :: Proxy status)
268 hoistClientMonad _ _ f ma = f ma
258 hoistClientMonad _ _ f ma = f ma
270instance {-# OVERLAPPING #-}
260instance {-# OVERLAPPING #-}
271− ( RunClient m, ReflectMethod method, KnownNat status
261+ ( RunClient m, ReflectMethod method
272 ) => HasClient m (Verb method status cts NoContent) where
262 ) => HasClient m (Verb method status cts NoContent) where
273 type Client m (Verb method status cts NoContent)
263 type Client m (Verb method status cts NoContent)
274 = m NoContent
264 = m NoContent
275 clientWithRoute _pm Proxy req = do
265 clientWithRoute _pm Proxy req = do
276− _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
266+ _response <- runRequest req { requestMethod = method }
277 return NoContent
267 return NoContent
278 where method = reflectMethod (Proxy :: Proxy method)
268 where method = reflectMethod (Proxy :: Proxy method)
279− status = statusFromNat (Proxy :: Proxy status)
281 hoistClientMonad _ _ f ma = f ma
270 hoistClientMonad _ _ f ma = f ma
@@ -293,13 +282,13 @@ instance (RunClient m, ReflectMethod method) =>
294instance {-# OVERLAPPING #-}
283instance {-# OVERLAPPING #-}
295 -- Note [Non-Empty Content Types]
284 -- Note [Non-Empty Content Types]
296− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
285+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
297 , ReflectMethod method, cts' ~ (ct ': cts)
286 , ReflectMethod method, cts' ~ (ct ': cts)
298 ) => HasClient m (Verb method status cts' (Headers ls a)) where
287 ) => HasClient m (Verb method status cts' (Headers ls a)) where
299 type Client m (Verb method status cts' (Headers ls a))
288 type Client m (Verb method status cts' (Headers ls a))
300 = m (Headers ls a)
289 = m (Headers ls a)
301 clientWithRoute _pm Proxy req = do
290 clientWithRoute _pm Proxy req = do
302− response <- runRequestAcceptStatus (Just [status]) req
291+ response <- runRequest req
303 { requestMethod = method
292 { requestMethod = method
304 , requestAccept = fromList $ toList accept
293 , requestAccept = fromList $ toList accept
@@ -307,26 +296,22 @@ instance {-# OVERLAPPING #-}
307 return $ Headers { getResponse = val
296 return $ Headers { getResponse = val
308 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
297 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
311− method = reflectMethod (Proxy :: Proxy method)
299+ where method = reflectMethod (Proxy :: Proxy method)
312− accept = contentTypes (Proxy :: Proxy ct)
300+ accept = contentTypes (Proxy :: Proxy ct)
313− status = statusFromNat (Proxy :: Proxy status)
315 hoistClientMonad _ _ f ma = f ma
302 hoistClientMonad _ _ f ma = f ma
317instance {-# OVERLAPPING #-}
304instance {-# OVERLAPPING #-}
318− ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
305+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method
319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
306 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
320 type Client m (Verb method status cts (Headers ls NoContent))
307 type Client m (Verb method status cts (Headers ls NoContent))
321 = m (Headers ls NoContent)
308 = m (Headers ls NoContent)
322 clientWithRoute _pm Proxy req = do
309 clientWithRoute _pm Proxy req = do
310+ let method = reflectMethod (Proxy :: Proxy method)
323− response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
311+ response <- runRequest req { requestMethod = method }
324 return $ Headers { getResponse = NoContent
312 return $ Headers { getResponse = NoContent
325 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
313 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
328− method = reflectMethod (Proxy :: Proxy method)
329− status = statusFromNat (Proxy :: Proxy status)
331 hoistClientMonad _ _ f ma = f ma
316 hoistClientMonad _ _ f ma = f ma
@@ -569,7 +554,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
569 (Proxy :: Proxy mods) add (maybe req add) mparam
554 (Proxy :: Proxy mods) add (maybe req add) mparam
571 add :: a -> Request
556 add :: a -> Request
572− add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
557+ add param = appendToQueryString pname (Just $ toQueryParam param) req
574 pname :: Text
559 pname :: Text
575 pname = pack $ symbolVal (Proxy :: Proxy sym)
560 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -618,7 +603,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
620 where pname = pack $ symbolVal (Proxy :: Proxy sym)
605 where pname = pack $ symbolVal (Proxy :: Proxy sym)
621− paramlist' = map (Just . encodeQueryParamValue) paramlist
606+ paramlist' = map (Just . toQueryParam) paramlist
623 hoistClientMonad pm _ f cl = \as ->
608 hoistClientMonad pm _ f cl = \as ->
624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
609 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@@ -740,7 +725,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
740 clientWithRoute pm (Proxy :: Proxy api)
725 clientWithRoute pm (Proxy :: Proxy api)
741 (appendToPath p req)
726 (appendToPath p req)
743− where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
728+ where p = pack $ symbolVal (Proxy :: Proxy path)
745 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
730 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
@@ -789,7 +774,7 @@ instance ( HasClient m api
790-- | Ignore @'Fragment'@ in client functions.
775-- | Ignore @'Fragment'@ in client functions.
791-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
776-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
793-- Example:
778-- Example:
795-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
780-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
@@ -801,12 +786,16 @@ instance ( HasClient m api
801-- > getBooks = client myApi
786-- > getBooks = client myApi
802-- > -- then you can just use "getBooksBy" to query that endpoint.
787-- > -- then you can just use "getBooksBy" to query that endpoint.
803-- > -- 'getBooks' for all books.
788-- > -- 'getBooks' for all books.
789+#ifdef HAS_TYPE_ERROR
804instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
790instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
792+instance ( HasClient m api
805 ) => HasClient m (Fragment a :> api) where
794 ) => HasClient m (Fragment a :> api) where
807 type Client m (Fragment a :> api) = Client m api
796 type Client m (Fragment a :> api) = Client m api
809− clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
798+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
811 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
800 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
@@ -821,119 +810,6 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
821 hoistClientMonad pm _ f cl = \bauth ->
810 hoistClientMonad pm _ f cl = \bauth ->
822 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
811 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
939{- Note [Non-Empty Content Types]
815{- Note [Non-Empty Content Types]
@@ -959,7 +835,7 @@ for empty and one for non-empty lists).
959checkContentTypeHeader :: RunClient m => Response -> m MediaType
835checkContentTypeHeader :: RunClient m => Response -> m MediaType
960checkContentTypeHeader response =
836checkContentTypeHeader response =
961 case lookup "Content-Type" $ toList $ responseHeaders response of
837 case lookup "Content-Type" $ toList $ responseHeaders response of
962− Nothing -> return $ "application" Media.// "octet-stream"
838+ Nothing -> return $ "application"//"octet-stream"
963 Just t -> case parseAccept t of
839 Just t -> case parseAccept t of
964 Nothing -> throwClientError $ InvalidContentTypeHeader response
840 Nothing -> throwClientError $ InvalidContentTypeHeader response
965 Just t' -> return t'
841 Just t' -> return t'
@@ -975,19 +851,3 @@ decodedAs response ct = do
975 Right val -> return val
851 Right val -> return val
977 accept = toList $ contentTypes ct
853 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