servant-client-core 0.18 → 0.18.1
raw patch · 6 files changed
+123/−17 lines, 6 filesdep +sop-coredep ~base64-bytestringdep ~servantnew-uploader
Dependencies added: sop-core
Dependency ranges changed: base64-bytestring, servant
Files
- CHANGELOG.md +12/−0
- servant-client-core.cabal +5/−10
- src/Servant/Client/Core.hs +2/−0
- src/Servant/Client/Core/HasClient.hs +90/−4
- src/Servant/Client/Core/Reexport.hs +2/−0
- src/Servant/Client/Core/RunClient.hs +12/−3
CHANGELOG.md view
@@ -1,6 +1,18 @@ [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) +0.18.1+------++### Significant changes++- Union verbs++### Other changes++- Bump "tested-with" ghc versions+- Loosen bound on base16-bytestring+ 0.18 ----
servant-client-core.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-client-core-version: 0.18+version: 0.18.1 synopsis: Core functionality and class for client function generation for servant APIs category: Servant, Web@@ -16,14 +16,8 @@ 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.3- || ==8.10.1- , GHCJS == 8.4+tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2+ , GHCJS == 8.4 extra-source-files: CHANGELOG.md@@ -77,13 +71,14 @@ build-depends: aeson >= 1.4.1.0 && < 1.6 , base-compat >= 0.10.5 && < 0.12- , base64-bytestring >= 1.0.0.1 && < 1.1+ , base64-bytestring >= 1.0.0.1 && < 1.2 , exceptions >= 0.10.0 && < 0.11 , free >= 5.1 && < 5.2 , http-media >= 0.7.1.3 && < 0.9 , http-types >= 0.12.2 && < 0.13 , network-uri >= 2.6.1.0 && < 2.7 , safe >= 0.3.17 && < 0.4+ , sop-core >= 0.4.0.0 && < 0.6 hs-source-dirs: src default-language: Haskell2010
src/Servant/Client/Core.hs view
@@ -18,6 +18,8 @@ -- * Client generation clientIn , HasClient(..)+ , foldMapUnion+ , matchUnion -- * Request , Request
src/Servant/Client/Core/HasClient.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -7,6 +8,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -15,31 +17,48 @@ clientIn, HasClient (..), EmptyClient (..),+ foldMapUnion,+ matchUnion, ) where import Prelude () import Prelude.Compat +import Control.Arrow+ (left, (+++)) import Control.Monad (unless) import qualified Data.ByteString.Lazy as BL+import Data.Either+ (partitionEithers) import Data.Foldable (toList) import Data.List (foldl')-import Data.Proxy- (Proxy (Proxy)) import Data.Sequence (fromList) import qualified Data.Text as T import Network.HTTP.Media (MediaType, matches, parseAccept, (//))+import qualified Data.Sequence as Seq+import Data.SOP.BasicFunctors+ (I (I), (:.:) (Comp))+import Data.SOP.Constraint+ (All)+import Data.SOP.NP+ (NP (..), cpure_NP)+import Data.SOP.NS+ (NS (S)) import Data.String (fromString) import Data.Text (Text, pack)+import Data.Proxy+ (Proxy (Proxy)) import GHC.TypeLits (KnownSymbol, symbolVal)+import Network.HTTP.Types+ (Status) import qualified Network.HTTP.Types as H import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,@@ -54,9 +73,11 @@ contentType, getHeadersHList, getResponse, toQueryParam, toUrlPiece) import Servant.API.ContentTypes- (contentTypes)+ (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender)) import Servant.API.Modifiers (FoldRequired, RequiredArgument, foldRequiredArgument)+import Servant.API.UVerb+ (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion) import Servant.Client.Core.Auth import Servant.Client.Core.BasicAuth@@ -288,6 +309,71 @@ hoistClientMonad _ _ f ma = f ma +data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus+ deriving (Eq, Show)++instance {-# OVERLAPPING #-}+ ( RunClient m,+ contentTypes ~ (contentType ': otherContentTypes),+ -- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem+ -- allow this in instance types as of 8.8.3.)+ as ~ (a ': as'),+ AllMime contentTypes,+ ReflectMethod method,+ All (AllMimeUnrender contentTypes) as,+ All HasStatus as, HasStatuses as',+ Unique (Statuses as)+ ) =>+ HasClient m (UVerb method contentTypes as)+ where+ type Client m (UVerb method contentTypes as) = m (Union as)++ clientWithRoute _ _ request = do+ let accept = Seq.fromList . allMime $ Proxy @contentTypes+ -- offering to accept all mime types listed in the api gives best compatibility. eg.,+ -- we might not own the server implementation, and the server may choose to support+ -- only part of the api.++ method = reflectMethod $ Proxy @method+ acceptStatus = statuses (Proxy @as)+ response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}+ responseContentType <- checkContentTypeHeader response+ unless (any (matches responseContentType) accept) $ do+ throwClientError $ UnsupportedContentType responseContentType response++ let status = responseStatusCode response+ body = responseBody response+ res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) body+ case res of+ Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response+ Right x -> return x+ where+ -- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the+ -- failures it encountered along the way+ -- TODO; better name, rewrite haddocs.+ tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs)+ tryParsers _ Nil = Left [ClientNoMatchingStatus]+ tryParsers status (Comp x :* xs)+ | status == statusOf (Comp x) =+ case partitionEithers x of+ (err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs+ (_, (res : _)) -> Right . inject . I $ res+ | otherwise = -- no reason to parse in the first place. This ain't the one we're looking for+ (ClientStatusMismatch :) +++ S $ tryParsers status xs++ -- | Given a list of types, parses the given response body as each type+ mimeUnrenders ::+ forall cts xs.+ All (AllMimeUnrender cts) xs =>+ Proxy cts ->+ BL.ByteString ->+ NP ([] :.: Either (MediaType, String)) xs+ mimeUnrenders ctp body = cpure_NP+ (Proxy @(AllMimeUnrender cts))+ (Comp . map (\(mediaType, parser) -> left ((,) mediaType) (parser body)) . allMimeUnrender $ ctp)++ hoistClientMonad _ _ nt s = nt s+ instance {-# OVERLAPPABLE #-} ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method, FramingUnrender framing, FromSourceIO chunk a@@ -710,4 +796,4 @@ Left err -> throwClientError $ DecodeFailure (T.pack err) response Right val -> return val where- accept = toList $ contentTypes ct + accept = toList $ contentTypes ct
src/Servant/Client/Core/Reexport.hs view
@@ -5,6 +5,8 @@ ( -- * HasClient HasClient(..)+ , foldMapUnion+ , matchUnion -- * Response (for @Raw@) , Response
src/Servant/Client/Core/RunClient.hs view
@@ -7,6 +7,7 @@ -- | Types for possible backends to run client-side `Request` queries module Servant.Client.Core.RunClient ( RunClient (..),+ runRequest, RunStreamingClient (..), ClientF (..), ) where@@ -14,6 +15,8 @@ import Prelude () import Prelude.Compat +import Network.HTTP.Types.Status+ (Status) import Control.Monad.Free (Free (..), liftF) @@ -22,10 +25,15 @@ import Servant.Client.Core.Response class Monad m => RunClient m where- -- | How to make a request.- runRequest :: Request -> m Response+ -- | How to make a request, with an optional list of status codes to not throw exceptions+ -- for (default: [200..299]).+ runRequestAcceptStatus :: Maybe [Status] -> Request -> m Response throwClientError :: ClientError -> m a +-- | How to make a request.+runRequest :: RunClient m => Request -> m Response+runRequest = runRequestAcceptStatus Nothing+ class RunClient m => RunStreamingClient m where withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a @@ -41,6 +49,7 @@ | Throw ClientError deriving (Functor) +-- TODO: honour the accept-status argument. instance ClientF ~ f => RunClient (Free f) where- runRequest req = liftF (RunRequest req id)+ runRequestAcceptStatus _ req = liftF (RunRequest req id) throwClientError = liftF . Throw