eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge pull request #41 from haskell-servant/jkarni/response-headers

Browse source 
Add server support for response headers
This commit is contained in:
Julian Arni 2015-04-16 20:53:13 +02:00
commit f6f120ded9
4 changed files with 177 additions and 44 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
CHANGELOG.md
View file

@ -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
-----

1
servant-server.cabal
View file

@ -80,6 +80,7 @@ test-suite spec
base == 4.*
, aeson
, bytestring
, bytestring-conversion
, directory
, either
, exceptions

125
src/Servant/Server/Internal.hs
View file

@ -1,11 +1,12 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.Server.Internal where
import Control.Applicative ((<$>))
@ -15,24 +16,30 @@ 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.Monoid (Monoid, mappend, mempty)
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.Text.Encoding (decodeUtf8, encodeUtf8)
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 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)
@ -40,6 +47,7 @@ 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'@.

60
test/Servant/ServerSpec.hs
View file

@ -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