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