diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ---- diff --git a/servant-client-core.cabal b/servant-client-core.cabal --- a/servant-client-core.cabal +++ b/servant-client-core.cabal @@ -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 diff --git a/src/Servant/Client/Core.hs b/src/Servant/Client/Core.hs --- a/src/Servant/Client/Core.hs +++ b/src/Servant/Client/Core.hs @@ -18,6 +18,8 @@ -- * Client generation clientIn , HasClient(..) + , foldMapUnion + , matchUnion -- * Request , Request diff --git a/src/Servant/Client/Core/HasClient.hs b/src/Servant/Client/Core/HasClient.hs --- a/src/Servant/Client/Core/HasClient.hs +++ b/src/Servant/Client/Core/HasClient.hs @@ -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 diff --git a/src/Servant/Client/Core/Reexport.hs b/src/Servant/Client/Core/Reexport.hs --- a/src/Servant/Client/Core/Reexport.hs +++ b/src/Servant/Client/Core/Reexport.hs @@ -5,6 +5,8 @@ ( -- * HasClient HasClient(..) + , foldMapUnion + , matchUnion -- * Response (for @Raw@) , Response diff --git a/src/Servant/Client/Core/RunClient.hs b/src/Servant/Client/Core/RunClient.hs --- a/src/Servant/Client/Core/RunClient.hs +++ b/src/Servant/Client/Core/RunClient.hs @@ -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