@@ -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,12 +14,19 @@
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
21+#if __GLASGOW_HASKELL__ >= 806
22+{-# LANGUAGE QuantifiedConstraints #-}
17module Servant.Client.Core.HasClient (
25module Servant.Client.Core.HasClient (
19 HasClient (..),
27 HasClient (..),
20 EmptyClient (..),
28 EmptyClient (..),
21 AsClientT,
29 AsClientT,
24 foldMapUnion,
31 foldMapUnion,
25 matchUnion,
32 matchUnion,
@@ -33,7 +40,9 @@ import Control.Arrow
33import Control.Monad
40import Control.Monad
35import qualified Data.ByteString as BS
42import qualified Data.ByteString as BS
43+import Data.ByteString.Builder
36−import qualified Data.ByteString.Lazy as BL
45+import qualified Data.ByteString.Lazy as BL
37import Data.Either
46import Data.Either
38 (partitionEithers)
47 (partitionEithers)
39import Data.Constraint (Dict(..))
48import Data.Constraint (Dict(..))
@@ -45,8 +54,7 @@ import Data.Sequence
45 (fromList)
54 (fromList)
46import qualified Data.Text as T
55import qualified Data.Text as T
47import Network.HTTP.Media
56import Network.HTTP.Media
48− (MediaType, matches, parseAccept)
57+ (MediaType, matches, parseAccept, (//))
49−import qualified Network.HTTP.Media as Media
50import qualified Data.Sequence as Seq
58import qualified Data.Sequence as Seq
51import Data.SOP.BasicFunctors
59import Data.SOP.BasicFunctors
52 (I (I), (:.:) (Comp))
60 (I (I), (:.:) (Comp))
@@ -63,7 +71,7 @@ import Data.Text
63import Data.Proxy
71import Data.Proxy
64 (Proxy (Proxy))
72 (Proxy (Proxy))
65import GHC.TypeLits
73import GHC.TypeLits
66− (KnownNat, KnownSymbol, TypeError, symbolVal)
74+ (KnownSymbol, symbolVal)
67import Network.HTTP.Types
75import Network.HTTP.Types
69import qualified Network.HTTP.Types as H
77import qualified Network.HTTP.Types as H
@@ -84,12 +92,9 @@ import Servant.API.Generic
84 , GenericServant, toServant, fromServant)
92 , GenericServant, toServant, fromServant)
85import Servant.API.ContentTypes
93import Servant.API.ContentTypes
86 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
94 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
87−import Servant.API.Status
89import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
95import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment)
90import Servant.API.Modifiers
96import Servant.API.Modifiers
91 (FoldRequired, RequiredArgument, foldRequiredArgument)
97 (FoldRequired, RequiredArgument, foldRequiredArgument)
92−import Servant.API.TypeErrors
93import Servant.API.UVerb
98import Servant.API.UVerb
94 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
99 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
@@ -208,7 +213,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m api)
208 clientWithRoute pm (Proxy :: Proxy api)
213 clientWithRoute pm (Proxy :: Proxy api)
209 (appendToPath p req)
214 (appendToPath p req)
211− where p = toEncodedUrlPiece val
216+ where p = (toUrlPiece val)
213 hoistClientMonad pm _ f cl = \a ->
218 hoistClientMonad pm _ f cl = \a ->
214 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
219 hoistClientMonad pm (Proxy :: Proxy api) f (cl a)
@@ -243,7 +248,7 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
243 clientWithRoute pm (Proxy :: Proxy sublayout)
248 clientWithRoute pm (Proxy :: Proxy sublayout)
244 (foldl' (flip appendToPath) req ps)
249 (foldl' (flip appendToPath) req ps)
246− where ps = map toEncodedUrlPiece vals
251+ where ps = map (toUrlPiece) vals
248 hoistClientMonad pm _ f cl = \as ->
253 hoistClientMonad pm _ f cl = \as ->
249 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
254 hoistClientMonad pm (Proxy :: Proxy sublayout) f (cl as)
@@ -251,11 +256,10 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient m sublayout)
251instance {-# OVERLAPPABLE #-}
256instance {-# OVERLAPPABLE #-}
252 -- Note [Non-Empty Content Types]
257 -- Note [Non-Empty Content Types]
253 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
258 ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
255 ) => HasClient m (Verb method status cts' a) where
259 ) => HasClient m (Verb method status cts' a) where
256 type Client m (Verb method status cts' a) = m a
260 type Client m (Verb method status cts' a) = m a
257 clientWithRoute _pm Proxy req = do
261 clientWithRoute _pm Proxy req = do
258− response <- runRequestAcceptStatus (Just [status]) req
262+ response <- runRequest req
259 { requestAccept = fromList $ toList accept
263 { requestAccept = fromList $ toList accept
260 , requestMethod = method
264 , requestMethod = method
@@ -263,20 +267,18 @@ instance {-# OVERLAPPABLE #-}
264 accept = contentTypes (Proxy :: Proxy ct)
268 accept = contentTypes (Proxy :: Proxy ct)
265 method = reflectMethod (Proxy :: Proxy method)
269 method = reflectMethod (Proxy :: Proxy method)
266− status = statusFromNat (Proxy :: Proxy status)
268 hoistClientMonad _ _ f ma = f ma
271 hoistClientMonad _ _ f ma = f ma
270instance {-# OVERLAPPING #-}
273instance {-# OVERLAPPING #-}
271− ( RunClient m, ReflectMethod method, KnownNat status
274+ ( RunClient m, ReflectMethod method
272 ) => HasClient m (Verb method status cts NoContent) where
275 ) => HasClient m (Verb method status cts NoContent) where
273 type Client m (Verb method status cts NoContent)
276 type Client m (Verb method status cts NoContent)
274 = m NoContent
277 = m NoContent
275 clientWithRoute _pm Proxy req = do
278 clientWithRoute _pm Proxy req = do
276− _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
279+ _response <- runRequest req { requestMethod = method }
277 return NoContent
280 return NoContent
278 where method = reflectMethod (Proxy :: Proxy method)
281 where method = reflectMethod (Proxy :: Proxy method)
279− status = statusFromNat (Proxy :: Proxy status)
281 hoistClientMonad _ _ f ma = f ma
283 hoistClientMonad _ _ f ma = f ma
@@ -293,13 +295,13 @@ instance (RunClient m, ReflectMethod method) =>
294instance {-# OVERLAPPING #-}
296instance {-# OVERLAPPING #-}
295 -- Note [Non-Empty Content Types]
297 -- Note [Non-Empty Content Types]
296− ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status
298+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls
297 , ReflectMethod method, cts' ~ (ct ': cts)
299 , ReflectMethod method, cts' ~ (ct ': cts)
298 ) => HasClient m (Verb method status cts' (Headers ls a)) where
300 ) => HasClient m (Verb method status cts' (Headers ls a)) where
299 type Client m (Verb method status cts' (Headers ls a))
301 type Client m (Verb method status cts' (Headers ls a))
300 = m (Headers ls a)
302 = m (Headers ls a)
301 clientWithRoute _pm Proxy req = do
303 clientWithRoute _pm Proxy req = do
302− response <- runRequestAcceptStatus (Just [status]) req
304+ response <- runRequest req
303 { requestMethod = method
305 { requestMethod = method
304 , requestAccept = fromList $ toList accept
306 , requestAccept = fromList $ toList accept
@@ -307,26 +309,22 @@ instance {-# OVERLAPPING #-}
307 return $ Headers { getResponse = val
309 return $ Headers { getResponse = val
308 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
310 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
311− method = reflectMethod (Proxy :: Proxy method)
312+ where method = reflectMethod (Proxy :: Proxy method)
312− accept = contentTypes (Proxy :: Proxy ct)
313+ accept = contentTypes (Proxy :: Proxy ct)
313− status = statusFromNat (Proxy :: Proxy status)
315 hoistClientMonad _ _ f ma = f ma
315 hoistClientMonad _ _ f ma = f ma
317instance {-# OVERLAPPING #-}
317instance {-# OVERLAPPING #-}
318− ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status
318+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method
319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
319 ) => HasClient m (Verb method status cts (Headers ls NoContent)) where
320 type Client m (Verb method status cts (Headers ls NoContent))
320 type Client m (Verb method status cts (Headers ls NoContent))
321 = m (Headers ls NoContent)
321 = m (Headers ls NoContent)
322 clientWithRoute _pm Proxy req = do
322 clientWithRoute _pm Proxy req = do
323+ let method = reflectMethod (Proxy :: Proxy method)
323− response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method }
324+ response <- runRequest req { requestMethod = method }
324 return $ Headers { getResponse = NoContent
325 return $ Headers { getResponse = NoContent
325 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
326 , getHeadersHList = buildHeadersTo . toList $ responseHeaders response
328− method = reflectMethod (Proxy :: Proxy method)
329− status = statusFromNat (Proxy :: Proxy status)
331 hoistClientMonad _ _ f ma = f ma
329 hoistClientMonad _ _ f ma = f ma
@@ -569,7 +567,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
569 (Proxy :: Proxy mods) add (maybe req add) mparam
567 (Proxy :: Proxy mods) add (maybe req add) mparam
571 add :: a -> Request
569 add :: a -> Request
572− add param = appendToQueryString pname (Just $ encodeQueryParamValue param) req
570+ add param = appendToQueryString pname (Just $ encodeQueryParam param) req
574 pname :: Text
572 pname :: Text
575 pname = pack $ symbolVal (Proxy :: Proxy sym)
573 pname = pack $ symbolVal (Proxy :: Proxy sym)
@@ -577,6 +575,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire
577 hoistClientMonad pm _ f cl = \arg ->
575 hoistClientMonad pm _ f cl = \arg ->
578 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
576 hoistClientMonad pm (Proxy :: Proxy api) f (cl arg)
578+encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString
579+encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece
580-- | If you use a 'QueryParams' in one of your endpoints in your API,
581-- | If you use a 'QueryParams' in one of your endpoints in your API,
581-- the corresponding querying function will automatically take
582-- the corresponding querying function will automatically take
582-- an additional argument, a list of values of the type specified
583-- an additional argument, a list of values of the type specified
@@ -618,7 +619,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api)
620 where pname = pack $ symbolVal (Proxy :: Proxy sym)
621 where pname = pack $ symbolVal (Proxy :: Proxy sym)
621− paramlist' = map (Just . encodeQueryParamValue) paramlist
622+ paramlist' = map (Just . encodeQueryParam) paramlist
623 hoistClientMonad pm _ f cl = \as ->
624 hoistClientMonad pm _ f cl = \as ->
624 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
625 hoistClientMonad pm (Proxy :: Proxy api) f (cl as)
@@ -740,7 +741,7 @@ instance (KnownSymbol path, HasClient m api) => HasClient m (path :> api) where
740 clientWithRoute pm (Proxy :: Proxy api)
741 clientWithRoute pm (Proxy :: Proxy api)
741 (appendToPath p req)
742 (appendToPath p req)
743− where p = toEncodedUrlPiece $ pack $ symbolVal (Proxy :: Proxy path)
744+ where p = pack $ symbolVal (Proxy :: Proxy path)
745 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
746 hoistClientMonad pm _ f cl = hoistClientMonad pm (Proxy :: Proxy api) f cl
@@ -789,7 +790,7 @@ instance ( HasClient m api
790-- | Ignore @'Fragment'@ in client functions.
791-- | Ignore @'Fragment'@ in client functions.
791-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
792-- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.
793-- Example:
794-- Example:
795-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
796-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]
@@ -801,12 +802,16 @@ instance ( HasClient m api
801-- > getBooks = client myApi
802-- > getBooks = client myApi
802-- > -- then you can just use "getBooksBy" to query that endpoint.
803-- > -- then you can just use "getBooksBy" to query that endpoint.
803-- > -- 'getBooks' for all books.
804-- > -- 'getBooks' for all books.
805+#ifdef HAS_TYPE_ERROR
804instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
806instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api
808+instance ( HasClient m api
805 ) => HasClient m (Fragment a :> api) where
810 ) => HasClient m (Fragment a :> api) where
807 type Client m (Fragment a :> api) = Client m api
812 type Client m (Fragment a :> api) = Client m api
809− clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
814+ clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api)
811 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
816 hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api)
@@ -826,6 +831,7 @@ data AsClientT (m :: * -> *)
826instance GenericMode (AsClientT m) where
831instance GenericMode (AsClientT m) where
827 type AsClientT m :- api = Client m api
832 type AsClientT m :- api = Client m api
834+#if __GLASGOW_HASKELL__ >= 806
830type GClientConstraints api m =
836type GClientConstraints api m =
831 ( GenericServant api (AsClientT m)
837 ( GenericServant api (AsClientT m)
@@ -833,10 +839,10 @@ type GClientConstraints api m =
835class GClient (api :: * -> *) m where
841class GClient (api :: * -> *) m where
836− gClientProof :: Dict (GClientConstraints api m)
842+ proof :: Dict (GClientConstraints api m)
838instance GClientConstraints api m => GClient api m where
844instance GClientConstraints api m => GClient api m where
839− gClientProof = Dict
845+ proof = Dict
842 ( forall n. GClient api n
848 ( forall n. GClient api n
@@ -848,7 +854,7 @@ instance
849 clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
855 clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)
850 clientWithRoute pm _ request =
856 clientWithRoute pm _ request =
851− case gClientProof @api @m of
857+ case proof @api @m of
852 Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
858 Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request
854 hoistClientMonad
860 hoistClientMonad
@@ -859,63 +865,29 @@ instance
859 -> Client ma (NamedRoutes api)
865 -> Client ma (NamedRoutes api)
860 -> Client mb (NamedRoutes api)
866 -> Client mb (NamedRoutes api)
861 hoistClientMonad _ _ nat clientA =
867 hoistClientMonad _ _ nat clientA =
862− case (gClientProof @api @ma, gClientProof @api @mb) of
868+ case (proof @api @ma, proof @api @mb) of
863 (Dict, Dict) ->
869 (Dict, Dict) ->
864 fromServant @api @(AsClientT mb) $
870 fromServant @api @(AsClientT mb) $
865 hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
871 hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $
866 toServant @api @(AsClientT ma) clientA
872 toServant @api @(AsClientT ma) clientA
868−infixl 1 //
874+#endif
871−-- | Helper to make code using records of clients more readable.
876+infixl 1 /:
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.
878+-- | Convenience function for working with nested record-clients.
905−-- Intended to be used in conjunction with '(//)'.
907-- Example:
880-- Example:
910−-- type Api = NamedRoutes RootApi
883+-- type Api = NamedAPI RootApi
912-- data RootApi mode = RootApi
885-- data RootApi mode = RootApi
913−-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi
886+-- { subApi :: mode :- NamedAPI SubApi
914−-- , hello :: mode :- Capture "name" String :> Get '[JSON] String
916-- } deriving Generic
888-- } deriving Generic
918−-- data SubApi mode = SubApi
890+-- data SubAmi mode = SubApi
919-- { endpoint :: mode :- Get '[JSON] Person
891-- { endpoint :: mode :- Get '[JSON] Person
921-- } deriving Generic
893-- } deriving Generic
@@ -926,14 +898,11 @@ x // f = f x
926-- rootClient :: RootApi (AsClientT ClientM)
898-- rootClient :: RootApi (AsClientT ClientM)
927-- rootClient = client api
899-- rootClient = client api
929−-- hello :: String -> ClientM String
930−-- hello name = rootClient // hello /: name
932-- endpointClient :: ClientM Person
901-- endpointClient :: ClientM Person
933−-- endpointClient = client // subApi /: "foobar123" // endpoint
902+-- endpointClient = client /: subApi /: endpoint
935−(/:) :: (a -> b -> c) -> b -> a -> c
904+(/:) :: a -> (a -> b) -> b
936−(/:) = flip
905+x /: f = f x
939{- Note [Non-Empty Content Types]
908{- Note [Non-Empty Content Types]
@@ -959,7 +928,7 @@ for empty and one for non-empty lists).
959checkContentTypeHeader :: RunClient m => Response -> m MediaType
928checkContentTypeHeader :: RunClient m => Response -> m MediaType
960checkContentTypeHeader response =
929checkContentTypeHeader response =
961 case lookup "Content-Type" $ toList $ responseHeaders response of
930 case lookup "Content-Type" $ toList $ responseHeaders response of
962− Nothing -> return $ "application" Media.// "octet-stream"
931+ Nothing -> return $ "application"//"octet-stream"
963 Just t -> case parseAccept t of
932 Just t -> case parseAccept t of
964 Nothing -> throwClientError $ InvalidContentTypeHeader response
933 Nothing -> throwClientError $ InvalidContentTypeHeader response
965 Just t' -> return t'
934 Just t' -> return t'
@@ -975,19 +944,3 @@ decodedAs response ct = do
975 Right val -> return val
944 Right val -> return val
977 accept = toList $ contentTypes ct
946 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