git.iko.soy/servant
on master help sign in
Merge pull request #177 from codedmart/methodHead
38ca8d5Julian Arni
servant-server/src/Servant/Server/Internal.hs+29−17
compare with master
unifiedsplit
@@ -25,10 +25,11 @@ import Control.Applicative ((<$>))
25#endif
25#endif
26import Control.Monad.Trans.Either (EitherT)
26import Control.Monad.Trans.Either (EitherT)
27import qualified Data.ByteString as B
27import qualified Data.ByteString as B
28+import qualified Data.ByteString.Lazy as BL
28import qualified Data.Map as M
29import qualified Data.Map as M
29import Data.Maybe (catMaybes, fromMaybe)
30import Data.Maybe (catMaybes, fromMaybe)
30import Data.String (fromString)
31import Data.String (fromString)
31−import Data.String.Conversions (cs, (<>))
32+import Data.String.Conversions (cs, (<>), ConvertibleStrings)
32import Data.Text (Text)
33import Data.Text (Text)
33import qualified Data.Text as T
34import qualified Data.Text as T
34import Data.Text.Encoding (decodeUtf8, encodeUtf8)
35import Data.Text.Encoding (decodeUtf8, encodeUtf8)
@@ -39,7 +40,8 @@ import Network.Socket (SockAddr)
39import Network.Wai (Application, lazyRequestBody,
40import Network.Wai (Application, lazyRequestBody,
40 rawQueryString, requestHeaders,
41 rawQueryString, requestHeaders,
41 requestMethod, responseLBS, remoteHost,
42 requestMethod, responseLBS, remoteHost,
42− isSecure, vault, httpVersion)
43+ isSecure, vault, httpVersion, Response,
44+ Request)
43import Servant.API ((:<|>) (..), (:>), Capture,
45import Servant.API ((:<|>) (..), (:>), Capture,
44 Delete, Get, Header,
46 Delete, Get, Header,
45 IsSecure(..), MatrixFlag, MatrixParam,
47 IsSecure(..), MatrixFlag, MatrixParam,
@@ -121,6 +123,24 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
121 Just v -> feedTo subserver v)
123 Just v -> feedTo subserver v)
122 where captureProxy = Proxy :: Proxy (Capture capture a)
124 where captureProxy = Proxy :: Proxy (Capture capture a)
123
125
126+allowedMethodHead :: Method -> Request -> Bool
127+allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
128+
129+allowedMethod :: Method -> Request -> Bool
130+allowedMethod method request = allowedMethodHead method request || requestMethod request == method
131+
132+processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
133+ => Maybe (a, BL.ByteString) -> Status -> Method
134+ -> Maybe [(HeaderName, B.ByteString)]
135+ -> Request -> RouteResult Response
136+processMethodRouter handleA status method headers request = case handleA of
137+ Nothing -> failWith UnsupportedMediaType
138+ Just (contentT, body) -> succeedWith $ responseLBS status hdrs bdy
139+ where
140+ bdy = case allowedMethodHead method request of
141+ True -> ""
142+ False -> body
143+ hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
124
144
125methodRouter :: (AllCTRender ctypes a)
145methodRouter :: (AllCTRender ctypes a)
126 => Method -> Proxy ctypes -> Status
146 => Method -> Proxy ctypes -> Status
@@ -129,13 +149,11 @@ methodRouter :: (AllCTRender ctypes a)
129methodRouter method proxy status action = LeafRouter route'
149methodRouter method proxy status action = LeafRouter route'
130 where
150 where
131 route' request respond
151 route' request respond
132− | pathIsEmpty request && requestMethod request == method = do
152+ | pathIsEmpty request && allowedMethod method request = do
133 runAction action respond $ \ output -> do
153 runAction action respond $ \ output -> do
134 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
154 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
135− case handleAcceptH proxy (AcceptHeader accH) output of
155+ handleA = handleAcceptH proxy (AcceptHeader accH) output
136− Nothing -> failWith UnsupportedMediaType
156+ processMethodRouter handleA status method Nothing request
137− Just (contentT, body) -> succeedWith $
138− responseLBS status [ ("Content-Type" , cs contentT)] body
139 | pathIsEmpty request && requestMethod request /= method =
157 | pathIsEmpty request && requestMethod request /= method =
140 respond $ failWith WrongMethod
158 respond $ failWith WrongMethod
141 | otherwise = respond $ failWith NotFound
159 | otherwise = respond $ failWith NotFound
@@ -147,14 +165,12 @@ methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
147methodRouterHeaders method proxy status action = LeafRouter route'
165methodRouterHeaders method proxy status action = LeafRouter route'
148 where
166 where
149 route' request respond
167 route' request respond
150− | pathIsEmpty request && requestMethod request == method = do
168+ | pathIsEmpty request && allowedMethod method request = do
151 runAction action respond $ \ output -> do
169 runAction action respond $ \ output -> do
152 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
170 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
153 headers = getHeaders output
171 headers = getHeaders output
154− case handleAcceptH proxy (AcceptHeader accH) (getResponse output) of
172+ handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
155− Nothing -> failWith UnsupportedMediaType
173+ processMethodRouter handleA status method (Just headers) request
156− Just (contentT, body) -> succeedWith $
157− responseLBS status ( ("Content-Type" , cs contentT) : headers) body
158 | pathIsEmpty request && requestMethod request /= method =
174 | pathIsEmpty request && requestMethod request /= method =
159 respond $ failWith WrongMethod
175 respond $ failWith WrongMethod
160 | otherwise = respond $ failWith NotFound
176 | otherwise = respond $ failWith NotFound
@@ -165,7 +181,7 @@ methodRouterEmpty :: Method
165methodRouterEmpty method action = LeafRouter route'
181methodRouterEmpty method action = LeafRouter route'
166 where
182 where
167 route' request respond
183 route' request respond
168− | pathIsEmpty request && requestMethod request == method = do
184+ | pathIsEmpty request && allowedMethod method request = do
169 runAction action respond $ \ () ->
185 runAction action respond $ \ () ->
170 succeedWith $ responseLBS noContent204 [] ""
186 succeedWith $ responseLBS noContent204 [] ""
171 | pathIsEmpty request && requestMethod request /= method =
187 | pathIsEmpty request && requestMethod request /= method =
@@ -612,7 +628,6 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
612 values = catMaybes $ map (convert . snd) parameters
628 values = catMaybes $ map (convert . snd) parameters
613 route (Proxy :: Proxy sublayout) (feedTo subserver values)
629 route (Proxy :: Proxy sublayout) (feedTo subserver values)
614 _ -> route (Proxy :: Proxy sublayout) (feedTo subserver [])
630 _ -> route (Proxy :: Proxy sublayout) (feedTo subserver [])
615−
616 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
631 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
617 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
632 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
618 convert Nothing = Nothing
633 convert Nothing = Nothing
@@ -644,11 +659,8 @@ instance (KnownSymbol sym, HasServer sublayout)
644 Just Nothing -> True -- param is there, with no value
659 Just Nothing -> True -- param is there, with no value
645 Just (Just v) -> examine v -- param with a value
660 Just (Just v) -> examine v -- param with a value
646 Nothing -> False -- param not in the query string
661 Nothing -> False -- param not in the query string
647−
648 route (Proxy :: Proxy sublayout) (feedTo subserver param)
662 route (Proxy :: Proxy sublayout) (feedTo subserver param)
649−
650 _ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)
663 _ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)
651−
652 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
664 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
653 examine v | v == "true" || v == "1" || v == "" = True
665 examine v | v == "true" || v == "1" || v == "" = True
654 | otherwise = False
666 | otherwise = False
servant-server/test/Servant/ServerSpec.hs+32−4
@@ -21,7 +21,7 @@ import Data.String.Conversions (cs)
21import qualified Data.Text as T
21import qualified Data.Text as T
22import GHC.Generics (Generic)
22import GHC.Generics (Generic)
23import Network.HTTP.Types (hAccept, hContentType,
23import Network.HTTP.Types (hAccept, hContentType,
24− methodDelete, methodGet,
24+ methodDelete, methodGet, methodHead,
25 methodPatch, methodPost, methodPut,
25 methodPatch, methodPost, methodPut,
26 ok200, parseQuery, status409)
26 ok200, parseQuery, status409)
27import Network.Wai (Application, Request, pathInfo,
27import Network.Wai (Application, Request, pathInfo,
@@ -33,7 +33,6 @@ import Test.Hspec (Spec, describe, it, shouldBe)
33import Test.Hspec.Wai (get, liftIO, matchHeaders,
33import Test.Hspec.Wai (get, liftIO, matchHeaders,
34 matchStatus, post, request,
34 matchStatus, post, request,
35 shouldRespondWith, with, (<:>))
35 shouldRespondWith, with, (<:>))
36−
37import Servant.API ((:<|>) (..), (:>),
36import Servant.API ((:<|>) (..), (:>),
38 addHeader, Capture,
37 addHeader, Capture,
39 Delete, Get, Header (..), Headers,
38 Delete, Get, Header (..), Headers,
@@ -82,6 +81,7 @@ spec :: Spec
82spec = do
81spec = do
83 captureSpec
82 captureSpec
84 getSpec
83 getSpec
84+ headSpec
85 postSpec
85 postSpec
86 putSpec
86 putSpec
87 patchSpec
87 patchSpec
@@ -127,13 +127,14 @@ captureSpec = do
127
127
128type GetApi = Get '[JSON] Person
128type GetApi = Get '[JSON] Person
129 :<|> "empty" :> Get '[] ()
129 :<|> "empty" :> Get '[] ()
130+ :<|> "post" :> Post '[] ()
130getApi :: Proxy GetApi
131getApi :: Proxy GetApi
131getApi = Proxy
132getApi = Proxy
132
133
133getSpec :: Spec
134getSpec :: Spec
134getSpec = do
135getSpec = do
135 describe "Servant.API.Get" $ do
136 describe "Servant.API.Get" $ do
136− let server = return alice :<|> return ()
137+ let server = return alice :<|> return () :<|> return ()
137 with (return $ serve getApi server) $ do
138 with (return $ serve getApi server) $ do
138
139
139 it "allows to GET a Person" $ do
140 it "allows to GET a Person" $ do
@@ -146,13 +147,40 @@ getSpec = do
146 post "/empty" "" `shouldRespondWith` 405
147 post "/empty" "" `shouldRespondWith` 405
147
148
148 it "returns 204 if the type is '()'" $ do
149 it "returns 204 if the type is '()'" $ do
149− get "empty" `shouldRespondWith` ""{ matchStatus = 204 }
150+ get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }
150
151
151 it "returns 415 if the Accept header is not supported" $ do
152 it "returns 415 if the Accept header is not supported" $ do
152 Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
153 Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
153 `shouldRespondWith` 415
154 `shouldRespondWith` 415
154
155
155
156
157+headSpec :: Spec
158+headSpec = do
159+ describe "Servant.API.Head" $ do
160+ let server = return alice :<|> return () :<|> return ()
161+ with (return $ serve getApi server) $ do
162+
163+ it "allows to GET a Person" $ do
164+ response <- Test.Hspec.Wai.request methodHead "/" [] ""
165+ return response `shouldRespondWith` 200
166+ liftIO $ decode' (simpleBody response) `shouldBe` (Nothing :: Maybe Person)
167+
168+ it "does not allow HEAD to POST route" $ do
169+ response <- Test.Hspec.Wai.request methodHead "/post" [] ""
170+ return response `shouldRespondWith` 405
171+
172+ it "throws 405 (wrong method) on POSTs" $ do
173+ post "/" "" `shouldRespondWith` 405
174+ post "/empty" "" `shouldRespondWith` 405
175+
176+ it "returns 204 if the type is '()'" $ do
177+ response <- Test.Hspec.Wai.request methodHead "/empty" [] ""
178+ return response `shouldRespondWith` ""{ matchStatus = 204 }
179+
180+ it "returns 415 if the Accept header is not supported" $ do
181+ Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
182+ `shouldRespondWith` 415
183+
156
184
157type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
185type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
158 :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
186 :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person