From 2ec477159f8a3272f0a5126a37f175cee8c537ea Mon Sep 17 00:00:00 2001 From: "Julian K. Arni" Date: Mon, 13 Apr 2015 15:13:55 +0200 Subject: [PATCH] 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