39 lines
1.1 KiB
Haskell
39 lines
1.1 KiB
Haskell
---------------------------------------------------------
|
|
-- |
|
|
-- Module : Hack.Middleware.MethodOverride
|
|
-- Copyright : Michael Snoyman
|
|
-- License : BSD3
|
|
--
|
|
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
-- Stability : Unstable
|
|
-- Portability : portable
|
|
--
|
|
-- Override the HTTP method based on either:
|
|
-- The X-HTTP-Method-Override header.
|
|
-- The _method_override GET parameter.
|
|
--
|
|
---------------------------------------------------------
|
|
module Hack.Middleware.MethodOverride (methodOverride) where
|
|
|
|
import Hack
|
|
import Web.Encodings (decodeUrlPairs)
|
|
import Data.Monoid (mappend)
|
|
import Data.Char
|
|
|
|
methodOverride :: Middleware
|
|
methodOverride app env = do
|
|
let mo1 = lookup "X-HTTP-Method-Override" $ http env
|
|
gets = decodeUrlPairs $ queryString env
|
|
mo2 = lookup "_method_override" gets
|
|
cm = requestMethod env
|
|
app $
|
|
case mo1 `mappend` mo2 of
|
|
Nothing -> env
|
|
Just nm -> env { requestMethod = safeRead cm $ map toUpper nm }
|
|
|
|
safeRead :: Read a => a -> String -> a
|
|
safeRead d s =
|
|
case reads s of
|
|
((x, _):_) -> x
|
|
[] -> d
|