0.9 #138

Merged
merged 4 commits into from Jun 6, 2012
@@ -131,7 +131,8 @@ 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
+data Method = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT |
+ PATCH | ExtMethod ByteString
deriving(Show,Read,Ord,Eq)
@@ -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
@@ -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])