servant-client-core 0.18.3 → 0.19
raw patch · 8 files changed
+240/−53 lines, 8 filesdep +constraintsdep ~aesondep ~basedep ~base-compatnew-uploader
Dependencies added: constraints
Dependency ranges changed: aeson, base, base-compat, hspec, servant, template-haskell, text
Files
- CHANGELOG.md +31/−0
- servant-client-core.cabal +8/−7
- src/Servant/Client/Core/BasicAuth.hs +0/−2
- src/Servant/Client/Core/HasClient.hs +172/−27
- src/Servant/Client/Core/Reexport.hs +4/−0
- src/Servant/Client/Core/Request.hs +5/−6
- src/Servant/Client/Generic.hs +8/−11
- test/Servant/Client/Core/RequestSpec.hs +12/−0
CHANGELOG.md view
@@ -1,6 +1,37 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +Package versions follow the [Package Versioning Policy](https://pvp.haskell.org/): in A.B.C, bumps to either A or B represent major versions.++0.19+----++### Significant changes++- Drop support for GHC < 8.6.+- Support GHC 9.0 (GHC 9.2 should work as well, but isn't fully tested yet).+- Support Aeson 2 ([#1475](https://github.com/haskell-servant/servant/pull/1475)),+ which fixes a [DOS vulnerability](https://github.com/haskell/aeson/issues/864)+ related to hash collisions.+- Add `NamedRoutes` combinator, making support for records first-class in Servant+ ([#1388](https://github.com/haskell-servant/servant/pull/1388)).+- Add custom type errors for partially applied combinators+ ([#1289](https://github.com/haskell-servant/servant/pull/1289),+ [#1486](https://github.com/haskell-servant/servant/pull/1486)).+- *servant-client* / *servant-client-core* / *servant-http-streams*: Fix+ erroneous behavior, where only 2XX status codes would be considered+ successful, irrelevant of the status parameter specified by the verb+ combinator. ([#1469](https://github.com/haskell-servant/servant/pull/1469))+- *servant-client* / *servant-client-core*: Fix `Show` instance for+ `Servant.Client.Core.Request`.+- *servant-client* / *servant-client-core*: Allow passing arbitrary binary data+ in Query parameters.+ ([#1432](https://github.com/haskell-servant/servant/pull/1432)).++### Other changes++- Various version bumps.+ 0.18.3 ------
servant-client-core.cabal view
@@ -1,6 +1,6 @@-cabal-version: >=1.10+cabal-version: 2.2 name: servant-client-core-version: 0.18.3+version: 0.19 synopsis: Core functionality and class for client function generation for servant APIs category: Servant, Web@@ -10,14 +10,14 @@ homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues-license: BSD3+license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors build-type: Simple-tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1- , GHCJS == 8.4+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1+ , GHCJS ==8.6.0.1 extra-source-files: CHANGELOG.md@@ -52,6 +52,7 @@ build-depends: base >= 4.9 && < 4.16 , bytestring >= 0.10.8.1 && < 0.12+ , constraints >= 0.2 && < 0.14 , containers >= 0.5.7.1 && < 0.7 , deepseq >= 1.4.2.0 && < 1.5 , text >= 1.2.3.0 && < 1.3@@ -64,12 +65,12 @@ -- Servant dependencies build-depends:- servant >= 0.18.3 && <0.19+ servant >= 0.19 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends:- aeson >= 1.4.1.0 && < 1.6+ aeson >= 1.4.1.0 && < 3 , base-compat >= 0.10.5 && < 0.12 , base64-bytestring >= 1.0.0.1 && < 1.3 , exceptions >= 0.10.0 && < 0.11
src/Servant/Client/Core/BasicAuth.hs view
@@ -9,8 +9,6 @@ import Data.ByteString.Base64 (encode)-import Data.Monoid- ((<>)) import Data.Text.Encoding (decodeUtf8) import Servant.API.BasicAuth
src/Servant/Client/Core/HasClient.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -7,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -14,14 +14,13 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802-#define HAS_TYPE_ERROR-#endif- module Servant.Client.Core.HasClient ( clientIn, HasClient (..), EmptyClient (..),+ AsClientT,+ (//),+ (/:), foldMapUnion, matchUnion, ) where@@ -33,9 +32,13 @@ (left, (+++)) import Control.Monad (unless)+import qualified Data.ByteString as BS+import Data.ByteString.Builder+ (toLazyByteString) import qualified Data.ByteString.Lazy as BL import Data.Either (partitionEithers)+import Data.Constraint (Dict(..)) import Data.Foldable (toList) import Data.List@@ -44,7 +47,8 @@ (fromList) import qualified Data.Text as T import Network.HTTP.Media- (MediaType, matches, parseAccept, (//))+ (MediaType, matches, parseAccept)+import qualified Network.HTTP.Media as Media import qualified Data.Sequence as Seq import Data.SOP.BasicFunctors (I (I), (:.:) (Comp))@@ -61,7 +65,7 @@ import Data.Proxy (Proxy (Proxy)) import GHC.TypeLits- (KnownSymbol, symbolVal)+ (KnownNat, KnownSymbol, TypeError, symbolVal) import Network.HTTP.Types (Status) import qualified Network.HTTP.Types as H@@ -76,12 +80,18 @@ ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, ToSourceIO (..), Vault, Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList,- getResponse, toQueryParam, toUrlPiece)+ getResponse, toEncodedUrlPiece, toUrlPiece, NamedRoutes)+import Servant.API.Generic+ (GenericMode(..), ToServant, ToServantApi+ , GenericServant, toServant, fromServant) import Servant.API.ContentTypes (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))+import Servant.API.Status+ (statusFromNat) import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment) import Servant.API.Modifiers (FoldRequired, RequiredArgument, foldRequiredArgument)+import Servant.API.TypeErrors import Servant.API.UVerb (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion) @@ -243,10 +253,11 @@ instance {-# OVERLAPPABLE #-} -- Note [Non-Empty Content Types] ( RunClient m, MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)+ , KnownNat status ) => HasClient m (Verb method status cts' a) where type Client m (Verb method status cts' a) = m a clientWithRoute _pm Proxy req = do- response <- runRequest req+ response <- runRequestAcceptStatus (Just [status]) req { requestAccept = fromList $ toList accept , requestMethod = method }@@ -254,18 +265,20 @@ where accept = contentTypes (Proxy :: Proxy ct) method = reflectMethod (Proxy :: Proxy method)+ status = statusFromNat (Proxy :: Proxy status) hoistClientMonad _ _ f ma = f ma instance {-# OVERLAPPING #-}- ( RunClient m, ReflectMethod method+ ( RunClient m, ReflectMethod method, KnownNat status ) => HasClient m (Verb method status cts NoContent) where type Client m (Verb method status cts NoContent) = m NoContent clientWithRoute _pm Proxy req = do- _response <- runRequest req { requestMethod = method }+ _response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method } return NoContent where method = reflectMethod (Proxy :: Proxy method)+ status = statusFromNat (Proxy :: Proxy status) hoistClientMonad _ _ f ma = f ma @@ -282,13 +295,13 @@ instance {-# OVERLAPPING #-} -- Note [Non-Empty Content Types]- ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls+ ( RunClient m, MimeUnrender ct a, BuildHeadersTo ls, KnownNat status , ReflectMethod method, cts' ~ (ct ': cts) ) => HasClient m (Verb method status cts' (Headers ls a)) where type Client m (Verb method status cts' (Headers ls a)) = m (Headers ls a) clientWithRoute _pm Proxy req = do- response <- runRequest req+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method , requestAccept = fromList $ toList accept }@@ -296,22 +309,26 @@ return $ Headers { getResponse = val , getHeadersHList = buildHeadersTo . toList $ responseHeaders response }- where method = reflectMethod (Proxy :: Proxy method)- accept = contentTypes (Proxy :: Proxy ct)+ where+ method = reflectMethod (Proxy :: Proxy method)+ accept = contentTypes (Proxy :: Proxy ct)+ status = statusFromNat (Proxy :: Proxy status) hoistClientMonad _ _ f ma = f ma instance {-# OVERLAPPING #-}- ( RunClient m, BuildHeadersTo ls, ReflectMethod method+ ( RunClient m, BuildHeadersTo ls, ReflectMethod method, KnownNat status ) => HasClient m (Verb method status cts (Headers ls NoContent)) where type Client m (Verb method status cts (Headers ls NoContent)) = m (Headers ls NoContent) clientWithRoute _pm Proxy req = do- let method = reflectMethod (Proxy :: Proxy method)- response <- runRequest req { requestMethod = method }+ response <- runRequestAcceptStatus (Just [status]) req { requestMethod = method } return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo . toList $ responseHeaders response }+ where+ method = reflectMethod (Proxy :: Proxy method)+ status = statusFromNat (Proxy :: Proxy status) hoistClientMonad _ _ f ma = f ma @@ -554,7 +571,7 @@ (Proxy :: Proxy mods) add (maybe req add) mparam where add :: a -> Request- add param = appendToQueryString pname (Just $ toQueryParam param) req+ add param = appendToQueryString pname (Just $ encodeQueryParam param) req pname :: Text pname = pack $ symbolVal (Proxy :: Proxy sym)@@ -562,6 +579,9 @@ hoistClientMonad pm _ f cl = \arg -> hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) +encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString+encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece+ -- | If you use a 'QueryParams' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument, a list of values of the type specified@@ -603,7 +623,7 @@ ) where pname = pack $ symbolVal (Proxy :: Proxy sym)- paramlist' = map (Just . toQueryParam) paramlist+ paramlist' = map (Just . encodeQueryParam) paramlist hoistClientMonad pm _ f cl = \as -> hoistClientMonad pm (Proxy :: Proxy api) f (cl as)@@ -774,7 +794,7 @@ -- | Ignore @'Fragment'@ in client functions. -- See <https://ietf.org/rfc/rfc2616.html#section-15.1.3> for more details.--- +-- -- Example: -- -- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book]@@ -786,16 +806,12 @@ -- > getBooks = client myApi -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooks' for all books.-#ifdef HAS_TYPE_ERROR instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api-#else-instance ( HasClient m api-#endif ) => HasClient m (Fragment a :> api) where type Client m (Fragment a :> api) = Client m api - clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api) @@ -810,8 +826,121 @@ hoistClientMonad pm _ f cl = \bauth -> hoistClientMonad pm (Proxy :: Proxy api) f (cl bauth) +-- | A type that specifies that an API record contains a client implementation.+data AsClientT (m :: * -> *)+instance GenericMode (AsClientT m) where+ type AsClientT m :- api = Client m api +type GClientConstraints api m =+ ( GenericServant api (AsClientT m)+ , Client m (ToServantApi api) ~ ToServant api (AsClientT m)+ )++class GClient (api :: * -> *) m where+ gClientProof :: Dict (GClientConstraints api m)++instance GClientConstraints api m => GClient api m where+ gClientProof = Dict++instance+ ( forall n. GClient api n+ , HasClient m (ToServantApi api)+ , RunClient m+ )+ => HasClient m (NamedRoutes api) where+ type Client m (NamedRoutes api) = api (AsClientT m)++ clientWithRoute :: Proxy m -> Proxy (NamedRoutes api) -> Request -> Client m (NamedRoutes api)+ clientWithRoute pm _ request =+ case gClientProof @api @m of+ Dict -> fromServant $ clientWithRoute pm (Proxy @(ToServantApi api)) request++ hoistClientMonad+ :: forall ma mb.+ Proxy m+ -> Proxy (NamedRoutes api)+ -> (forall x. ma x -> mb x)+ -> Client ma (NamedRoutes api)+ -> Client mb (NamedRoutes api)+ hoistClientMonad _ _ nat clientA =+ case (gClientProof @api @ma, gClientProof @api @mb) of+ (Dict, Dict) ->+ fromServant @api @(AsClientT mb) $+ hoistClientMonad @m @(ToServantApi api) @ma @mb Proxy Proxy nat $+ toServant @api @(AsClientT ma) clientA++infixl 1 //+infixl 2 /:++-- | Helper to make code using records of clients more readable.+--+-- Can be mixed with (/:) for supplying arguments.+--+-- Example:+--+-- @@+-- type Api = NamedRoutes RootApi+--+-- data RootApi mode = RootApi+-- { subApi :: mode :- NamedRoutes SubApi+-- , …+-- } deriving Generic+--+-- data SubApi mode = SubApi+-- { endpoint :: mode :- Get '[JSON] Person+-- , …+-- } deriving Generic+--+-- api :: Proxy API+-- api = Proxy+--+-- rootClient :: RootApi (AsClientT ClientM)+-- rootClient = client api+--+-- endpointClient :: ClientM Person+-- endpointClient = client // subApi // endpoint+-- @@+(//) :: a -> (a -> b) -> b+x // f = f x++-- | Convenience function for supplying arguments to client functions when+-- working with records of clients.+--+-- Intended to be used in conjunction with '(//)'.+--+-- Example:+--+-- @@+-- type Api = NamedRoutes RootApi+--+-- data RootApi mode = RootApi+-- { subApi :: mode :- Capture "token" String :> NamedRoutes SubApi+-- , hello :: mode :- Capture "name" String :> Get '[JSON] String+-- , …+-- } deriving Generic+--+-- data SubApi mode = SubApi+-- { endpoint :: mode :- Get '[JSON] Person+-- , …+-- } deriving Generic+--+-- api :: Proxy API+-- api = Proxy+--+-- rootClient :: RootApi (AsClientT ClientM)+-- rootClient = client api+--+-- hello :: String -> ClientM String+-- hello name = rootClient // hello /: name+--+-- endpointClient :: ClientM Person+-- endpointClient = client // subApi /: "foobar123" // endpoint+-- @@+(/:) :: (a -> b -> c) -> b -> a -> c+(/:) = flip++ {- Note [Non-Empty Content Types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Rather than have@@ -835,7 +964,7 @@ checkContentTypeHeader :: RunClient m => Response -> m MediaType checkContentTypeHeader response = case lookup "Content-Type" $ toList $ responseHeaders response of- Nothing -> return $ "application"//"octet-stream"+ Nothing -> return $ "application" Media.// "octet-stream" Just t -> case parseAccept t of Nothing -> throwClientError $ InvalidContentTypeHeader response Just t' -> return t'@@ -851,3 +980,19 @@ Right val -> return val where accept = toList $ contentTypes ct++-------------------------------------------------------------------------------+-- Custom type errors+-------------------------------------------------------------------------------++-- Erroring instance for HasClient' when a combinator is not fully applied+instance (RunClient m, TypeError (PartialApplication HasClient arr)) => HasClient m ((arr :: a -> b) :> sub)+ where+ type Client m (arr :> sub) = TypeError (PartialApplication HasClient arr)+ clientWithRoute _ _ _ = error "unreachable"+ hoistClientMonad _ _ _ _ = error "unreachable"++-- Erroring instances for 'HasClient' for unknown API combinators+instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceForSub (HasClient m) ty)) => HasClient m (ty :> sub)++instance {-# OVERLAPPABLE #-} (RunClient m, TypeError (NoInstanceFor (HasClient m api))) => HasClient m api
src/Servant/Client/Core/Reexport.hs view
@@ -7,6 +7,9 @@ HasClient(..) , foldMapUnion , matchUnion+ , AsClientT+ , (//)+ , (/:) -- * Response (for @Raw@) , Response@@ -23,6 +26,7 @@ , showBaseUrl , parseBaseUrl , InvalidBaseUrlException+ ) where
src/Servant/Client/Core/Request.hs view
@@ -35,8 +35,6 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LBS-import Data.Semigroup- ((<>)) import qualified Data.Sequence as Seq import Data.Text (Text)@@ -80,12 +78,13 @@ . showString ", requestAccept = " . showsPrec 0 (requestAccept req) . showString ", requestHeaders = "- . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req))+ . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req) . showString ", requestHttpVersion = " . showsPrec 0 (requestHttpVersion req) . showString ", requestMethod = " . showsPrec 0 (requestMethod req) . showString "}"+ ) where redactSensitiveHeader :: Header -> Header redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")@@ -147,13 +146,13 @@ appendToPath p req = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p } -appendToQueryString :: Text -- ^ param name- -> Maybe Text -- ^ param value+appendToQueryString :: Text -- ^ param name+ -> Maybe BS.ByteString -- ^ param value -> Request -> Request appendToQueryString pname pvalue req = req { requestQueryString = requestQueryString req- Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)}+ Seq.|> (encodeUtf8 pname, pvalue)} addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request addHeader name val req
src/Servant/Client/Generic.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ module Servant.Client.Generic ( AsClientT, genericClient,@@ -15,11 +16,7 @@ import Servant.API.Generic import Servant.Client.Core---- | A type that specifies that an API record contains a client implementation.-data AsClientT (m :: * -> *)-instance GenericMode (AsClientT m) where- type AsClientT m :- api = Client m api+import Servant.Client.Core.HasClient (AsClientT) -- | Generate a record of client functions. genericClient
test/Servant/Client/Core/RequestSpec.hs view
@@ -10,10 +10,22 @@ import Servant.Client.Core.Request import Test.Hspec +newtype DataWithRequest = DataWithRequest (RequestF RequestBody ())+ deriving Show+ spec :: Spec spec = do describe "Request" $ do describe "show" $ do+ it "has parenthesis correctly positioned" $ do+ let d = DataWithRequest (void defaultRequest)+ show d `shouldBe` "DataWithRequest (Request {requestPath = ()\+ \, requestQueryString = fromList []\+ \, requestBody = Nothing\+ \, requestAccept = fromList []\+ \, requestHeaders = fromList []\+ \, requestHttpVersion = HTTP/1.1\+ \, requestMethod = \"GET\"})" it "redacts the authorization header" $ do let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") } isInfixOf "secret" (show request) `shouldBe` False