    {-# 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, HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup HeaderName
    hContentType (Request -> [(HeaderName, ByteString)]
    requestHeaders Request
    req)) of
            (ByteString
    "POST", Just ByteString
    "application/x-www-form-urlencoded") -> Request -> IO Request
    setPost Request
    req IO Request
    -> (Request -> IO ResponseReceived) -> IO ResponseReceived
    forall a b. IO a -> (a -> IO b) -> IO b
    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
            (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 <- ([ByteString] -> ByteString
    forall a. Monoid a => [a] -> a
    mconcat ([ByteString] -> ByteString)
    -> (ByteString -> [ByteString]) -> ByteString -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ByteString -> [ByteString]
    toChunks) (ByteString -> ByteString) -> IO ByteString -> IO ByteString
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` Request -> IO ByteString
    lazyRequestBody Request
    req
        IORef ByteString
    ref <- ByteString -> IO (IORef ByteString)
    forall a. a -> IO (IORef a)
    newIORef ByteString
    body
        let rb :: IO ByteString
    rb = IORef ByteString
    -> (ByteString -> (ByteString, ByteString)) -> IO ByteString
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    atomicModifyIORef IORef ByteString
    ref ((ByteString -> (ByteString, ByteString)) -> IO ByteString)
    -> (ByteString -> (ByteString, ByteString)) -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ \ByteString
    bs -> (ByteString
    forall a. Monoid a => a
    mempty, ByteString
    bs)
            req' :: Request
    req' = IO ByteString -> Request -> Request
    setRequestBodyChunks IO ByteString
    rb Request
    req
        case ByteString -> Query
    parseQuery ByteString
    body of
            ((ByteString
    "_method", Just ByteString
    newmethod) : Query
    _) -> Request -> IO Request
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Request
    req'{requestMethod = newmethod}
            Query
    _ -> Request -> IO Request
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Request
    req'

    {- HLint ignore setPost "Use tuple-section" -}