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-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.1 +------ + +### Significant changes + +- Union verbs + +### Other changes + +- Bump "tested-with" ghc versions +- Allow newer dependencies + 0.18 ---- diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-server -version: 0.18 +version: 0.18.1 synopsis: A family of combinators for defining webservices APIs and serving them category: Servant, Web @@ -23,13 +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.3 - || ==8.10.1 +tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 extra-source-files: CHANGELOG.md @@ -57,6 +51,7 @@ Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServerError Servant.Server.StaticFiles + Servant.Server.UVerb -- deprecated exposed-modules: @@ -77,7 +72,7 @@ -- strict dependency as we re-export 'servant' things. build-depends: servant >= 0.18 && < 0.19.1 - , http-api-data >= 0.4.1 && < 0.4.2 + , http-api-data >= 0.4.1 && < 0.4.3 -- 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. @@ -90,6 +85,7 @@ , network-uri >= 2.6.1.0 && < 2.8 , monad-control >= 1.0.2.3 && < 1.1 , network >= 2.8 && < 3.2 + , sop-core >= 0.4.0.0 && < 0.6 , string-conversions >= 0.4.0.1 && < 0.5 , resourcet >= 1.2.2 && < 1.3 , tagged >= 0.8.6 && < 0.9 @@ -100,6 +96,7 @@ hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall -Wno-redundant-constraints executable greet @@ -161,11 +158,11 @@ aeson >= 1.4.1.0 && < 1.6 , directory >= 1.3.0.0 && < 1.4 , hspec >= 2.6.0 && < 2.8 - , hspec-wai >= 0.10.1 && < 0.11 + , hspec-wai >= 0.10.1 && < 0.12 , QuickCheck >= 2.12.6.1 && < 2.14 , should-not-typecheck >= 2.1.0 && < 2.2 , temporary >= 1.3 && < 1.4 - , wai-extra >= 3.0.24.3 && < 3.1 + , wai-extra >= 3.0.24.3 && < 3.2 build-tool-depends: hspec-discover:hspec-discover >= 2.6.0 && <2.8 diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs --- a/src/Servant/Server.hs +++ b/src/Servant/Server.hs @@ -110,6 +110,7 @@ -- * Re-exports , Application , Tagged (..) + , module Servant.Server.UVerb ) where @@ -122,6 +123,7 @@ import Network.Wai (Application) import Servant.Server.Internal +import Servant.Server.UVerb -- * Implementing Servers 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 @@ -65,7 +65,7 @@ (SockAddr) import Network.Wai (Application, Request, httpVersion, isSecure, lazyRequestBody, - queryString, remoteHost, requestBody, requestHeaders, + queryString, remoteHost, getRequestBodyChunk, requestHeaders, requestMethod, responseLBS, responseStream, vault) import Prelude () import Prelude.Compat @@ -681,7 +681,7 @@ bodyCheck fromRS = withRequest $ \req -> do let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk - let body = requestBody req + let body = getRequestBodyChunk req let rs = S.fromAction B.null body let rs' = fromRS $ framingUnrender' rs return rs' @@ -750,12 +750,12 @@ emptyServer :: ServerT EmptyAPI m emptyServer = Tagged EmptyServer --- | The server for an `EmptyAPI` is `emptyAPIServer`. +-- | The server for an `EmptyAPI` is `emptyServer`. -- -- > type MyApi = "nothing" :> EmptyApi -- > -- > server :: Server MyApi --- > server = emptyAPIServer +-- > server = emptyServer instance HasServer EmptyAPI context where type ServerT EmptyAPI m = Tagged m EmptyServer diff --git a/src/Servant/Server/UVerb.hs b/src/Servant/Server/UVerb.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/UVerb.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Servant.Server.UVerb + ( respond, + IsServerResource, + ) +where + +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 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.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction) + + +-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union, +-- and will construct a union value in an 'Applicative' (eg. 'Server'). +respond :: + forall (x :: *) (xs :: [*]) (f :: * -> *). + (Applicative f, HasStatus x, IsMember x xs) => + x -> + f (Union xs) +respond = pure . inject . I + +-- | Helper constraint used in @instance 'HasServer' 'UVerb'@. +type IsServerResource contentTypes = AllCTRender contentTypes `And` HasStatus + +instance + ( ReflectMethod method, + AllMime contentTypes, + All (IsServerResource contentTypes) as, + Unique (Statuses as) -- for consistency with servant-swagger (server would work fine + -- wihtout; client is a bit of a corner case, because it dispatches + -- the parser based on the status code. with this uniqueness + -- constraint it won't have to run more than one parser in weird + -- corner cases. + ) => + HasServer (UVerb method contentTypes as) context + where + type ServerT (UVerb method contentTypes as) m = m (Union as) + + hoistServerWithContext _ _ nt s = nt s + + route :: + forall env. + Proxy (UVerb method contentTypes as) -> + Context context -> + Delayed env (Server (UVerb method contentTypes as)) -> + Router env + route _proxy _ctx action = leafRouter route' + where + method = reflectMethod (Proxy @method) + route' env request cont = do + let action' :: Delayed env (Handler (Union as)) + action' = + 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 + + 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)) -> + let bdy = if allowedMethodHead method request then "" else body + in Route $ responseLBS status ((hContentType, cs contentT) : []) bdy diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -7,7 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} module Servant.ServerSpec where @@ -49,14 +48,16 @@ import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, - Delete, EmptyAPI, Get, Header, Headers, HttpVersion, - IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb, - NoFraming, OctetStream, Patch, PlainText, Post, Put, - QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, - SourceIO, StdMethod (..), Stream, Strict, Verb, addHeader) + Delete, EmptyAPI, Get, HasStatus(StatusOf), Header, Headers, + HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..), + NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post, + Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, + ReqBody, SourceIO, StdMethod (..), Stream, Strict, Union, + UVerb, Verb, addHeader) import Servant.Server (Context ((:.), EmptyContext), Handler, Server, Tagged (..), - emptyServer, err401, err403, err404, serve, serveWithContext) + emptyServer, err401, err403, err404, respond, serve, + serveWithContext) import Servant.Test.ComprehensiveAPI import qualified Servant.Types.SourceT as S import Test.Hspec @@ -87,6 +88,7 @@ spec :: Spec spec = do verbSpec + uverbSpec captureSpec captureAllSpec queryParamSpec @@ -253,8 +255,8 @@ with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) - (\ "captured" -> Tagged $ \request_ respond -> - respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do + (\ "captured" -> Tagged $ \request_ sendResponse -> + sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) @@ -305,8 +307,8 @@ with (return (serve (Proxy :: Proxy (CaptureAll "segments" String :> Raw)) - (\ _captured -> Tagged $ \request_ respond -> - respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do + (\ _captured -> Tagged $ \request_ sendResponse -> + sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "consumes everything from pathInfo" $ do get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int]))) @@ -544,8 +546,8 @@ rawApi = Proxy rawApplication :: Show a => (Request -> a) -> Tagged m Application -rawApplication f = Tagged $ \request_ respond -> - respond $ responseLBS ok200 [] +rawApplication f = Tagged $ \request_ sendResponse -> + sendResponse $ responseLBS ok200 [] (cs $ show $ f request_) rawSpec :: Spec @@ -706,7 +708,7 @@ basicAuthServer :: Server BasicAuthAPI basicAuthServer = const (return jerry) :<|> - (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "") + (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext = @@ -751,7 +753,7 @@ genAuthServer :: Server GenAuthAPI genAuthServer = const (return tweety) - :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "") + :<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") type instance AuthServerData (AuthProtect "auth") = () @@ -780,6 +782,73 @@ it "plays nice with subsequent Raw endpoints" $ do get "/foo" `shouldRespondWith` 418 + +-- }}} +------------------------------------------------------------------------------ +-- * UVerb {{{ +------------------------------------------------------------------------------ + +newtype PersonResponse = PersonResponse Person + deriving Generic +instance ToJSON PersonResponse +instance HasStatus PersonResponse where + type StatusOf PersonResponse = 200 + +newtype RedirectResponse = RedirectResponse String + deriving Generic +instance ToJSON RedirectResponse +instance HasStatus RedirectResponse where + type StatusOf RedirectResponse = 301 + +newtype AnimalResponse = AnimalResponse Animal + deriving Generic +instance ToJSON AnimalResponse +instance HasStatus AnimalResponse where + type StatusOf AnimalResponse = 203 + + +type UVerbApi + = "person" :> Capture "shouldRedirect" Bool :> UVerb 'GET '[JSON] '[PersonResponse, RedirectResponse] + :<|> "animal" :> UVerb 'GET '[JSON] '[AnimalResponse] + +uverbSpec :: Spec +uverbSpec = describe "Servant.API.UVerb " $ do + let + joe = Person "joe" 42 + mouse = Animal "Mouse" 7 + + personHandler + :: Bool + -> Handler (Union '[PersonResponse + ,RedirectResponse]) + personHandler True = respond $ RedirectResponse "over there!" + personHandler False = respond $ PersonResponse joe + + animalHandler = respond $ AnimalResponse mouse + + server :: Server UVerbApi + server = personHandler :<|> animalHandler + + with (pure $ serve (Proxy :: Proxy UVerbApi) server) $ do + context "A route returning either 301/String or 200/Person" $ do + context "when requesting the person" $ do + let theRequest = THW.get "/person/false" + it "returns status 200" $ + theRequest `shouldRespondWith` 200 + it "returns a person" $ do + response <- theRequest + liftIO $ decode' (simpleBody response) `shouldBe` Just joe + context "requesting the redirect" $ + it "returns a message and status 301" $ + THW.get "/person/true" + `shouldRespondWith` "\"over there!\"" {matchStatus = 301} + context "a route with a single response type" $ do + let theRequest = THW.get "/animal" + it "should return the defined status code" $ + theRequest `shouldRespondWith` 203 + it "should return the expected response" $ do + response <- theRequest + liftIO $ decode' (simpleBody response) `shouldBe` Just mouse -- }}} ------------------------------------------------------------------------------