Permalink
Browse files

Merge pull request #64 from sordina/master

Adding ability to override POST request method from the first field of url-encoded post-data
  • Loading branch information...
snoyberg committed Apr 29, 2012
2 parents e6d9281 + c64992c commit 0eb6c8a121d3f5cc35a882640372aca007699a51
@@ -0,0 +1,39 @@
+{-# LANGUAGE OverloadedStrings #-}
+-----------------------------------------------------------------
+-- | Module : Network.Wai.Middleware.MethodOverridePost
+--
+-- Changes the request-method via first post-parameter _method.
+-----------------------------------------------------------------
+module Network.Wai.Middleware.MethodOverridePost
+ ( methodOverridePost
+ ) where
+
+import Network.Wai
+import Network.HTTP.Types (parseQuery)
+import Data.Monoid (mconcat)
+import Data.Conduit.Lazy (lazyConsume)
+import Control.Monad.Trans.Resource (ResourceT)
+import Data.Conduit.List (sourceList)
+
+-- | Allows overriding of the HTTP request method via the _method post string parameter.
+--
+-- * Looks for the Content-Type requestHeader.
+--
+-- * If the header is set to application/x-www-form-urlencoded
+-- and the first POST parameter is _method
+-- then it changes the request-method to the value of that
+-- parameter.
+--
+-- * This middlware only applies when the initial request method is POST.
+--
+methodOverridePost :: Middleware
+methodOverridePost app req = case (requestMethod req, lookup "Content-Type" (requestHeaders req)) of
+ ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= app
+ _ -> app req
+
+setPost :: Request -> ResourceT IO Request
+setPost req = do
+ body <- lazyConsume (requestBody req)
+ case parseQuery (mconcat body) of
+ (("_method", Just newmethod):_) -> return $ req {requestBody = sourceList body, requestMethod = newmethod}
+ _ -> return $ req {requestBody = sourceList body}
@@ -21,6 +21,7 @@ import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.Vhost
import Network.Wai.Middleware.Autohead
import Network.Wai.Middleware.MethodOverride
+import Network.Wai.Middleware.MethodOverridePost
import Network.Wai.Middleware.AcceptOverride
import Network.Wai.Middleware.RequestLogger (logCallback)
import Codec.Compression.GZip (decompress)
@@ -31,7 +32,6 @@ import Data.Conduit.Binary (sourceFile)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (fromMaybe)
import Network.HTTP.Types (parseSimpleQuery, status200)
-import Data.Monoid (mappend)
specs :: Specs
specs = do
@@ -53,6 +53,7 @@ specs = do
it "vhost" caseVhost
it "autohead" caseAutohead
it "method override" caseMethodOverride
+ it "method override post" caseMethodOverridePost
it "accept override" caseAcceptOverride
it "dalvik multipart" caseDalvikMultipart
it "debug request body" caseDebugRequestBody
@@ -354,6 +355,32 @@ caseMethodOverride = flip runSession moApp $ do
}
assertHeader "Method" "PUT" sres3
+mopApp :: Application
+mopApp = methodOverridePost $ \req -> return $ responseLBS status200 [("Method", requestMethod req)] ""
+
+caseMethodOverridePost :: Assertion
+caseMethodOverridePost = flip runSession mopApp $ do
+
+ -- Get Request are unmodified
+ sres1 <- let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
+ s = simpleRequest r
+ m = s { requestMethod = "GET" }
+ b = r { simpleRequest = m }
+ in srequest b
+ assertHeader "Method" "GET" sres1
+
+ -- Post requests are modified if _method comes first
+ sres2 <- srequest $ toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"
+ assertHeader "Method" "PUT" sres2
+
+ -- Post requests are unmodified if _method doesn't come first
+ sres3 <- srequest $ toRequest "application/x-www-form-urlencoded" "foo=bar&_method=PUT&baz=bin"
+ assertHeader "Method" "POST" sres3
+
+ -- Post requests are unmodified if Content-Type header isn't set to "application/x-www-form-urlencoded"
+ sres4 <- srequest $ toRequest "text/html; charset=utf-8" "foo=bar&_method=PUT&baz=bin"
+ assertHeader "Method" "POST" sres4
+
aoApp :: Application
aoApp = acceptOverride $ \req -> return $ responseLBS status200
[("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""
@@ -38,6 +38,7 @@ Library
, zlib-conduit >= 0.4 && < 0.5
, blaze-builder-conduit >= 0.4 && < 0.5
, ansi-terminal
+ , resourcet >= 0.3 && < 0.4
Exposed-modules: Network.Wai.Handler.CGI
Network.Wai.Middleware.AcceptOverride
@@ -47,6 +48,7 @@ Library
Network.Wai.Middleware.Gzip
Network.Wai.Middleware.Jsonp
Network.Wai.Middleware.MethodOverride
+ Network.Wai.Middleware.MethodOverridePost
Network.Wai.Middleware.Rewrite
Network.Wai.Middleware.Vhost
Network.Wai.Parse

0 comments on commit 0eb6c8a

Please sign in to comment.