Added method override middleware

Hack/Middleware/MethodOverride.hs

@@ -0,0 +1,37 @@
+---------------------------------------------------------
+-- |
+-- 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)
+
+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 nm }
+
+safeRead :: Read a => a -> String -> a
+safeRead d s =
+  case reads s of
+    ((x, _):_) -> x
+    [] -> d

README.md

@@ -14,11 +14,14 @@ PUT: Replace data on server.
 DELETE: Remove data from server.
 POST: Some form of update.
 
-FIXME Note: not all clients support PUT and DELETE. Therefore, we need a
+Note: not all clients support PUT and DELETE. Therefore, we need a
-workaround. I will implement two fixes:
+workaround. There are two fixes:
 
 1. X-HTTP-Method-Override header.
-2. Get parameter (ie, in the query string). This will be more useful for web forms.
+2. Get parameter _method_override (ie, in the query string). This will be more
+useful for web forms.
+
+See MethodOverride middleware.
 
 ## Resource
 

Web/Restful/Application.hs

@@ -47,6 +47,7 @@ import Hack.Middleware.Gzip
 import Hack.Middleware.CleanPath
 import Hack.Middleware.Jsonp
 import Hack.Middleware.ClientSession
+import Hack.Middleware.MethodOverride
 
 import Control.Applicative ((<$>), Applicative (..))
 import Control.Arrow (second)
@@ -80,7 +81,12 @@ instance Default ApplicationSettings where
             , rpxnowApiKey = Nothing
             , encryptKey = Left defaultKeyFile
             , urlRewriter = \s -> (s, [])
-            , hackMiddleware = [gzip, cleanPath, jsonp]
+            , hackMiddleware =
+                [ gzip
+                , cleanPath
+                , jsonp
+                , methodOverride
+                ]
             , response404 = default404
             , htmlWrapper = id
             }