diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,52 @@ [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.14 +---- + +- `Stream` takes a status code argument + + ```diff + -Stream method framing ctype a + +Stream method status framing ctype a + ``` + + ([#966](https://github.com/haskell-servant/servant/pull/966) + [#972](https://github.com/haskell-servant/servant/pull/972)) + +- `ToStreamGenerator` definition changed, so it's possible to write an instance + for conduits. + + ```diff + -class ToStreamGenerator f a where + - toStreamGenerator :: f a -> StreamGenerator a + +class ToStreamGenerator a b | a -> b where + + toStreamGenerator :: a -> StreamGenerator b + ``` + + ([#959](https://github.com/haskell-servant/servant/pull/959)) + +- Added `NoFraming` streaming strategy + ([#959](https://github.com/haskell-servant/servant/pull/959)) + +- *servant-server* File serving in polymorphic monad. + i.e. Generalised types of `serveDirectoryFileServer` etc functions in + `Servant.Utils.StaticFiles` + ([#953](https://github.com/haskell-servant/servant/pull/953)) + +- *servant-server* `ReqBody` content type check is recoverable. + This allows writing APIs like: + + ```haskell + ReqBody '[JSON] Int :> Post '[PlainText] Int + :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int + ``` + + which is useful when handlers are subtly different, + for example may do less work. + ([#937](https://github.com/haskell-servant/servant/pull/937)) + + 0.13.0.1 -------- diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -1,5 +1,5 @@ name: servant-server -version: 0.13.0.1 +version: 0.14 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them @@ -22,11 +22,11 @@ build-type: Custom cabal-version: >=1.10 tested-with: - GHC==7.8.4, - GHC==7.10.3, - GHC==8.0.2, - GHC==8.2.2, - GHC==8.4.1 + GHC==7.8.4 + GHC==7.10.3 + GHC==8.0.2 + GHC==8.2.2 + GHC==8.4.3 extra-source-files: include/*.h CHANGELOG.md @@ -40,7 +40,7 @@ setup-depends: base >= 4 && <5, Cabal, - cabal-doctest >= 1.0.1 && <1.1 + cabal-doctest >= 1.0.6 && <1.1 library exposed-modules: @@ -71,37 +71,31 @@ if !impl(ghc >= 8.0) build-depends: - semigroups >= 0.18.3 && < 0.19 + semigroups >= 0.18.4 && < 0.19 -- Servant dependencies build-depends: - servant == 0.13.* + servant == 0.14.* -- 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.2.3.0 && < 1.4 - , base-compat >= 0.9.3 && < 0.11 - , attoparsec >= 0.13.2.0 && < 0.14 + base-compat >= 0.10.1 && < 0.11 , base64-bytestring >= 1.0.0.1 && < 1.1 - , exceptions >= 0.8.3 && < 0.11 - , http-api-data >= 0.3.7.1 && < 0.4 - , http-media >= 0.7.0 && < 0.8 - , http-types >= 0.12 && < 0.13 + , exceptions >= 0.10.0 && < 0.11 + , http-api-data >= 0.3.8.1 && < 0.4 + , http-media >= 0.7.1.2 && < 0.8 + , http-types >= 0.12.1 && < 0.13 , network-uri >= 2.6.1.0 && < 2.7 - , monad-control >= 1.0.0.4 && < 1.1 - , network >= 2.6.3.2 && < 2.7 - , safe >= 0.3.15 && < 0.4 - , split >= 0.2.3.2 && < 0.3 + , monad-control >= 1.0.2.3 && < 1.1 + , network >= 2.6.3.5 && < 2.8 , string-conversions >= 0.4.0.1 && < 0.5 - , system-filepath >= 0.4 && < 0.5 - , resourcet >= 1.1.9 && < 1.3 + , resourcet >= 1.1.11 && < 1.3 , tagged >= 0.8.5 && < 0.9 , transformers-base >= 0.4.4 && < 0.5 - , transformers-compat >= 0.5.1 && < 0.7 + , transformers-compat >= 0.6.2 && < 0.7 , wai >= 3.2.1.1 && < 3.3 , wai-app-static >= 3.1.6.1 && < 3.2 - , warp >= 3.2.13 && < 3.3 , word8 >= 0.1.3 && < 0.2 hs-source-dirs: src @@ -120,11 +114,13 @@ base , servant , servant-server - , aeson - , warp , wai , text + build-depends: + aeson >= 1.3.1.1 && < 1.5 + , warp >= 3.2.13 && < 3.3 + test-suite spec type: exitcode-stdio-1.0 ghc-options: -Wall @@ -148,13 +144,10 @@ build-depends: base , base-compat - , aeson , base64-bytestring , bytestring - , exceptions , http-types , mtl - , network , resourcet , safe , servant @@ -164,27 +157,26 @@ , transformers , transformers-compat , wai - , warp -- Additonal dependencies build-depends: - directory >= 1.2.1.0 && < 1.4 - , hspec >= 2.4.4 && < 2.6 - , hspec-wai >= 0.9 && < 0.10 + aeson >= 1.3.1.1 && < 1.5 + , directory >= 1.2.1.0 && < 1.4 + , hspec >= 2.5.1 && < 2.6 + , hspec-wai >= 0.9.0 && < 0.10 + , QuickCheck >= 2.11.3 && < 2.12 , should-not-typecheck >= 2.1.0 && < 2.2 - , parsec >= 3.1.11 && < 3.2 - , QuickCheck >= 2.10.1 && < 2.12 + , temporary >= 1.3 && < 1.4 , wai-extra >= 3.0.21.0 && < 3.1 - , temporary >= 1.2.0.3 && < 1.4 build-tool-depends: - hspec-discover:hspec-discover >=2.4.4 && <2.6 + hspec-discover:hspec-discover >= 2.5.1 && <2.6 test-suite doctests build-depends: base , servant-server - , doctest >= 0.13.0 && <0.16 + , doctest >= 0.15.0 && <0.16 type: exitcode-stdio-1.0 main-is: test/doctests.hs buildable: True diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -283,37 +283,40 @@ instance OVERLAPPABLE_ - ( MimeRender ctype a, ReflectMethod method, - FramingRender framing ctype, ToStreamGenerator f a - ) => HasServer (Stream method framing ctype (f a)) context where + ( MimeRender ctype a, ReflectMethod method, KnownNat status, + FramingRender framing ctype, ToStreamGenerator b a + ) => HasServer (Stream method status framing ctype b) context where - type ServerT (Stream method framing ctype (f a)) m = m (f a) + type ServerT (Stream method status framing ctype b) m = m b hoistServerWithContext _ _ nt s = nt s - route Proxy _ = streamRouter ([],) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype) + route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) instance OVERLAPPING_ - ( MimeRender ctype a, ReflectMethod method, - FramingRender framing ctype, ToStreamGenerator f a, - GetHeaders (Headers h (f a)) - ) => HasServer (Stream method framing ctype (Headers h (f a))) context where + ( MimeRender ctype a, ReflectMethod method, KnownNat status, + FramingRender framing ctype, ToStreamGenerator b a, + GetHeaders (Headers h b) + ) => HasServer (Stream method status framing ctype (Headers h b)) context where - type ServerT (Stream method framing ctype (Headers h (f a))) m = m (Headers h (f a)) + type ServerT (Stream method status framing ctype (Headers h b)) m = m (Headers h b) hoistServerWithContext _ _ nt s = nt s - route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype) + route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) -streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator f a) => - (b -> ([(HeaderName, B.ByteString)], f a)) +streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator b a) => + (c -> ([(HeaderName, B.ByteString)], b)) -> Method + -> Status -> Proxy framing -> Proxy ctype - -> Delayed env (Handler b) + -> Delayed env (Handler c) -> Router env -streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \env request respond -> +streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond -> let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request cmediatype = NHM.matchAccept [contentType ctypeproxy] accH accCheck = when (isNothing cmediatype) $ delayedFail err406 @@ -323,7 +326,7 @@ ) env request respond $ \ output -> let (headers, fa) = splitHeaders output k = getStreamGenerator . toStreamGenerator $ fa in - Route $ responseStream status200 (contentHeader : headers) $ \write flush -> do + Route $ responseStream status (contentHeader : headers) $ \write flush -> do write . BB.lazyByteString $ header framingproxy ctypeproxy case boundary framingproxy ctypeproxy of BoundaryStrategyBracket f -> @@ -604,7 +607,7 @@ let contentTypeH = fromMaybe "application/octet-stream" $ lookup hContentType $ requestHeaders request case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of - Nothing -> delayedFailFatal err415 + Nothing -> delayedFail err415 Just f -> return f -- Body check, we get a body parsing functions as the first argument. diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs --- a/src/Servant/Utils/StaticFiles.hs +++ b/src/Servant/Utils/StaticFiles.hs @@ -18,7 +18,7 @@ import Data.ByteString (ByteString) import Network.Wai.Application.Static import Servant.API.Raw (Raw) -import Servant.Server (Server, Tagged (..)) +import Servant.Server (ServerT, Tagged (..)) import System.FilePath (addTrailingPathSeparator) #if !MIN_VERSION_wai_app_static(3,1,0) import Filesystem.Path.CurrentOS (decodeString) @@ -47,33 +47,33 @@ -- in order. -- -- Corresponds to the `defaultWebAppSettings` `StaticSettings` value. -serveDirectoryWebApp :: FilePath -> Server Raw +serveDirectoryWebApp :: FilePath -> ServerT Raw m serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath -- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`. -serveDirectoryFileServer :: FilePath -> Server Raw +serveDirectoryFileServer :: FilePath -> ServerT Raw m serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath -- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'. -serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> Server Raw +serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> ServerT Raw m serveDirectoryWebAppLookup etag = serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath -- | Uses 'embeddedSettings'. -serveDirectoryEmbedded :: [(FilePath, ByteString)] -> Server Raw +serveDirectoryEmbedded :: [(FilePath, ByteString)] -> ServerT Raw m serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files) -- | Alias for 'staticApp'. Lets you serve a directory -- with arbitrary 'StaticSettings'. Useful when you want -- particular settings not covered by the four other -- variants. This is the most flexible method. -serveDirectoryWith :: StaticSettings -> Server Raw +serveDirectoryWith :: StaticSettings -> ServerT Raw m serveDirectoryWith = Tagged . staticApp -- | Same as 'serveDirectoryFileServer'. It used to be the only -- file serving function in servant pre-0.10 and will be kept -- around for a few versions, but is deprecated. -serveDirectory :: FilePath -> Server Raw +serveDirectory :: FilePath -> ServerT Raw m serveDirectory = serveDirectoryFileServer {-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-} diff --git a/test/Servant/Server/ErrorSpec.hs b/test/Servant/Server/ErrorSpec.hs --- a/test/Servant/Server/ErrorSpec.hs +++ b/test/Servant/Server/ErrorSpec.hs @@ -247,6 +247,8 @@ :<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 3 :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- 4 :<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- 5 + :<|> "path5" :> (ReqBody '[JSON] Int :> Post '[PlainText] Int -- 6 + :<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- 7 errorChoiceApi :: Proxy ErrorChoiceApi errorChoiceApi = Proxy @@ -256,8 +258,8 @@ :<|> return 1 :<|> return 2 :<|> (\_ -> return 3) - :<|> (\_ -> return 4) - :<|> (\_ -> return 5) + :<|> ((\_ -> return 4) :<|> (\_ -> return 5)) + :<|> ((\_ -> return 6) :<|> (\_ -> return 7)) errorChoiceSpec :: Spec @@ -278,6 +280,13 @@ request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"), (hAccept, "blah")] "5" `shouldRespondWith` 406 + it "should respond with 415 only if none of the subservers supports the request's content type" $ do + request methodPost "path5" [(hContentType, "text/plain;charset=utf-8")] "1" + `shouldRespondWith` 200 + request methodPost "path5" [(hContentType, "application/json")] "1" + `shouldRespondWith` 200 + request methodPost "path5" [(hContentType, "application/not-supported")] "" + `shouldRespondWith` 415 -- }}} diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -17,57 +17,62 @@ module Servant.ServerSpec where -import Control.Monad (forM_, when, unless) -import Control.Monad.Error.Class (MonadError (..)) -import Data.Aeson (FromJSON, ToJSON, decode', encode) -import qualified Data.ByteString.Base64 as Base64 -import Data.Char (toUpper) +import Control.Monad + (forM_, unless, when) +import Control.Monad.Error.Class + (MonadError (..)) +import Data.Aeson + (FromJSON, ToJSON, decode', encode) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as Base64 +import Data.Char + (toUpper) import Data.Monoid -import Data.Proxy (Proxy (Proxy)) -import Data.String (fromString) -import Data.String.Conversions (cs) -import qualified Data.Text as T -import GHC.Generics (Generic) -import Network.HTTP.Types (Status (..), hAccept, hContentType, - methodDelete, methodGet, - methodHead, methodPatch, - methodPost, methodPut, ok200, - imATeapot418, - parseQuery) -import Network.Wai (Application, Request, requestHeaders, pathInfo, - queryString, rawQueryString, - responseLBS) -import Network.Wai.Test (defaultRequest, request, - runSession, simpleBody, - simpleHeaders, simpleStatus) -import Servant.API ((:<|>) (..), (:>), AuthProtect, - BasicAuth, BasicAuthData(BasicAuthData), - Capture, CaptureAll, Delete, Get, Header, - Headers, HttpVersion, - IsSecure (..), JSON, - NoContent (..), Patch, PlainText, - Post, Put, EmptyAPI, - QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, - StdMethod (..), Verb, addHeader) +import Data.Proxy + (Proxy (Proxy)) +import Data.String + (fromString) +import Data.String.Conversions + (cs) +import qualified Data.Text as T +import GHC.Generics + (Generic) +import Network.HTTP.Types + (Status (..), hAccept, hContentType, imATeapot418, + methodDelete, methodGet, methodHead, methodPatch, methodPost, + methodPut, ok200, parseQuery) +import Network.Wai + (Application, Request, pathInfo, queryString, rawQueryString, + requestHeaders, responseLBS) +import Network.Wai.Test + (defaultRequest, request, runSession, simpleBody, + simpleHeaders, simpleStatus) +import Servant.API + ((:<|>) (..), (:>), AuthProtect, BasicAuth, + BasicAuthData (BasicAuthData), Capture, CaptureAll, Delete, + EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..), + JSON, NoContent (..), NoFraming, OctetStream, Patch, + PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, + RemoteHost, ReqBody, StdMethod (..), Stream, + StreamGenerator (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI -import Servant.Server (Server, Handler, Tagged (..), err401, err403, - err404, serve, serveWithContext, - Context((:.), EmptyContext), emptyServer) -import Test.Hspec (Spec, context, describe, it, - shouldBe, shouldContain) -import qualified Test.Hspec.Wai as THW -import Test.Hspec.Wai (get, liftIO, matchHeaders, - matchStatus, shouldRespondWith, - with, (<:>)) +import Servant.Server + (Context ((:.), EmptyContext), Handler, Server, Tagged (..), + emptyServer, err401, err403, err404, serve, serveWithContext) +import Test.Hspec + (Spec, context, describe, it, shouldBe, shouldContain) +import Test.Hspec.Wai + (get, liftIO, matchHeaders, matchStatus, shouldRespondWith, + with, (<:>)) +import qualified Test.Hspec.Wai as THW -import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck), - BasicAuthResult(Authorized,Unauthorized)) import Servant.Server.Experimental.Auth - (AuthHandler, AuthServerData, - mkAuthHandler) + (AuthHandler, AuthServerData, mkAuthHandler) +import Servant.Server.Internal.BasicAuth + (BasicAuthCheck (BasicAuthCheck), + BasicAuthResult (Authorized, Unauthorized)) import Servant.Server.Internal.Context - (NamedContext(..)) + (NamedContext (..)) -- * comprehensive api test @@ -83,6 +88,7 @@ spec = do verbSpec captureSpec + captureAllSpec queryParamSpec reqBodySpec headerSpec @@ -105,6 +111,7 @@ :<|> "accept" :> ( Verb method status '[JSON] Person :<|> Verb method status '[PlainText] String ) + :<|> "stream" :> Stream method status NoFraming OctetStream (StreamGenerator BS.ByteString) verbSpec :: Spec verbSpec = describe "Servant.API.Verb" $ do @@ -114,6 +121,8 @@ :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent) :<|> (return alice :<|> return "B") + :<|> return (StreamGenerator $ \f _ -> f "bytestring") + get200 = Proxy :: Proxy (VerbApi 'GET 200) post210 = Proxy :: Proxy (VerbApi 'POST 210) put203 = Proxy :: Proxy (VerbApi 'PUT 203) @@ -178,6 +187,11 @@ response <- THW.request method "" [] "" liftIO $ simpleHeaders response `shouldContain` [("Content-Type", "application/json;charset=utf-8")] + + it "works for Stream as for Result" $ do + response <- THW.request method "/stream" [] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ simpleBody response `shouldBe` "bytestring" test "GET 200" get200 methodGet 200 test "POST 210" post210 methodPost 210