Browse files

Merge commit 'c9e094b701ff63e0f0f5db9ce3344bd0cfd1a2d6'

  • Loading branch information...
2 parents bbb7858 + c9e094b commit 8b08d04f224f3280dadddc2fd88791acba220d24 @gregorycollins gregorycollins committed Jun 12, 2012
Showing with 98 additions and 4 deletions.
  1. +27 −3 src/Snap/Internal/Http/Types.hs
  2. +64 −1 test/suite/Snap/Core/Tests.hs
  3. +7 −0 test/suite/Snap/Test/Tests.hs
View
30 src/Snap/Internal/Http/Types.hs
@@ -131,9 +131,33 @@ deleteHeader k = updateHeaders $ H.delete k
------------------------------------------------------------------------------
-- | Enumerates the HTTP method values (see
-- <http://tools.ietf.org/html/rfc2068.html#section-5.1.1>).
-data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT
- deriving(Show,Read,Ord,Eq)
-
+data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT |
+ PATCH | Method ByteString
+ deriving(Show,Read,Ord)
+
+
+instance Eq Method where
+ GET == GET = True
+ GET == Method "GET" = True
+ HEAD == HEAD = True
+ HEAD == Method "HEAD" = True
+ POST == POST = True
+ POST == Method "POST" = True
+ PUT == PUT = True
+ PUT == Method "PUT" = True
+ DELETE == DELETE = True
+ DELETE == Method "DELETE" = True
+ TRACE == TRACE = True
+ TRACE == Method "TRACE" = True
+ OPTIONS == OPTIONS = True
+ OPTIONS == Method "OPTIONS" = True
+ CONNECT == CONNECT = True
+ CONNECT == Method "CONNECT" = True
+ PATCH == PATCH = True
+ PATCH == Method "PATCH" = True
+ Method a == Method b = a == b
+ m@(Method _) == other = other == m
+ _ == _ = False
------------------------------------------------------------------------------
type HttpVersion = (Int,Int)
View
65 test/suite/Snap/Core/Tests.hs
@@ -30,6 +30,7 @@ import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.HUnit hiding (Test, path)
+import Test.QuickCheck(oneof, variant, elements, Gen, arbitrary)
import Snap.Internal.Exceptions
import Snap.Internal.Http.Types
@@ -54,6 +55,8 @@ tests = [ testFail
, testTrivials
, testMethod
, testMethods
+ , testMethodEq
+ , testMethodNotEq
, testDir
, testCatchIO
, testWrites
@@ -122,6 +125,13 @@ mkZomgRq = do
enum Nothing GET (1,1) [] "/" "/" "/" ""
Map.empty Map.empty Map.empty
+mkMethodRq :: Method -> IO Request
+mkMethodRq m = do
+ enum <- newIORef $ SomeEnumerator returnI
+
+ return $ Request "foo" 80 "127.0.0.1" 999 "foo" 1000 "foo" False H.empty
+ enum Nothing m (1,1) [] "/" "/" "/" ""
+ Map.empty Map.empty Map.empty
mkIpHeaderRq :: IO Request
mkIpHeaderRq = do
@@ -167,6 +177,13 @@ go m = do
where
dummy !x = return $! (show x `using` rdeepseq) `seq` ()
+goMeth :: Method -> Snap a -> IO (Request,Response)
+goMeth m s = do
+ methRq <- mkMethodRq m
+ run_ $ runSnap s dummy (const (return ())) methRq
+ where
+ dummy !x = return $! (show x `using` rdeepseq) `seq` ()
+
goIP :: Snap a -> IO (Request,Response)
goIP m = do
rq <- mkIpHeaderRq
@@ -454,11 +471,57 @@ testMethod = testCase "types/method" $ do
testMethods :: Test
testMethods = testCase "types/methods" $ do
- expect404 $ go (methods [POST,PUT] $ return ())
+ expect404 $ go (methods [POST,PUT,PATCH,Method "MOVE"] $ return ())
expectNo404 $ go (methods [GET] $ return ())
expectNo404 $ go (methods [POST,GET] $ return ())
expectNo404 $ go (methods [PUT,GET] $ return ())
expectNo404 $ go (methods [GET,PUT,DELETE] $ return ())
+ expectNo404 $ go (methods [GET,PUT,DELETE,PATCH] $ return ())
+ expectNo404 $ go (methods [GET,Method "COPY"] $ return ())
+ expect404 $ goMeth PATCH (methods [POST,PUT,GET,Method "FOO"] $ return ())
+ expect404 $ goMeth (Method "Baz")
+ (methods [GET,POST,Method "Foo"] $ return ())
+ expectNo404 $ goMeth (Method "Baz")
+ (method (Method "Baz") $ return ())
+ expectNo404 $ goMeth (Method "Foo")
+ (methods [Method "Baz",PATCH,GET,Method "Foo"] $ return ())
+
+ expectNo404 $ goMeth GET (method (Method "GET") $ return ())
+ expectNo404 $ goMeth (Method "GET") (method GET $ return ())
+
+
+methodGen :: Int -> Gen Method
+methodGen n = variant n $ oneof
+ [ elements [ GET, HEAD, POST, PUT, DELETE
+ , TRACE, OPTIONS, CONNECT, PATCH ]
+ , Method <$> arbitrary
+ ]
+
+testMethodEq :: Test
+testMethodEq = testProperty "types/Method/eq" $ prop
+ where
+ prop n = do
+ m <- methodGen n
+ return $ m == m && toMeth m == m
+ toMeth GET = Method "GET"
+ toMeth HEAD = Method "HEAD"
+ toMeth POST = Method "POST"
+ toMeth PUT = Method "PUT"
+ toMeth DELETE = Method "DELETE"
+ toMeth TRACE = Method "TRACE"
+ toMeth OPTIONS = Method "OPTIONS"
+ toMeth CONNECT = Method "CONNECT"
+ toMeth PATCH = Method "PATCH"
+ toMeth (Method a) = Method a
+
+
+testMethodNotEq :: Test
+testMethodNotEq = testProperty "types/Method/noteq" $ prop
+ where
+ prop n = do
+ m <- methodGen n
+ m' <- methodGen (n + 1)
+ return $ (m /= m') == not (m == m')
testDir :: Test
View
7 test/suite/Snap/Test/Tests.hs
@@ -62,6 +62,13 @@ testSetRequestType = testCase "test/requestBuilder/setRequestType" $ do
UrlEncodedPostRequest $ Map.fromList [("foo", ["foo"])]
assertEqual "setRequestType/5/Method" POST (rqMethod request5)
+ request6 <- buildRequest $ setRequestType $
+ RequestWithRawBody (Method "MOVE") "foo"
+ assertEqual "setRequestType/6/Method" (Method "MOVE") (rqMethod request6)
+
+ request7 <- buildRequest $ setRequestType $ RequestWithRawBody PATCH "bar"
+ assertEqual "setRequestType/7/Method" PATCH (rqMethod request7)
+
where
rt4 = MultipartPostRequest [ ("foo", FormData ["foo"])
, ("bar", Files [fd4])

0 comments on commit 8b08d04

Please sign in to comment.