    {-# LANGUAGE CPP #-}
    -----------------------------------------------------------------
    -- | 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, hContentType)

    #if __GLASGOW_HASKELL__ < 710
    import Data.Monoid                  (mconcat, mempty)
    #endif
    import Data.IORef
    import Data.ByteString.Lazy (toChunks)

    -- | 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 app :: Application
    app req :: Request
    req send :: Response -> IO ResponseReceived
    send =
        case (Request -> Method
    requestMethod Request
    req, HeaderName -> [(HeaderName, Method)] -> Maybe Method
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup HeaderName
    hContentType (Request -> [(HeaderName, Method)]
    requestHeaders Request
    req)) of
          ("POST", Just "application/x-www-form-urlencoded") -> Request -> IO Request
    setPost Request
    req IO Request
    -> (Request -> IO ResponseReceived) -> IO ResponseReceived
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Application
    -> (Response -> IO ResponseReceived)
    -> Request
    -> IO ResponseReceived
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Application
    app Response -> IO ResponseReceived
    send
          _                                                  -> Application
    app Request
    req Response -> IO ResponseReceived
    send

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