@@ -21,6 +21,7 @@ import Network.Wai.Middleware.Gzip
2121import Network.Wai.Middleware.Vhost
2222import Network.Wai.Middleware.Autohead
2323import Network.Wai.Middleware.MethodOverride
24+import Network.Wai.Middleware.MethodOverridePost
2425import Network.Wai.Middleware.AcceptOverride
2526import Network.Wai.Middleware.RequestLogger (logCallback)
2627import Codec.Compression.GZip (decompress)
@@ -31,8 +32,11 @@ import Data.Conduit.Binary (sourceFile)
3132import Control.Monad.IO.Class (liftIO)
3233import Data.Maybe (fromMaybe)
3334import Network.HTTP.Types (parseSimpleQuery, status200)
34−import Data.Monoid (mappend)
3535
36+{-
37+type Specs = Test.Hspec.Monadic.SpecM ()
38+ -- Defined in `Test.Hspec.Monadic'
39+-}
3640specs :: Specs
3741specs = do
3842 describe "Network.Wai.Parse" $ do
@@ -53,6 +57,7 @@ specs = do
5357 it "vhost" caseVhost
5458 it "autohead" caseAutohead
5559 it "method override" caseMethodOverride
60+ it "method override post" caseMethodOverridePost
5661 it "accept override" caseAcceptOverride
5762 it "dalvik multipart" caseDalvikMultipart
5863 it "debug request body" caseDebugRequestBody
@@ -354,6 +359,28 @@ caseMethodOverride = flip runSession moApp $ do
354359 }
355360 assertHeader "Method" "PUT" sres3
356361
362+mopApp :: Application
363+mopApp = methodOverridePost $ \req -> return $ responseLBS status200 [("Method", requestMethod req)] ""
364+
365+caseMethodOverridePost :: Assertion
366+caseMethodOverridePost = flip runSession mopApp $ do
367+
368+ -- Get Request are unmodified
369+ sres1 <- let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
370+ s = simpleRequest r
371+ m = s { requestMethod = "GET" }
372+ b = r { simpleRequest = m }
373+ in srequest b
374+ assertHeader "Method" "GET" sres1
375+
376+ -- Post requests are modified if _method comes first
377+ sres2 <- srequest $ toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
378+ assertHeader "Method" "PUT" sres2
379+
380+ -- Post requests are unmodified if _method doesn't come first
381+ sres3 <- srequest $ toRequest "application/x-www-form-urlencoded" "foo=bar&_method=PUT&baz=bin"
382+ assertHeader "Method" "POST" sres3
383+
357384aoApp :: Application
358385aoApp = acceptOverride $ \req -> return $ responseLBS status200
359386 [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""