@@ -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,
@@ -33,10 +34,11 @@ import Control.Arrow
33import Control.Monad
34import Control.Monad
35import qualified Data.ByteString as BS
36import qualified Data.ByteString as BS
37+import Data.ByteString.Builder
36−import qualified Data.ByteString.Lazy as BL
39+import qualified Data.ByteString.Lazy as BL
37import Data.Either
40import Data.Either
38 (partitionEithers)
41 (partitionEithers)
39−import Data.Constraint (Dict(..))
40import Data.Foldable
42import Data.Foldable
42import Data.List
44import Data.List
@@ -45,8 +47,7 @@ import Data.Sequence
45 (fromList)
47 (fromList)
46import qualified Data.Text as T
48import qualified Data.Text as T
47import Network.HTTP.Media
49import Network.HTTP.Media
48− (MediaType, matches, parseAccept)
50+ (MediaType, matches, parseAccept, (//))
49−import qualified Network.HTTP.Media as Media
50import qualified Data.Sequence as Seq
51import qualified Data.Sequence as Seq
51import Data.SOP.BasicFunctors
52import Data.SOP.BasicFunctors
52 (I (I), (:.:) (Comp))
53 (I (I), (:.:) (Comp))
@@ -63,7 +64,7 @@ import Data.Text
63import Data.Proxy
64import Data.Proxy
64 (Proxy (Proxy))
65 (Proxy (Proxy))
65import GHC.TypeLits
66import GHC.TypeLits
66− (KnownNat, KnownSymbol, TypeError, symbolVal)
67+ (KnownSymbol, symbolVal)
67import Network.HTTP.Types
68import Network.HTTP.Types
69import qualified Network.HTTP.Types as H
70import qualified Network.HTTP.Types as H
@@ -78,18 +79,12 @@ import Servant.API
78 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
79 ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream,
79 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
80 StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault,
80 Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
81 Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,
81− getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)
82+ getResponse, toEncodedUrlPiece, toUrlPiece)
82−import Servant.API.Generic
83− (GenericMode(..), ToServant, ToServantApi
84− , GenericServant, toServant, fromServant)
85import Servant.API.ContentTypes
83import Servant.API.ContentTypes
86 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
84 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
87−import Servant.API.Status
89import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
85import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
90import Servant.API.Modifiers
86import Servant.API.Modifiers
91 (FoldRequired, RequiredArgument, foldRequiredArgument)
87 (FoldRequired, RequiredArgument, foldRequiredArgument)
92−import Servant.API.TypeErrors
93import Servant.API.UVerb
88import Servant.API.UVerb
94 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
89 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
@@ -208,7 +203,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
208 clientWithRoute pm (Proxy :: Proxy api)
203 clientWithRoute pm (Proxy :: Proxy api)
209 (appendToPath p req)
204 (appendToPath p req)
211− where p = toEncodedUrlPiece val
206+ where p = (toUrlPiece val)
213 hoistClientMonad pm _ f cl = \a ->
208 hoistClientMonad pm _ f cl = \a ->
214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
209 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@@ -243,7 +238,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
243 clientWithRoute pm (Proxy :: Proxy sublayout)
238 clientWithRoute pm (Proxy :: Proxy sublayout)
244 (foldl' (flip appendToPath) req ps)
239 (foldl' (flip appendToPath) req ps)
246− where ps = map toEncodedUrlPiece vals
241+ where ps = map (toUrlPiece) vals
248 hoistClientMonad pm _ f cl = \as ->
243 hoistClientMonad pm _ f cl = \as ->
249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
244 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
@@ -251,11 +246,10 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
251instance {-# OVERLAPPABLE #-}
246instance {-# OVERLAPPABLE #-}
252 -- Note [Non-Empty Content Types]
247 -- Note [Non-Empty Content Types]
253 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
248 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
255 ) => HasClient m (Verb method status cts' a) where
249 ) => HasClient m (Verb method status cts' a) where
256 type Client m (Verb method status cts' a) = m a
250 type Client m (Verb method status cts' a) = m a
257 clientWithRoute _pm Proxy req = do
251 clientWithRoute _pm Proxy req = do
258− response <- runRequestAcceptStatus (Just [status]) req
252+ response <- runRequest req
259 { requestAccept = fromList $ toList accept
253 { requestAccept = fromList $ toList accept
260 , requestMethod = method
254 , requestMethod = method
@@ -263,20 +257,18 @@ instance {-# OVERLAPPABLE #-}
264 accept = contentTypes (Proxy :: Proxy ct)
258 accept = contentTypes (Proxy :: Proxy ct)
265 method = reflectMethod (Proxy :: Proxy method)
259 method = reflectMethod (Proxy :: Proxy method)
266− status = statusFromNat (Proxy :: Proxy status)
268 hoistClientMonad _ _ f ma = f ma
261 hoistClientMonad _ _ f ma = f ma
270instance {-# OVERLAPPING #-}
263instance {-# OVERLAPPING #-}
271− ( RunClient m, ReflectMethod method, KnownNat status
264+ ( RunClient m, ReflectMethod method
272 ) => HasClient m (Verb method status cts NoContent) where
265 ) => HasClient m (Verb method status cts NoContent) where
273 type Client m (Verb method status cts NoContent)
266 type Client m (Verb method status cts NoContent)
274 = m NoContent
267 = m NoContent
275 clientWithRoute _pm Proxy req = do
268 clientWithRoute _pm Proxy req = do
276− _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
269+ _response <- runRequest req { requestMethod = method }
277 return NoContent
270 return NoContent
278 where method = reflectMethod (Proxy :: Proxy method)
271 where method = reflectMethod (Proxy :: Proxy method)
279− status = statusFromNat (Proxy :: Proxy status)
281 hoistClientMonad _ _ f ma = f ma
273 hoistClientMonad _ _ f ma = f ma
@@ -293,13 +285,13 @@ instance (RunClient m, ReflectMethod method) =>
294instance {-# OVERLAPPING #-}
286instance {-# OVERLAPPING #-}
295 -- Note [Non-Empty Content Types]
287 -- Note [Non-Empty Content Types]
296− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
288+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
297 , ReflectMethod method, cts' ~ (ct ': cts)
289 , ReflectMethod method, cts' ~ (ct ': cts)
298 ) => HasClient m (Verb method status cts' (Headers ls a)) where
290 ) => HasClient m (Verb method status cts' (Headers ls a)) where
299 type Client m (Verb method status cts' (Headers ls a))
291 type Client m (Verb method status cts' (Headers ls a))
300 = m (Headers ls a)
292 = m (Headers ls a)
301 clientWithRoute _pm Proxy req = do
293 clientWithRoute _pm Proxy req = do
302− response <- runRequestAcceptStatus (Just [status]) req
294+ response <- runRequest req
303 { requestMethod = method
295 { requestMethod = method
304 , requestAccept = fromList $ toList accept
296 , requestAccept = fromList $ toList accept
@@ -307,26 +299,22 @@ instance {-# OVERLAPPING #-}
307 return $ Headers { getResponse = val
299 return $ Headers { getResponse = val
308 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
300 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
311− method = reflectMethod (Proxy :: Proxy method)
302+ where method = reflectMethod (Proxy :: Proxy method)
312− accept = contentTypes (Proxy :: Proxy ct)
303+ accept = contentTypes (Proxy :: Proxy ct)
313− status = statusFromNat (Proxy :: Proxy status)
315 hoistClientMonad _ _ f ma = f ma
305 hoistClientMonad _ _ f ma = f ma
317instance {-# OVERLAPPING #-}
307instance {-# OVERLAPPING #-}
318− ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
308+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method
319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
309 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
320 type Client m (Verb method status cts (Headers ls NoContent))
310 type Client m (Verb method status cts (Headers ls NoContent))
321 = m (Headers ls NoContent)
311 = m (Headers ls NoContent)
322 clientWithRoute _pm Proxy req = do
312 clientWithRoute _pm Proxy req = do
313+ let method = reflectMethod (Proxy :: Proxy method)
323− response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
314+ response <- runRequest req { requestMethod = method }
324 return $ Headers { getResponse = NoContent
315 return $ Headers { getResponse = NoContent
325 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
316 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
328− method = reflectMethod (Proxy :: Proxy method)
329− status = statusFromNat (Proxy :: Proxy status)
331 hoistClientMonad _ _ f ma = f ma
319 hoistClientMonad _ _ f ma = f ma
@@ -569,7 +557,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
569 (Proxy :: Proxy mods) add (maybe req add) mparam
557 (Proxy :: Proxy mods) add (maybe req add) mparam
571 add :: a -> Request
559 add :: a -> Request
572− add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
560+ add param = appendToQueryString pname (Just $ encodeQueryParam param) req
574 pname :: Text
562 pname :: Text
575 pname = pack $ symbolVal (Proxy :: Proxy sym)
563 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -577,6 +565,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
577 hoistClientMonad pm _ f cl = \arg ->
565 hoistClientMonad pm _ f cl = \arg ->
578 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
566 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
568+encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString
569+encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece
580-- | If you use a 'QueryParams' in one of your endpoints in your API,
571-- | If you use a 'QueryParams' in one of your endpoints in your API,
581-- the corresponding querying function will automatically take
572-- the corresponding querying function will automatically take
582-- an additional argument, a list of values of the type specified
573-- an additional argument, a list of values of the type specified
@@ -618,7 +609,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
620 where pname = pack $ symbolVal (Proxy :: Proxy sym)
611 where pname = pack $ symbolVal (Proxy :: Proxy sym)
621− paramlist' = map (Just . encodeQueryParamValue) paramlist
612+ paramlist' = map (Just . encodeQueryParam) paramlist
623 hoistClientMonad pm _ f cl = \as ->
614 hoistClientMonad pm _ f cl = \as ->
624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
615 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@@ -740,7 +731,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
740 clientWithRoute pm (Proxy :: Proxy api)
731 clientWithRoute pm (Proxy :: Proxy api)
741 (appendToPath p req)
732 (appendToPath p req)
743− where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
734+ where p = pack $ symbolVal (Proxy :: Proxy path)
745 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
736 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
@@ -789,7 +780,7 @@ instance ( HasClient m api
790-- | Ignore @'Fragment'@ in client functions.
781-- | Ignore @'Fragment'@ in client functions.
791-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
782-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
793-- Example:
784-- Example:
795-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
786-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
@@ -801,12 +792,16 @@ instance ( HasClient m api
801-- > getBooks = client myApi
792-- > getBooks = client myApi
802-- > -- then you can just use "getBooksBy" to query that endpoint.
793-- > -- then you can just use "getBooksBy" to query that endpoint.
803-- > -- 'getBooks' for all books.
794-- > -- 'getBooks' for all books.
795+#ifdef HAS_TYPE_ERROR
804instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
796instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
798+instance ( HasClient m api
805 ) => HasClient m (Fragment a :> api) where
800 ) => HasClient m (Fragment a :> api) where
807 type Client m (Fragment a :> api) = Client m api
802 type Client m (Fragment a :> api) = Client m api
809− clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
804+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
811 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
806 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
@@ -821,119 +816,6 @@ instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where
821 hoistClientMonad pm _ f cl = \bauth ->
816 hoistClientMonad pm _ f cl = \bauth ->
822 hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth)
817 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]
821{- Note [Non-Empty Content Types]
@@ -959,7 +841,7 @@ for empty and one for non-empty lists).
959checkContentTypeHeader :: RunClient m => Response -> m MediaType
841checkContentTypeHeader :: RunClient m => Response -> m MediaType
960checkContentTypeHeader response =
842checkContentTypeHeader response =
961 case lookup "Content-Type" $ toList $ responseHeaders response of
843 case lookup "Content-Type" $ toList $ responseHeaders response of
962− Nothing -> return $ "application" Media.// "octet-stream"
844+ Nothing -> return $ "application"//"octet-stream"
963 Just t -> case parseAccept t of
845 Just t -> case parseAccept t of
964 Nothing -> throwClientError $ InvalidContentTypeHeader response
846 Nothing -> throwClientError $ InvalidContentTypeHeader response
965 Just t' -> return t'
847 Just t' -> return t'
@@ -975,19 +857,3 @@ decodedAs response ct = do
975 Right val -> return val
857 Right val -> return val
977 accept = toList $ contentTypes ct
859 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