Merge pull request #177 from codedmart/methodHead
Respond with Head to all Get requests
This commit is contained in:
Julian Arni
commit
38ca8d54d0
2 changed files with 61 additions and 21 deletions
|
|
@ -25,10 +25,11 @@ import Control.Applicative ((<$>))
|
|||
#endif
|
||||
import Control.Monad.Trans.Either (EitherT)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (catMaybes, fromMaybe)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs, (<>))
|
||||
import Data.String.Conversions (cs, (<>), ConvertibleStrings)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||
|
|
@ -39,7 +40,8 @@ import Network.Socket (SockAddr)
|
|||
import Network.Wai (Application, lazyRequestBody,
|
||||
rawQueryString, requestHeaders,
|
||||
requestMethod, responseLBS, remoteHost,
|
||||
isSecure, vault, httpVersion)
|
||||
isSecure, vault, httpVersion, Response,
|
||||
Request)
|
||||
import Servant.API ((:<|>) (..), (:>), Capture,
|
||||
Delete, Get, Header,
|
||||
IsSecure(..), MatrixFlag, MatrixParam,
|
||||
|
|
@ -121,6 +123,24 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
|
|||
Just v -> feedTo subserver v)
|
||||
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)
|
||||
=> Method -> Proxy ctypes -> Status
|
||||
|
|
@ -129,13 +149,11 @@ methodRouter :: (AllCTRender ctypes a)
|
|||
methodRouter method proxy status action = LeafRouter route'
|
||||
where
|
||||
route' request respond
|
||||
| pathIsEmpty request && requestMethod request == method = do
|
||||
| pathIsEmpty request && allowedMethod method request = do
|
||||
runAction action respond $ \ output -> do
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
case handleAcceptH proxy (AcceptHeader accH) output of
|
||||
Nothing -> failWith UnsupportedMediaType
|
||||
Just (contentT, body) -> succeedWith $
|
||||
responseLBS status [ ("Content-Type" , cs contentT)] body
|
||||
handleA = handleAcceptH proxy (AcceptHeader accH) output
|
||||
processMethodRouter handleA status method Nothing request
|
||||
| pathIsEmpty request && requestMethod request /= method =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
|
@ -147,14 +165,12 @@ methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
|
|||
methodRouterHeaders method proxy status action = LeafRouter route'
|
||||
where
|
||||
route' request respond
|
||||
| pathIsEmpty request && requestMethod request == method = do
|
||||
| pathIsEmpty request && allowedMethod method request = do
|
||||
runAction action respond $ \ output -> do
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
headers = getHeaders output
|
||||
case handleAcceptH proxy (AcceptHeader accH) (getResponse output) of
|
||||
Nothing -> failWith UnsupportedMediaType
|
||||
Just (contentT, body) -> succeedWith $
|
||||
responseLBS status ( ("Content-Type" , cs contentT) : headers) body
|
||||
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
|
||||
processMethodRouter handleA status method (Just headers) request
|
||||
| pathIsEmpty request && requestMethod request /= method =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
|
|
@ -165,7 +181,7 @@ methodRouterEmpty :: Method
|
|||
methodRouterEmpty method action = LeafRouter route'
|
||||
where
|
||||
route' request respond
|
||||
| pathIsEmpty request && requestMethod request == method = do
|
||||
| pathIsEmpty request && allowedMethod method request = do
|
||||
runAction action respond $ \ () ->
|
||||
succeedWith $ responseLBS noContent204 [] ""
|
||||
| pathIsEmpty request && requestMethod request /= method =
|
||||
|
|
@ -612,7 +628,6 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
|
|||
values = catMaybes $ map (convert . snd) parameters
|
||||
route (Proxy :: Proxy sublayout) (feedTo subserver values)
|
||||
_ -> route (Proxy :: Proxy sublayout) (feedTo subserver [])
|
||||
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
|
||||
convert Nothing = Nothing
|
||||
|
|
@ -644,11 +659,8 @@ instance (KnownSymbol sym, HasServer sublayout)
|
|||
Just Nothing -> True -- param is there, with no value
|
||||
Just (Just v) -> examine v -- param with a value
|
||||
Nothing -> False -- param not in the query string
|
||||
|
||||
route (Proxy :: Proxy sublayout) (feedTo subserver param)
|
||||
|
||||
_ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)
|
||||
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
examine v | v == "true" || v == "1" || v == "" = True
|
||||
| otherwise = False
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ import Data.String.Conversions (cs)
|
|||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Types (hAccept, hContentType,
|
||||
methodDelete, methodGet,
|
||||
methodDelete, methodGet, methodHead,
|
||||
methodPatch, methodPost, methodPut,
|
||||
ok200, parseQuery, status409)
|
||||
import Network.Wai (Application, Request, pathInfo,
|
||||
|
|
@ -33,7 +33,6 @@ import Test.Hspec (Spec, describe, it, shouldBe)
|
|||
import Test.Hspec.Wai (get, liftIO, matchHeaders,
|
||||
matchStatus, post, request,
|
||||
shouldRespondWith, with, (<:>))
|
||||
|
||||
import Servant.API ((:<|>) (..), (:>),
|
||||
addHeader, Capture,
|
||||
Delete, Get, Header (..), Headers,
|
||||
|
|
@ -82,6 +81,7 @@ spec :: Spec
|
|||
spec = do
|
||||
captureSpec
|
||||
getSpec
|
||||
headSpec
|
||||
postSpec
|
||||
putSpec
|
||||
patchSpec
|
||||
|
|
@ -127,13 +127,14 @@ captureSpec = do
|
|||
|
||||
type GetApi = Get '[JSON] Person
|
||||
:<|> "empty" :> Get '[] ()
|
||||
:<|> "post" :> Post '[] ()
|
||||
getApi :: Proxy GetApi
|
||||
getApi = Proxy
|
||||
|
||||
getSpec :: Spec
|
||||
getSpec = do
|
||||
describe "Servant.API.Get" $ do
|
||||
let server = return alice :<|> return ()
|
||||
let server = return alice :<|> return () :<|> return ()
|
||||
with (return $ serve getApi server) $ do
|
||||
|
||||
it "allows to GET a Person" $ do
|
||||
|
|
@ -146,13 +147,40 @@ getSpec = do
|
|||
post "/empty" "" `shouldRespondWith` 405
|
||||
|
||||
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
|
||||
Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
|
||||
`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
|
||||
:<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
|
||||
|
|
|
|||
Loading…
Reference in a new issue