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

Merge pull request #177 from codedmart/methodHead

Browse source 
Respond with Head to all Get requests
This commit is contained in:
Julian Arni 2015-08-01 20:16:42 +02:00
commit 38ca8d54d0
2 changed files with 61 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

46
servant-server/src/Servant/Server/Internal.hs
View file

@ -25,10 +25,11 @@ import Control.Applicative ((<$>))
#endif #endif
import Control.Monad.Trans.Either (EitherT) import Control.Monad.Trans.Either (EitherT)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe) import Data.Maybe (catMaybes, fromMaybe)
import Data.String (fromString) import Data.String (fromString)
import Data.String.Conversions (cs, (<>)) import Data.String.Conversions (cs, (<>), ConvertibleStrings)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.Encoding (decodeUtf8, encodeUtf8)
@ -39,7 +40,8 @@ import Network.Socket (SockAddr)
import Network.Wai (Application, lazyRequestBody, import Network.Wai (Application, lazyRequestBody,
rawQueryString, requestHeaders, rawQueryString, requestHeaders,
requestMethod, responseLBS, remoteHost, requestMethod, responseLBS, remoteHost,
isSecure, vault, httpVersion) isSecure, vault, httpVersion, Response,
Request)
import Servant.API ((:<|>) (..), (:>), Capture, import Servant.API ((:<|>) (..), (:>), Capture,
Delete, Get, Header, Delete, Get, Header,
IsSecure(..), MatrixFlag, MatrixParam, IsSecure(..), MatrixFlag, MatrixParam,
@ -121,6 +123,24 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
Just v -> feedTo subserver v) Just v -> feedTo subserver v)
where captureProxy = Proxy :: Proxy (Capture capture a) where captureProxy = Proxy :: Proxy (Capture capture a)
allowedMethodHead :: Method -> Request -> Bool
allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
allowedMethod :: Method -> Request -> Bool
allowedMethod method request = allowedMethodHead method request || requestMethod request == method
processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
=> Maybe (a, BL.ByteString) -> Status -> Method
-> Maybe [(HeaderName, B.ByteString)]
-> Request -> RouteResult Response
processMethodRouter handleA status method headers request = case handleA of
Nothing -> failWith UnsupportedMediaType
Just (contentT, body) -> succeedWith $ responseLBS status hdrs bdy
where
bdy = case allowedMethodHead method request of
True -> ""
False -> body
hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
methodRouter :: (AllCTRender ctypes a) methodRouter :: (AllCTRender ctypes a)
=> Method -> Proxy ctypes -> Status => Method -> Proxy ctypes -> Status
@ -129,13 +149,11 @@ methodRouter :: (AllCTRender ctypes a)
methodRouter method proxy status action = LeafRouter route' methodRouter method proxy status action = LeafRouter route'
where where
route' request respond route' request respond
| pathIsEmpty request && requestMethod request == method = do | pathIsEmpty request && allowedMethod method request = do
runAction action respond $ \ output -> do runAction action respond $ \ output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
case handleAcceptH proxy (AcceptHeader accH) output of handleA = handleAcceptH proxy (AcceptHeader accH) output
Nothing -> failWith UnsupportedMediaType processMethodRouter handleA status method Nothing request
Just (contentT, body) -> succeedWith $
responseLBS status [ ("Content-Type" , cs contentT)] body
| pathIsEmpty request && requestMethod request /= method = | pathIsEmpty request && requestMethod request /= method =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -147,14 +165,12 @@ methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
methodRouterHeaders method proxy status action = LeafRouter route' methodRouterHeaders method proxy status action = LeafRouter route'
where where
route' request respond route' request respond
| pathIsEmpty request && requestMethod request == method = do | pathIsEmpty request && allowedMethod method request = do
runAction action respond $ \ output -> do runAction action respond $ \ output -> do
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
headers = getHeaders output headers = getHeaders output
case handleAcceptH proxy (AcceptHeader accH) (getResponse output) of handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
Nothing -> failWith UnsupportedMediaType processMethodRouter handleA status method (Just headers) request
Just (contentT, body) -> succeedWith $
responseLBS status ( ("Content-Type" , cs contentT) : headers) body
| pathIsEmpty request && requestMethod request /= method = | pathIsEmpty request && requestMethod request /= method =
respond $ failWith WrongMethod respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith NotFound
@ -165,7 +181,7 @@ methodRouterEmpty :: Method
methodRouterEmpty method action = LeafRouter route' methodRouterEmpty method action = LeafRouter route'
where where
route' request respond route' request respond
| pathIsEmpty request && requestMethod request == method = do | pathIsEmpty request && allowedMethod method request = do
runAction action respond $ \ () -> runAction action respond $ \ () ->
succeedWith $ responseLBS noContent204 [] "" succeedWith $ responseLBS noContent204 [] ""
| pathIsEmpty request && requestMethod request /= method = | pathIsEmpty request && requestMethod request /= method =
@ -612,7 +628,6 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
values = catMaybes $ map (convert . snd) parameters values = catMaybes $ map (convert . snd) parameters
route (Proxy :: Proxy sublayout) (feedTo subserver values) route (Proxy :: Proxy sublayout) (feedTo subserver values)
_ -> route (Proxy :: Proxy sublayout) (feedTo subserver []) _ -> route (Proxy :: Proxy sublayout) (feedTo subserver [])
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing convert Nothing = Nothing
@ -644,11 +659,8 @@ instance (KnownSymbol sym, HasServer sublayout)
Just Nothing -> True -- param is there, with no value Just Nothing -> True -- param is there, with no value
Just (Just v) -> examine v -- param with a value Just (Just v) -> examine v -- param with a value
Nothing -> False -- param not in the query string Nothing -> False -- param not in the query string
route (Proxy :: Proxy sublayout) (feedTo subserver param) route (Proxy :: Proxy sublayout) (feedTo subserver param)
_ -> route (Proxy :: Proxy sublayout) (feedTo subserver False) _ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False | otherwise = False

36
servant-server/test/Servant/ServerSpec.hs
View file

@ -21,7 +21,7 @@ import Data.String.Conversions (cs)
import qualified Data.Text as T import qualified Data.Text as T
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Network.HTTP.Types (hAccept, hContentType, import Network.HTTP.Types (hAccept, hContentType,
methodDelete, methodGet, methodDelete, methodGet, methodHead,
methodPatch, methodPost, methodPut, methodPatch, methodPost, methodPut,
ok200, parseQuery, status409) ok200, parseQuery, status409)
import Network.Wai (Application, Request, pathInfo, import Network.Wai (Application, Request, pathInfo,
@ -33,7 +33,6 @@ import Test.Hspec (Spec, describe, it, shouldBe)
import Test.Hspec.Wai (get, liftIO, matchHeaders, import Test.Hspec.Wai (get, liftIO, matchHeaders,
matchStatus, post, request, matchStatus, post, request,
shouldRespondWith, with, (<:>)) shouldRespondWith, with, (<:>))
import Servant.API ((:<|>) (..), (:>), import Servant.API ((:<|>) (..), (:>),
addHeader, Capture, addHeader, Capture,
Delete, Get, Header (..), Headers, Delete, Get, Header (..), Headers,
@ -82,6 +81,7 @@ spec :: Spec
spec = do spec = do
captureSpec captureSpec
getSpec getSpec
headSpec
postSpec postSpec
putSpec putSpec
patchSpec patchSpec
@ -127,13 +127,14 @@ captureSpec = do
type GetApi = Get '[JSON] Person type GetApi = Get '[JSON] Person
:<|> "empty" :> Get '[] () :<|> "empty" :> Get '[] ()
:<|> "post" :> Post '[] ()
getApi :: Proxy GetApi getApi :: Proxy GetApi
getApi = Proxy getApi = Proxy
getSpec :: Spec getSpec :: Spec
getSpec = do getSpec = do
describe "Servant.API.Get" $ do describe "Servant.API.Get" $ do
let server = return alice :<|> return () let server = return alice :<|> return () :<|> return ()
with (return $ serve getApi server) $ do with (return $ serve getApi server) $ do
it "allows to GET a Person" $ do it "allows to GET a Person" $ do
@ -146,13 +147,40 @@ getSpec = do
post "/empty" "" `shouldRespondWith` 405 post "/empty" "" `shouldRespondWith` 405
it "returns 204 if the type is '()'" $ do it "returns 204 if the type is '()'" $ do
get "empty" `shouldRespondWith` ""{ matchStatus = 204 } get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }
it "returns 415 if the Accept header is not supported" $ do it "returns 415 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415 `shouldRespondWith` 415
headSpec :: Spec
headSpec = do
describe "Servant.API.Head" $ do
let server = return alice :<|> return () :<|> return ()
with (return $ serve getApi server) $ do
it "allows to GET a Person" $ do
response <- Test.Hspec.Wai.request methodHead "/" [] ""
return response `shouldRespondWith` 200
liftIO $ decode' (simpleBody response) `shouldBe` (Nothing :: Maybe Person)
it "does not allow HEAD to POST route" $ do
response <- Test.Hspec.Wai.request methodHead "/post" [] ""
return response `shouldRespondWith` 405
it "throws 405 (wrong method) on POSTs" $ do
post "/" "" `shouldRespondWith` 405
post "/empty" "" `shouldRespondWith` 405
it "returns 204 if the type is '()'" $ do
response <- Test.Hspec.Wai.request methodHead "/empty" [] ""
return response `shouldRespondWith` ""{ matchStatus = 204 }
it "returns 415 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
:<|> "a" :> QueryParams "names" String :> Get '[JSON] Person :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person