From 5eddb318a28fd066765dfb2ca4a03d5d5ae580f4 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 12 Mar 2015 18:29:57 +0100 Subject: [PATCH 1/5] Make Post and Put return NoContent when response is () --- src/Servant/Server/Internal.hs | 74 ++++++++++++--- test/Servant/ServerSpec.hs | 162 +++++++++++++++++++++++++++------ 2 files changed, 193 insertions(+), 43 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index df930374..b92036c6 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -4,12 +4,12 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE ScopedTypeVariables #-} module Servant.Server.Internal where import Control.Applicative ((<$>)) import Control.Monad.Trans.Either (EitherT, runEitherT) -import Data.Aeson (ToJSON) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.IORef (newIORef, readIORef, writeIORef) @@ -286,6 +286,19 @@ instance ( AllCTRender ctypes a respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound +instance HasServer (Get ctypes ()) where + type ServerT (Get ctypes ()) m = m () + route Proxy action request respond + | pathIsEmpty request && requestMethod request == methodGet = do + e <- runEitherT action + respond . succeedWith $ case e of + Right () -> responseLBS noContent204 [] "" + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | pathIsEmpty request && requestMethod request /= methodGet = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by 'Header'. @@ -351,6 +364,19 @@ instance ( AllCTRender ctypes a respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound +instance HasServer (Post ctypes ()) where + type ServerT (Post ctypes ()) m = m () + route Proxy action request respond + | pathIsEmpty request && requestMethod request == methodPost = do + e <- runEitherT action + respond . succeedWith $ case e of + Right () -> responseLBS noContent204 [] "" + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | pathIsEmpty request && requestMethod request /= methodPost = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + -- | When implementing the handler for a 'Put' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- and 'Servant.API.Post.Post', the handler code runs in the @@ -382,7 +408,19 @@ instance ( AllCTRender ctypes a responseLBS (mkStatus status (cs message)) [] (cs message) | pathIsEmpty request && requestMethod request /= methodPut = respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound +instance HasServer (Put ctypes ()) where + type ServerT (Put ctypes ()) m = m () + route Proxy action request respond + | pathIsEmpty request && requestMethod request == methodPut = do + e <- runEitherT action + respond . succeedWith $ case e of + Right () -> responseLBS noContent204 [] "" + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | pathIsEmpty request && requestMethod request /= methodPut = + respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound -- | When implementing the handler for a 'Patch' endpoint, @@ -397,25 +435,35 @@ instance ( AllCTRender ctypes a -- a 'ToJSON' instance and servant takes care of encoding it for you, -- yielding status code 201 along the way. instance ( AllCTRender ctypes a - , Typeable a - , ToJSON a) => HasServer (Patch ctypes a) where + ) => HasServer (Patch ctypes a) where type ServerT (Patch ctypes a) m = m a route Proxy action request respond - | pathIsEmpty request && requestMethod request == methodPost = do + | pathIsEmpty request && requestMethod request == methodPatch = do e <- runEitherT action respond . succeedWith $ case e of - Right out -> case cast out of - Nothing -> do - let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request - case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) out of - Nothing -> responseLBS (mkStatus 406 "") [] "" - Just (contentT, body) -> responseLBS status200 [ ("Content-Type" - , cs contentT)] body - Just () -> responseLBS status204 [] "" + Right output -> do + let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of + Nothing -> responseLBS (mkStatus 406 "") [] "" + Just (contentT, body) -> responseLBS status200 [ ("Content-Type" + , cs contentT)] body Left (status, message) -> responseLBS (mkStatus status (cs message)) [] (cs message) - | pathIsEmpty request && requestMethod request /= methodPost = + | pathIsEmpty request && requestMethod request /= methodPatch = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + +instance HasServer (Patch ctypes ()) where + type ServerT (Patch ctypes ()) m = m () + route Proxy action request respond + | pathIsEmpty request && requestMethod request == methodPatch = do + e <- runEitherT action + respond . succeedWith $ case e of + Right () -> responseLBS noContent204 [] "" + Left (status, message) -> + responseLBS (mkStatus status (cs message)) [] (cs message) + | pathIsEmpty request && requestMethod request /= methodPatch = respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index e73c565e..6b44e409 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -1,36 +1,40 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeOperators #-} module Servant.ServerSpec where -import Control.Monad (when) -import Control.Monad.Trans.Either (EitherT, left) -import Data.Aeson (ToJSON, FromJSON, encode, decode') -import Data.Char (toUpper) -import Data.Monoid ((<>)) -import Data.Proxy (Proxy(Proxy)) -import Data.String (fromString) -import Data.String.Conversions (cs) -import GHC.Generics (Generic) -import Network.HTTP.Types ( parseQuery, ok200, status409, methodPost - , methodDelete, hContentType) -import Network.Wai ( Application, Request, responseLBS, pathInfo - , queryString, rawQueryString ) -import Network.Wai.Test (runSession, defaultRequest, simpleBody, request) -import Test.Hspec (Spec, describe, it, shouldBe) -import Test.Hspec.Wai ( liftIO, with, get, post, shouldRespondWith - , matchStatus, request ) +import Control.Monad (when) +import Control.Monad.Trans.Either (EitherT, left) +import Data.Aeson (FromJSON, ToJSON, decode', encode) +import Data.Char (toUpper) +import Data.Monoid ((<>)) +import Data.Proxy (Proxy (Proxy)) +import Data.String (fromString) +import Data.String.Conversions (cs) +import GHC.Generics (Generic) +import Network.HTTP.Types (hContentType, methodDelete, + methodPatch, methodPost, methodPut, + ok200, parseQuery, status409) +import Network.Wai (Application, Request, pathInfo, + queryString, rawQueryString, + responseLBS) +import Network.Wai.Test (defaultRequest, request, + runSession, simpleBody) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.Wai (get, liftIO, matchStatus, post, + request, shouldRespondWith, with) -import Servant.API (JSON, Capture, Get, ReqBody, Post, QueryParam - , QueryParams, QueryFlag, MatrixParam, MatrixParams - , MatrixFlag, Raw, (:>), (:<|>)(..), Header, Delete ) -import Servant.Server (Server, serve) -import Servant.Server.Internal (RouteMismatch(..)) +import Servant.API ((:<|>) (..), (:>), Capture, Delete, + Get, Header, JSON, MatrixFlag, + MatrixParam, MatrixParams, Patch, + Post, Put, QueryFlag, QueryParam, + QueryParams, Raw, ReqBody) +import Servant.Server (Server, serve) +import Servant.Server.Internal (RouteMismatch (..)) -- * test data types @@ -69,9 +73,11 @@ spec :: Spec spec = do captureSpec getSpec + postSpec + putSpec + patchSpec queryParamSpec matrixParamSpec - postSpec headerSpec rawSpec unionSpec @@ -105,13 +111,15 @@ captureSpec = do type GetApi = Get '[JSON] Person + :<|> "empty" :> Get '[] () getApi :: Proxy GetApi getApi = Proxy getSpec :: Spec getSpec = do describe "Servant.API.Get" $ do - with (return (serve getApi (return alice))) $ do + let server = return alice :<|> return () + with (return $ serve getApi server) $ do it "allows to GET a Person" $ do response <- get "/" return response `shouldRespondWith` 200 @@ -121,6 +129,10 @@ getSpec = do it "throws 405 (wrong method) on POSTs" $ do post "/" "" `shouldRespondWith` 405 + it "returns 204 if the type is '()'" $ do + get "empty" `shouldRespondWith` ""{ matchStatus = 204 } + + type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person @@ -291,13 +303,16 @@ matrixParamSpec = do type PostApi = ReqBody '[JSON] Person :> Post '[JSON] Integer :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer + :<|> "empty" :> Post '[] () + postApi :: Proxy PostApi postApi = Proxy postSpec :: Spec postSpec = do describe "Servant.API.Post and .ReqBody" $ do - with (return (serve postApi (return . age :<|> return . age))) $ do + let server = return . age :<|> return . age :<|> return () + with (return $ serve postApi server) $ do let post' x = Test.Hspec.Wai.request methodPost x [(hContentType , "application/json;charset=utf-8")] @@ -319,11 +334,98 @@ postSpec = do it "correctly rejects invalid request bodies with status 400" $ do post' "/" "some invalid body" `shouldRespondWith` 400 + it "returns 204 if the type is '()'" $ do + post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } + it "responds with 415 if the requested media type is unsupported" $ do let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType , "application/nonsense")] post'' "/" "anything at all" `shouldRespondWith` 415 +type PutApi = + ReqBody '[JSON] Person :> Put '[JSON] Integer + :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer + :<|> "empty" :> Put '[] () + +putApi :: Proxy PutApi +putApi = Proxy + +putSpec :: Spec +putSpec = do + describe "Servant.API.Put and .ReqBody" $ do + let server = return . age :<|> return . age :<|> return () + with (return $ serve putApi server) $ do + let put' x = Test.Hspec.Wai.request methodPut x [(hContentType + , "application/json;charset=utf-8")] + + it "allows to put a Person" $ do + put' "/" (encode alice) `shouldRespondWith` "42"{ + matchStatus = 200 + } + + it "allows alternative routes if all have request bodies" $ do + put' "/bla" (encode alice) `shouldRespondWith` "42"{ + matchStatus = 200 + } + + it "handles trailing '/' gracefully" $ do + put' "/bla/" (encode alice) `shouldRespondWith` "42"{ + matchStatus = 200 + } + + it "correctly rejects invalid request bodies with status 400" $ do + put' "/" "some invalid body" `shouldRespondWith` 400 + + it "returns 204 if the type is '()'" $ do + put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } + + it "responds with 415 if the requested media type is unsupported" $ do + let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType + , "application/nonsense")] + put'' "/" "anything at all" `shouldRespondWith` 415 + +type PatchApi = + ReqBody '[JSON] Person :> Patch '[JSON] Integer + :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer + :<|> "empty" :> Patch '[] () + +patchApi :: Proxy PatchApi +patchApi = Proxy + +patchSpec :: Spec +patchSpec = do + describe "Servant.API.Patch and .ReqBody" $ do + let server = return . age :<|> return . age :<|> return () + with (return $ serve patchApi server) $ do + let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType + , "application/json;charset=utf-8")] + + it "allows to patch a Person" $ do + patch' "/" (encode alice) `shouldRespondWith` "42"{ + matchStatus = 200 + } + + it "allows alternative routes if all have request bodies" $ do + patch' "/bla" (encode alice) `shouldRespondWith` "42"{ + matchStatus = 200 + } + + it "handles trailing '/' gracefully" $ do + patch' "/bla/" (encode alice) `shouldRespondWith` "42"{ + matchStatus = 200 + } + + it "correctly rejects invalid request bodies with status 400" $ do + patch' "/" "some invalid body" `shouldRespondWith` 400 + + it "returns 204 if the type is '()'" $ do + patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } + + it "responds with 415 if the requested media type is unsupported" $ do + let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType + , "application/nonsense")] + patch'' "/" "anything at all" `shouldRespondWith` 415 + type HeaderApi a = Header "MyHeader" a :> Delete headerApi :: Proxy (HeaderApi a) headerApi = Proxy From b35512c3d4b73f3bf4ba6701bec3893f7dbd5739 Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Thu, 12 Mar 2015 18:37:08 +0100 Subject: [PATCH 2/5] Update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6a0b3e47..437c167d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,7 @@ * Support for `Accept`/`Content-type` headers and for the content-type aware combinators in *servant-0.3* * Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29) * Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21) +* Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28) 0.2.4 ----- From 622c77251e2613a3fd9b1e3bfde2ac3337c5a6ee Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 6 Apr 2015 16:12:28 +0200 Subject: [PATCH 3/5] Don't succeedWith when response content-type is unacceptable. --- src/Servant/Server/Internal.hs | 40 +++++++++++++++++----------------- test/Servant/ServerSpec.hs | 10 +++++++-- 2 files changed, 28 insertions(+), 22 deletions(-) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index b92036c6..064eddab 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -273,14 +273,14 @@ instance ( AllCTRender ctypes a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodGet = do e <- runEitherT action - respond . succeedWith $ case e of + respond $ case e of Right output -> do let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> responseLBS (mkStatus 406 "Not Acceptable") [] "" - Just (contentT, body) -> responseLBS ok200 [ ("Content-Type" - , cs contentT)] body - Left (status, message) -> + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS ok200 [ ("Content-Type" , cs contentT)] body + Left (status, message) -> succeedWith $ responseLBS (mkStatus status (cs message)) [] (cs message) | pathIsEmpty request && requestMethod request /= methodGet = respond $ failWith WrongMethod @@ -351,14 +351,14 @@ instance ( AllCTRender ctypes a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPost = do e <- runEitherT action - respond . succeedWith $ case e of + respond $ case e of Right output -> do let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> responseLBS (mkStatus 406 "") [] "" - Just (contentT, body) -> responseLBS status201 [ ("Content-Type" - , cs contentT)] body - Left (status, message) -> + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status201 [ ("Content-Type" , cs contentT)] body + Left (status, message) -> succeedWith $ responseLBS (mkStatus status (cs message)) [] (cs message) | pathIsEmpty request && requestMethod request /= methodPost = respond $ failWith WrongMethod @@ -397,14 +397,14 @@ instance ( AllCTRender ctypes a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPut = do e <- runEitherT action - respond . succeedWith $ case e of + respond $ case e of Right output -> do let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> responseLBS (mkStatus 406 "") [] "" - Just (contentT, body) -> responseLBS status200 [ ("Content-Type" - , cs contentT)] body - Left (status, message) -> + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status200 [ ("Content-Type" , cs contentT)] body + Left (status, message) -> succeedWith $ responseLBS (mkStatus status (cs message)) [] (cs message) | pathIsEmpty request && requestMethod request /= methodPut = respond $ failWith WrongMethod @@ -441,14 +441,14 @@ instance ( AllCTRender ctypes a route Proxy action request respond | pathIsEmpty request && requestMethod request == methodPatch = do e <- runEitherT action - respond . succeedWith $ case e of + respond $ case e of Right output -> do let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of - Nothing -> responseLBS (mkStatus 406 "") [] "" - Just (contentT, body) -> responseLBS status200 [ ("Content-Type" - , cs contentT)] body - Left (status, message) -> + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status200 [ ("Content-Type" , cs contentT)] body + Left (status, message) -> succeedWith $ responseLBS (mkStatus status (cs message)) [] (cs message) | pathIsEmpty request && requestMethod request /= methodPatch = respond $ failWith WrongMethod diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 6b44e409..03c7463c 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -15,6 +15,7 @@ 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 (hContentType, methodDelete, methodPatch, methodPost, methodPut, @@ -31,8 +32,9 @@ import Test.Hspec.Wai (get, liftIO, matchStatus, post, import Servant.API ((:<|>) (..), (:>), Capture, Delete, Get, Header, JSON, MatrixFlag, MatrixParam, MatrixParams, Patch, - Post, Put, QueryFlag, QueryParam, - QueryParams, Raw, ReqBody) + PlainText, Post, Put, QueryFlag, + QueryParam, QueryParams, Raw, + ReqBody) import Servant.Server (Server, serve) import Servant.Server.Internal (RouteMismatch (..)) @@ -483,6 +485,7 @@ rawSpec = do type AlternativeApi = "foo" :> Get '[JSON] Person :<|> "bar" :> Get '[JSON] Animal + :<|> "foo" :> Get '[PlainText] T.Text unionApi :: Proxy AlternativeApi unionApi = Proxy @@ -490,6 +493,7 @@ unionServer :: Server AlternativeApi unionServer = return alice :<|> return jerry + :<|> return "a string" unionSpec :: Spec unionSpec = do @@ -504,6 +508,8 @@ unionSpec = do liftIO $ do decode' (simpleBody response_) `shouldBe` Just jerry + it "checks all endpoints before returning 406" $ do + get "/foo" `shouldRespondWith` 200 -- | Test server error functionality. errorsSpec :: Spec From fed014e12024fe151bddbc5a58e627dc602a226b Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 6 Apr 2015 16:43:36 +0200 Subject: [PATCH 4/5] Pay back some test-debt --- test/Servant/ServerSpec.hs | 36 ++++++++++++++++++++++++++++-------- 1 file changed, 28 insertions(+), 8 deletions(-) diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 03c7463c..ab03ae95 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -17,7 +17,8 @@ import Data.String (fromString) import Data.String.Conversions (cs) import qualified Data.Text as T import GHC.Generics (Generic) -import Network.HTTP.Types (hContentType, methodDelete, +import Network.HTTP.Types (hAccept, hContentType, + methodDelete, methodGet, methodPatch, methodPost, methodPut, ok200, parseQuery, status409) import Network.Wai (Application, Request, pathInfo, @@ -43,7 +44,7 @@ import Servant.Server.Internal (RouteMismatch (..)) data Person = Person { name :: String, - age :: Integer + age :: Integer } deriving (Eq, Show, Generic) @@ -54,7 +55,7 @@ alice :: Person alice = Person "Alice" 42 data Animal = Animal { - species :: String, + species :: String, numberOfLegs :: Integer } deriving (Eq, Show, Generic) @@ -99,10 +100,13 @@ captureSpec :: Spec captureSpec = do describe "Servant.API.Capture" $ do with (return (serve captureApi captureServer)) $ do + it "can capture parts of the 'pathInfo'" $ do response <- get "/2" - liftIO $ do - decode' (simpleBody response) `shouldBe` Just tweety + liftIO $ decode' (simpleBody response) `shouldBe` Just tweety + + it "returns 404 if the decoding fails" $ do + get "/notAnInt" `shouldRespondWith` 404 with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) @@ -122,18 +126,23 @@ getSpec = do describe "Servant.API.Get" $ do let server = return alice :<|> return () with (return $ serve getApi server) $ do + it "allows to GET a Person" $ do response <- get "/" return response `shouldRespondWith` 200 - liftIO $ do - decode' (simpleBody response) `shouldBe` Just alice + liftIO $ decode' (simpleBody response) `shouldBe` Just alice it "throws 405 (wrong method) on POSTs" $ do post "/" "" `shouldRespondWith` 405 + post "/empty" "" `shouldRespondWith` 405 it "returns 204 if the type is '()'" $ do get "empty" `shouldRespondWith` ""{ matchStatus = 204 } + it "returns 415 if the Accept header is not supported" $ do + Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" + `shouldRespondWith` 415 + type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person @@ -486,6 +495,9 @@ type AlternativeApi = "foo" :> Get '[JSON] Person :<|> "bar" :> Get '[JSON] Animal :<|> "foo" :> Get '[PlainText] T.Text + :<|> "bar" :> Post '[JSON] Animal + :<|> "bar" :> Put '[JSON] Animal + :<|> "bar" :> Delete unionApi :: Proxy AlternativeApi unionApi = Proxy @@ -494,11 +506,15 @@ unionServer = return alice :<|> return jerry :<|> return "a string" + :<|> return jerry + :<|> return jerry + :<|> return () unionSpec :: Spec unionSpec = do describe "Servant.API.Alternative" $ do with (return $ serve unionApi unionServer) $ do + it "unions endpoints" $ do response <- get "/foo" liftIO $ do @@ -508,9 +524,13 @@ unionSpec = do liftIO $ do decode' (simpleBody response_) `shouldBe` Just jerry - it "checks all endpoints before returning 406" $ do + + it "checks all endpoints before returning 415" $ do get "/foo" `shouldRespondWith` 200 + it "returns 404 if the path does not exist" $ do + get "/nonexistent" `shouldRespondWith` 404 + -- | Test server error functionality. errorsSpec :: Spec errorsSpec = do From 2ec477159f8a3272f0a5126a37f175cee8c537ea Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 13 Apr 2015 15:13:55 +0200 Subject: [PATCH 5/5] Add server support for response headers --- CHANGELOG.md | 1 + servant-server.cabal | 1 + src/Servant/Server/Internal.hs | 159 +++++++++++++++++++++++++-------- test/Servant/ServerSpec.hs | 60 +++++++++++-- 4 files changed, 177 insertions(+), 44 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 437c167d..9b9f30b6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,7 @@ * Export `toApplication` from `Servant.Server` (https://github.com/haskell-servant/servant-server/pull/29) * Support other Monads than just `EitherT (Int, String) IO` (https://github.com/haskell-servant/servant-server/pull/21) * Make methods return status code 204 if they return () (https://github.com/haskell-servant/servant-server/issues/28) +* Add server support for response headers 0.2.4 ----- diff --git a/servant-server.cabal b/servant-server.cabal index 8061a0ba..75a54ba8 100644 --- a/servant-server.cabal +++ b/servant-server.cabal @@ -80,6 +80,7 @@ test-suite spec base == 4.* , aeson , bytestring + , bytestring-conversion , directory , either , exceptions diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs index 064eddab..9e64dafc 100644 --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -1,45 +1,53 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Servant.Server.Internal where -import Control.Applicative ((<$>)) -import Control.Monad.Trans.Either (EitherT, runEitherT) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.IORef (newIORef, readIORef, writeIORef) -import Data.List (unfoldr) -import Data.Maybe (catMaybes, fromMaybe) -import Data.Monoid (Monoid, mempty, mappend) -import Data.String (fromString) -import Data.String.Conversions (cs, (<>)) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Typeable -import GHC.TypeLits (KnownSymbol, symbolVal) -import Network.HTTP.Types hiding (Header) -import Network.Wai ( Response, Request, ResponseReceived, Application - , pathInfo, requestBody, strictRequestBody - , lazyRequestBody, requestHeaders, requestMethod, - rawQueryString, responseLBS) -import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header - , MatrixParams, MatrixParam, MatrixFlag - , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..)) -import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..) - , AllCTUnrender(..),) -import Servant.Common.Text (FromText, fromText) +import Control.Applicative ((<$>)) +import Control.Monad.Trans.Either (EitherT, runEitherT) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.List (unfoldr) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Monoid (Monoid, mappend, mempty) +import Data.String (fromString) +import Data.String.Conversions (cs, (<>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Typeable +import GHC.TypeLits (KnownSymbol, symbolVal) +import Network.HTTP.Types hiding (Header, ResponseHeaders) +import Network.Wai (Application, Request, Response, + ResponseReceived, lazyRequestBody, + pathInfo, rawQueryString, + requestBody, requestHeaders, + requestMethod, responseLBS, + strictRequestBody) +import Servant.API ((:<|>) (..), (:>), Capture, + Delete, Get, Header, MatrixFlag, + MatrixParam, MatrixParams, Patch, + Post, Put, QueryFlag, QueryParam, + QueryParams, Raw, ReqBody) +import Servant.API.ContentTypes (AcceptHeader (..), + AllCTRender (..), + AllCTUnrender (..)) +import Servant.API.ResponseHeaders (Headers, getResponse, getHeaders) +import Servant.Common.Text (FromText, fromText) data ReqBodyState = Uncalled | Called !B.ByteString | Done !B.ByteString + toApplication :: RoutingApplication -> Application toApplication ra request respond = do reqBodyRef <- newIORef Uncalled @@ -286,6 +294,7 @@ instance ( AllCTRender ctypes a respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound +-- '()' ==> 204 No Content instance HasServer (Get ctypes ()) where type ServerT (Get ctypes ()) m = m () route Proxy action request respond @@ -299,6 +308,26 @@ instance HasServer (Get ctypes ()) where respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound +-- Add response headers +instance ( AllCTRender ctypes v ) => HasServer (Get ctypes (Headers h v)) where + type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) + route Proxy action request respond + | pathIsEmpty request && requestMethod request == methodGet = do + e <- runEitherT action + respond $ case e of + Right output -> do + let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request + headers = getHeaders output + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body + Left (status, message) -> succeedWith $ + responseLBS (mkStatus status (cs message)) [] (cs message) + | pathIsEmpty request && requestMethod request /= methodGet = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by 'Header'. @@ -377,6 +406,26 @@ instance HasServer (Post ctypes ()) where respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound +-- Add response headers +instance ( AllCTRender ctypes v ) => HasServer (Post ctypes (Headers h v)) where + type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) + route Proxy action request respond + | pathIsEmpty request && requestMethod request == methodPost = do + e <- runEitherT action + respond $ case e of + Right output -> do + let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request + headers = getHeaders output + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body + Left (status, message) -> succeedWith $ + responseLBS (mkStatus status (cs message)) [] (cs message) + | pathIsEmpty request && requestMethod request /= methodPost = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + -- | When implementing the handler for a 'Put' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- and 'Servant.API.Post.Post', the handler code runs in the @@ -387,7 +436,7 @@ instance HasServer (Post ctypes ()) where -- -- If successfully returning a value, we use the type-level list, combined -- with the request's @Accept@ header, to encode the value for you --- (returning a status code of 201). If there was no @Accept@ header or it +-- (returning a status code of 200). If there was no @Accept@ header or it -- was @*/*@, we return encode using the first @Content-Type@ type on the -- list. instance ( AllCTRender ctypes a @@ -423,6 +472,26 @@ instance HasServer (Put ctypes ()) where respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound +-- Add response headers +instance ( AllCTRender ctypes v ) => HasServer (Put ctypes (Headers h v)) where + type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) + route Proxy action request respond + | pathIsEmpty request && requestMethod request == methodPut = do + e <- runEitherT action + respond $ case e of + Right output -> do + let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request + headers = getHeaders output + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body + Left (status, message) -> succeedWith $ + responseLBS (mkStatus status (cs message)) [] (cs message) + | pathIsEmpty request && requestMethod request /= methodPut = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + -- | When implementing the handler for a 'Patch' endpoint, -- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' -- and 'Servant.API.Put.Put', the handler code runs in the @@ -433,7 +502,7 @@ instance HasServer (Put ctypes ()) where -- -- If successfully returning a value, we just require that its type has -- a 'ToJSON' instance and servant takes care of encoding it for you, --- yielding status code 201 along the way. +-- yielding status code 200 along the way. instance ( AllCTRender ctypes a ) => HasServer (Patch ctypes a) where type ServerT (Patch ctypes a) m = m a @@ -467,6 +536,26 @@ instance HasServer (Patch ctypes ()) where respond $ failWith WrongMethod | otherwise = respond $ failWith NotFound +-- Add response headers +instance ( AllCTRender ctypes v ) => HasServer (Patch ctypes (Headers h v)) where + type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) + route Proxy action request respond + | pathIsEmpty request && requestMethod request == methodPatch = do + e <- runEitherT action + respond $ case e of + Right outpatch -> do + let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request + headers = getHeaders outpatch + case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of + Nothing -> failWith UnsupportedMediaType + Just (contentT, body) -> succeedWith $ + responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body + Left (status, message) -> succeedWith $ + responseLBS (mkStatus status (cs message)) [] (cs message) + | pathIsEmpty request && requestMethod request /= methodPatch = + respond $ failWith WrongMethod + | otherwise = respond $ failWith NotFound + -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @'Maybe' 'Text'@. diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index ab03ae95..58ef1244 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -3,13 +3,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module Servant.ServerSpec where -import Control.Monad (when) +import Control.Monad (forM_, when) import Control.Monad.Trans.Either (EitherT, left) import Data.Aeson (FromJSON, ToJSON, decode', encode) +import Data.ByteString.Conversion () import Data.Char (toUpper) import Data.Monoid ((<>)) import Data.Proxy (Proxy (Proxy)) @@ -27,15 +30,17 @@ import Network.Wai (Application, Request, pathInfo, import Network.Wai.Test (defaultRequest, request, runSession, simpleBody) import Test.Hspec (Spec, describe, it, shouldBe) -import Test.Hspec.Wai (get, liftIO, matchStatus, post, - request, shouldRespondWith, with) +import Test.Hspec.Wai (get, liftIO, matchHeaders, + matchStatus, post, request, + shouldRespondWith, with, (<:>)) -import Servant.API ((:<|>) (..), (:>), Capture, Delete, - Get, Header, JSON, MatrixFlag, - MatrixParam, MatrixParams, Patch, - PlainText, Post, Put, QueryFlag, - QueryParam, QueryParams, Raw, - ReqBody) +import Servant.API ((:<|>) (..), (:>), + AddHeader (addHeader), Capture, + Delete, Get, Header (..), Headers, + JSON, MatrixFlag, MatrixParam, + MatrixParams, Patch, PlainText, + Post, Put, QueryFlag, QueryParam, + QueryParams, Raw, ReqBody) import Servant.Server (Server, serve) import Servant.Server.Internal (RouteMismatch (..)) @@ -85,6 +90,7 @@ spec = do rawSpec unionSpec errorsSpec + responseHeadersSpec type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal @@ -531,6 +537,42 @@ unionSpec = do it "returns 404 if the path does not exist" $ do get "/nonexistent" `shouldRespondWith` 404 +type ResponseHeadersApi = + Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) + :<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) + :<|> Put '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) + :<|> Patch '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) + + +responseHeadersServer :: Server ResponseHeadersApi +responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi" + in h :<|> h :<|> h :<|> h + + +responseHeadersSpec :: Spec +responseHeadersSpec = describe "ResponseHeaders" $ do + with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do + + let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)] + + it "includes the headers in the response" $ + forM_ methods $ \(method, expected) -> + Test.Hspec.Wai.request method "/" [] "" + `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"] + , matchStatus = expected + } + + it "responds with not found for non-existent endpoints" $ + forM_ methods $ \(method,_) -> + Test.Hspec.Wai.request method "blahblah" [] "" + `shouldRespondWith` 404 + + it "returns 415 if the Accept header is not supported" $ + forM_ methods $ \(method,_) -> + Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" + `shouldRespondWith` 415 + + -- | Test server error functionality. errorsSpec :: Spec errorsSpec = do