Parsing of extension methods

snapframework · Jun 5, 2012 · 6e4a7f4 · 6e4a7f4
1 parent 11b7adf
commit 6e4a7f4
Show file tree

Hide file tree

Showing 2 changed files with 8 additions and 5 deletions.
diff --git a/src/Snap/Internal/Http/Parser.hs b/src/Snap/Internal/Http/Parser.hs
@@ -171,8 +171,8 @@ methodFromString "DELETE"  = return DELETE
 methodFromString "TRACE"   = return TRACE
 methodFromString "OPTIONS" = return OPTIONS
 methodFromString "CONNECT" = return CONNECT
-methodFromString s         =
-    throwError $ HttpParseException $ "Bad method '" ++ S.unpack s ++ "'"
+methodFromString "PATCH"   = return PATCH
+methodFromString s         = return $ ExtMethod s
 
 
 ------------------------------------------------------------------------------

diff --git a/test/suite/Snap/Internal/Http/Server/Tests.hs b/test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -152,7 +152,8 @@ testMethodParsing :: Test
 testMethodParsing =
     testCase "server/method parsing" $ Prelude.mapM_ testOneMethod ms
   where
-    ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT ]
+    ms = [ GET, HEAD, POST, PUT, DELETE, TRACE, OPTIONS, CONNECT, PATCH
+         , ExtMethod "COPY", ExtMethod "MOVE"]
 
 
 dummyIter :: Iteratee ByteString IO ()
@@ -272,9 +273,11 @@ testPartialParse = testCase "server/short" $ do
 
 
 methodTestText :: Method -> L.ByteString
-methodTestText m = L.concat [ (L.pack $ map c2w $ show m)
+methodTestText m = L.concat [ mbs m
                         , " / HTTP/1.1\r\nContent-Length: 0\r\n\r\n" ]
-
+  where
+    mbs (ExtMethod b) = L.fromChunks [b]
+    mbs b = L.pack $ map c2w $ show b
 
 sampleRequest2 :: ByteString
 sampleRequest2 =