{-# LANGUAGE CPP #-}
-----------------------------------------------------------------
-- | Module : Network.Wai.Middleware.MethodOverridePost
--
-- Changes the request-method via first post-parameter _method.
-----------------------------------------------------------------
module Network.Wai.Middleware.MethodOverridePost
  ( methodOverridePost
  ) where

import Data.ByteString.Lazy (toChunks)
import Data.IORef (atomicModifyIORef, newIORef)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (mconcat, mempty)
#endif
import Network.HTTP.Types (hContentType, parseQuery)
import Network.Wai

-- | 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 middleware only applies when the initial request method is POST.
--
methodOverridePost :: Middleware
methodOverridePost :: Middleware
methodOverridePost Application
app Request
req Response -> IO ResponseReceived
send =
    case (Request -> ByteString
requestMethod Request
req, forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType (Request -> RequestHeaders
requestHeaders Request
req)) of
      (ByteString
"POST", Just ByteString
"application/x-www-form-urlencoded") -> Request -> IO Request
setPost Request
req forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip Application
app Response -> IO ResponseReceived
send
      (ByteString, Maybe ByteString)
_                                                  -> Application
app Request
req Response -> IO ResponseReceived
send

setPost :: Request -> IO Request
setPost :: Request -> IO Request
setPost Request
req = do
  ByteString
body <- (forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
toChunks) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Request -> IO ByteString
lazyRequestBody Request
req
  IORef ByteString
ref <- forall a. a -> IO (IORef a)
newIORef ByteString
body
  let rb :: IO ByteString
rb = forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef ByteString
ref forall a b. (a -> b) -> a -> b
$ \ByteString
bs -> (forall a. Monoid a => a
mempty, ByteString
bs)
  case ByteString -> Query
parseQuery ByteString
body of
    ((ByteString
"_method", Just ByteString
newmethod):Query
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Request
req {requestBody :: IO ByteString
requestBody = IO ByteString
rb, requestMethod :: ByteString
requestMethod = ByteString
newmethod}
    Query
_                               -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Request
req {requestBody :: IO ByteString
requestBody = IO ByteString
rb}