servant-server 0.18.2 → 0.18.3
raw patch · 5 files changed
+91/−30 lines, 5 filesdep ~basedep ~base64-bytestringdep ~bytestring
Dependency ranges changed: base, base64-bytestring, bytestring, http-api-data, servant, sop-core
Files
- CHANGELOG.md +12/−0
- servant-server.cabal +10/−9
- src/Servant/Server/UVerb.hs +39/−19
- test/Servant/Server/Internal/ContextSpec.hs +1/−1
- test/Servant/ServerSpec.hs +29/−1
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-server/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.3+------++### Significant changes++- Add response header support to UVerb (#1420)++### Other changes++- Support GHC-9.0.1.+- Bump `bytestring`, `hspec` and `base64-bytestring` dependencies.+ 0.18.2 ------
servant-server.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-server-version: 0.18.2+version: 0.18.3 synopsis: A family of combinators for defining webservices APIs and serving them category: Servant, Web@@ -23,7 +23,7 @@ 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+tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 extra-source-files: CHANGELOG.md@@ -60,8 +60,8 @@ -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 build-depends:- base >= 4.9 && < 4.15- , bytestring >= 0.10.8.1 && < 0.11+ base >= 4.9 && < 4.16+ , bytestring >= 0.10.8.1 && < 0.12 , containers >= 0.5.7.1 && < 0.7 , mtl >= 2.2.2 && < 2.3 , text >= 1.2.3.0 && < 1.3@@ -71,14 +71,14 @@ -- Servant dependencies -- strict dependency as we re-export 'servant' things. build-depends:- servant >= 0.18.2 && < 0.18.3- , http-api-data >= 0.4.1 && < 0.4.3+ servant >= 0.18.3 && < 0.18.4+ , http-api-data >= 0.4.1 && < 0.4.4 -- 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: base-compat >= 0.10.5 && < 0.12- , base64-bytestring >= 1.0.0.1 && < 1.2+ , base64-bytestring >= 1.0.0.1 && < 1.3 , exceptions >= 0.10.0 && < 0.11 , http-media >= 0.7.1.3 && < 0.9 , http-types >= 0.12.2 && < 0.13@@ -147,6 +147,7 @@ , safe , servant , servant-server+ , sop-core , string-conversions , text , transformers@@ -157,7 +158,7 @@ build-depends: aeson >= 1.4.1.0 && < 1.6 , directory >= 1.3.0.0 && < 1.4- , hspec >= 2.6.0 && < 2.8+ , hspec >= 2.6.0 && < 2.9 , hspec-wai >= 0.10.1 && < 0.12 , QuickCheck >= 2.12.6.1 && < 2.15 , should-not-typecheck >= 2.1.0 && < 2.2@@ -165,4 +166,4 @@ , wai-extra >= 3.0.24.3 && < 3.2 build-tool-depends:- hspec-discover:hspec-discover >= 2.6.0 && <2.8+ hspec-discover:hspec-discover >= 2.6.0 && <2.9
src/Servant/Server/UVerb.hs view
@@ -22,15 +22,17 @@ ) where +import qualified Data.ByteString as B import Data.Proxy (Proxy (Proxy)) import Data.SOP (I (I)) import Data.SOP.Constraint (All, And) import Data.String.Conversions (LBS, cs)-import Network.HTTP.Types (Status, hContentType)-import Network.Wai (responseLBS)+import Network.HTTP.Types (Status, HeaderName, hContentType)+import Network.Wai (responseLBS, Request) import Servant.API (ReflectMethod, reflectMethod) import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)-import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, foldMapUnion, inject, statusOf)+import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..))+import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf) import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction) @@ -43,13 +45,38 @@ f (Union xs) respond = pure . inject . I --- | Helper constraint used in @instance 'HasServer' 'UVerb'@.-type IsServerResource contentTypes = AllCTRender contentTypes `And` HasStatus+class IsServerResource (cts :: [*]) a where+ resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS)+ resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)] +instance {-# OVERLAPPABLE #-} AllCTRender cts a+ => IsServerResource cts a where+ resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res+ resourceHeaders _ _ = []++instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a))+ => IsServerResource cts (Headers h a) where+ resourceResponse request p res = resourceResponse request p (getResponse res)+ resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res)++instance {-# OVERLAPPING #-} IsServerResource cts a+ => IsServerResource cts (WithStatus n a) where+ resourceResponse request p (WithStatus x) = resourceResponse request p x+ resourceHeaders cts (WithStatus x) = resourceHeaders cts x++encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a)+ => Request -> Proxy cts -> a+ -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])+encodeResource request cts res = (statusOf (Proxy @a),+ resourceResponse request cts res,+ resourceHeaders cts res)++type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus+ instance ( ReflectMethod method, AllMime contentTypes,- All (IsServerResource contentTypes) as,+ All (IsServerResourceWithStatus contentTypes) as, Unique (Statuses as) -- for consistency with servant-swagger (server would work fine -- without; client is a bit of a corner case, because it dispatches -- the parser based on the status code. with this uniqueness@@ -77,20 +104,13 @@ action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)- mkProxy :: a -> Proxy a- mkProxy _ = Proxy runAction action' env request cont $ \(output :: Union as) -> do- let encodeResource :: (AllCTRender contentTypes a, HasStatus a) => a -> (Status, Maybe (LBS, LBS))- encodeResource res =- ( statusOf $ mkProxy res,- handleAcceptH (Proxy @contentTypes) (getAcceptHeader request) res- )- pickResource :: Union as -> (Status, Maybe (LBS, LBS))- pickResource = foldMapUnion (Proxy @(IsServerResource contentTypes)) encodeResource-+ let cts = Proxy @contentTypes+ pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)])+ pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts) case pickResource output of- (_, Nothing) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does- (status, Just (contentT, body)) ->+ (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does+ (status, Just (contentT, body), headers) -> let bdy = if allowedMethodHead method request then "" else body- in Route $ responseLBS status ((hContentType, cs contentT) : []) bdy+ in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy
test/Servant/Server/Internal/ContextSpec.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE DataKinds #-}-{-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-}+{-# OPTIONS_GHC -fdefer-type-errors -Wwarn -Wno-deferred-type-errors #-} module Servant.Server.Internal.ContextSpec (spec) where import Data.Proxy
test/Servant/ServerSpec.hs view
@@ -28,6 +28,8 @@ (fromMaybe) import Data.Proxy (Proxy (Proxy))+import Data.SOP+ (I (..), NS (..)) import Data.String (fromString) import Data.String.Conversions@@ -53,7 +55,7 @@ NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,- UVerb, Union, Verb, addHeader)+ UVerb, Union, Verb, WithStatus (..), addHeader) import Servant.Server (Context ((:.), EmptyContext), Handler, Server, Tagged (..), emptyServer, err401, err403, err404, respond, serve,@@ -98,6 +100,7 @@ rawSpec alternativeSpec responseHeadersSpec+ uverbResponseHeadersSpec miscCombinatorSpec basicAuthSpec genAuthSpec@@ -683,6 +686,31 @@ forM_ methods $ \method -> THW.request method "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 406++-- }}}+------------------------------------------------------------------------------+-- * uverbResponseHeaderSpec {{{+------------------------------------------------------------------------------+type UVerbHeaderResponse = '[+ WithStatus 200 (Headers '[Header "H1" Int] String),+ WithStatus 404 String ]++type UVerbResponseHeadersApi =+ Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse++uverbResponseHeadersServer :: Server UVerbResponseHeadersApi+uverbResponseHeadersServer True = pure . Z . I . WithStatus $ addHeader 5 "foo"+uverbResponseHeadersServer False = pure . S . Z . I . WithStatus $ "bar"++uverbResponseHeadersSpec :: Spec+uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do+ with (return $ serve (Proxy :: Proxy UVerbResponseHeadersApi) uverbResponseHeadersServer) $ do++ it "includes the headers in the response" $+ THW.request methodGet "/true" [] ""+ `shouldRespondWith` "\"foo\"" { matchHeaders = ["H1" <:> "5"]+ , matchStatus = 200+ } -- }}} ------------------------------------------------------------------------------