@@ -25,10 +25,11 @@ import Control.Applicative ((<$>))
2525#endif
2626import Control.Monad.Trans.Either (EitherT)
2727import qualified Data.ByteString as B
28+import qualified Data.ByteString.Lazy as BL
2829import qualified Data.Map as M
2930import Data.Maybe (catMaybes, fromMaybe)
3031import Data.String (fromString)
31−import Data.String.Conversions (cs, (<>))
32+import Data.String.Conversions (cs, (<>), ConvertibleStrings)
3233import Data.Text (Text)
3334import qualified Data.Text as T
3435import Data.Text.Encoding (decodeUtf8, encodeUtf8)
@@ -39,7 +40,8 @@ import Network.Socket (SockAddr)
3940import Network.Wai (Application, lazyRequestBody,
4041 rawQueryString, requestHeaders,
4142 requestMethod, responseLBS, remoteHost,
42− isSecure, vault, httpVersion)
43+ isSecure, vault, httpVersion, Response,
44+ Request)
4345import Servant.API ((:<|>) (..), (:>), Capture,
4446 Delete, Get, Header,
4547 IsSecure(..), MatrixFlag, MatrixParam,
@@ -121,6 +123,24 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
121123 Just v -> feedTo subserver v)
122124 where captureProxy = Proxy :: Proxy (Capture capture a)
123125
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)
124144
125145methodRouter :: (AllCTRender ctypes a)
126146 => Method -> Proxy ctypes -> Status
@@ -129,13 +149,11 @@ methodRouter :: (AllCTRender ctypes a)
129149methodRouter method proxy status action = LeafRouter route'
130150 where
131151 route' request respond
132− | pathIsEmpty request && requestMethod request == method = do
152+ | pathIsEmpty request && allowedMethod method request = do
133153 runAction action respond $ \ output -> do
134154 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
135− case handleAcceptH proxy (AcceptHeader accH) output of
136− Nothing -> failWith UnsupportedMediaType
137− Just (contentT, body) -> succeedWith $
138− responseLBS status [ ("Content-Type" , cs contentT)] body
155+ handleA = handleAcceptH proxy (AcceptHeader accH) output
156+ processMethodRouter handleA status method Nothing request
139157 | pathIsEmpty request && requestMethod request /= method =
140158 respond $ failWith WrongMethod
141159 | otherwise = respond $ failWith NotFound
@@ -147,14 +165,12 @@ methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
147165methodRouterHeaders method proxy status action = LeafRouter route'
148166 where
149167 route' request respond
150− | pathIsEmpty request && requestMethod request == method = do
168+ | pathIsEmpty request && allowedMethod method request = do
151169 runAction action respond $ \ output -> do
152170 let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
153171 headers = getHeaders output
154− case handleAcceptH proxy (AcceptHeader accH) (getResponse output) of
155− Nothing -> failWith UnsupportedMediaType
156− Just (contentT, body) -> succeedWith $
157− responseLBS status ( ("Content-Type" , cs contentT) : headers) body
172+ handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
173+ processMethodRouter handleA status method (Just headers) request
158174 | pathIsEmpty request && requestMethod request /= method =
159175 respond $ failWith WrongMethod
160176 | otherwise = respond $ failWith NotFound
@@ -165,7 +181,7 @@ methodRouterEmpty :: Method
165181methodRouterEmpty method action = LeafRouter route'
166182 where
167183 route' request respond
168− | pathIsEmpty request && requestMethod request == method = do
184+ | pathIsEmpty request && allowedMethod method request = do
169185 runAction action respond $ \ () ->
170186 succeedWith $ responseLBS noContent204 [] ""
171187 | pathIsEmpty request && requestMethod request /= method =
@@ -612,7 +628,6 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
612628 values = catMaybes $ map (convert . snd) parameters
613629 route (Proxy :: Proxy sublayout) (feedTo subserver values)
614630 _ -> route (Proxy :: Proxy sublayout) (feedTo subserver [])
615−
616631 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
617632 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
618633 convert Nothing = Nothing
@@ -644,11 +659,8 @@ instance (KnownSymbol sym, HasServer sublayout)
644659 Just Nothing -> True -- param is there, with no value
645660 Just (Just v) -> examine v -- param with a value
646661 Nothing -> False -- param not in the query string
647−
648662 route (Proxy :: Proxy sublayout) (feedTo subserver param)
649−
650663 _ -> route (Proxy :: Proxy sublayout) (feedTo subserver False)
651−
652664 where paramname = cs $ symbolVal (Proxy :: Proxy sym)
653665 examine v | v == "true" || v == "1" || v == "" = True
654666 | otherwise = False