diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -1,5 +1,5 @@ name: snap-core -version: 0.8.1 +version: 0.9.0 synopsis: Snap: A Haskell Web Framework (core interfaces and types) description: diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs --- a/src/Snap/Internal/Http/Types.hs +++ b/src/Snap/Internal/Http/Types.hs @@ -131,9 +131,33 @@ ------------------------------------------------------------------------------ -- | Enumerates the HTTP method values (see -- ). -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) diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs --- a/src/Snap/Util/FileServe.hs +++ b/src/Snap/Util/FileServe.hs @@ -38,8 +38,8 @@ import Data.ByteString.Internal (c2w) import Data.Int import Data.List -import Data.Map (Map) -import qualified Data.Map as Map +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map import Data.Maybe (fromMaybe, isNothing) import Data.Monoid import qualified Data.Text as T @@ -79,12 +79,12 @@ ------------------------------------------------------------------------------ -- | A type alias for dynamic handlers -type HandlerMap m = Map FilePath (FilePath -> m ()) +type HandlerMap m = HashMap FilePath (FilePath -> m ()) ------------------------------------------------------------------------------ -- | A type alias for MIME type -type MimeMap = Map FilePath ByteString +type MimeMap = HashMap FilePath ByteString ------------------------------------------------------------------------------ @@ -569,7 +569,7 @@ ------------------------------------------------------------------------------ -lookupExt :: a -> Map FilePath a -> FilePath -> a +lookupExt :: a -> HashMap FilePath a -> FilePath -> a lookupExt def m f = if null ext then def diff --git a/src/Snap/Util/FileUploads.hs b/src/Snap/Util/FileUploads.hs --- a/src/Snap/Util/FileUploads.hs +++ b/src/Snap/Util/FileUploads.hs @@ -42,6 +42,8 @@ , setProcessFormInputs , getMaximumFormInputSize , setMaximumFormInputSize + , getMaximumNumberOfFormInputs + , setMaximumNumberOfFormInputs , getMinimumUploadRate , setMinimumUploadRate , getMinimumUploadSeconds @@ -481,6 +483,20 @@ -- 'rqParams' map. setMaximumFormInputSize :: Int64 -> UploadPolicy -> UploadPolicy setMaximumFormInputSize s u = u { maximumFormInputSize = s } + + +------------------------------------------------------------------------------ +-- | Get the maximum size of a form input which will be read into our +-- 'rqParams' map. +getMaximumNumberOfFormInputs :: UploadPolicy -> Int +getMaximumNumberOfFormInputs = maximumNumberOfFormInputs + + +------------------------------------------------------------------------------ +-- | Set the maximum size of a form input which will be read into our +-- 'rqParams' map. +setMaximumNumberOfFormInputs :: Int -> UploadPolicy -> UploadPolicy +setMaximumNumberOfFormInputs s u = u { maximumNumberOfFormInputs = s } ------------------------------------------------------------------------------ diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs --- a/src/Snap/Util/GZip.hs +++ b/src/Snap/Util/GZip.hs @@ -137,6 +137,7 @@ compressibleMimeTypes :: Set ByteString compressibleMimeTypes = Set.fromList [ "application/x-font-truetype" , "application/x-javascript" + , "application/json" , "text/css" , "text/html" , "text/javascript" diff --git a/test/suite/Snap/Core/Tests.hs b/test/suite/Snap/Core/Tests.hs --- a/test/suite/Snap/Core/Tests.hs +++ b/test/suite/Snap/Core/Tests.hs @@ -30,6 +30,7 @@ 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 @@ , testTrivials , testMethod , testMethods + , testMethodEq + , testMethodNotEq , testDir , testCatchIO , testWrites @@ -122,7 +125,14 @@ 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 rq <- mkZomgRq @@ -167,6 +177,13 @@ 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 @@ 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 diff --git a/test/suite/Snap/Util/FileServe/Tests.hs b/test/suite/Snap/Util/FileServe/Tests.hs --- a/test/suite/Snap/Util/FileServe/Tests.hs +++ b/test/suite/Snap/Util/FileServe/Tests.hs @@ -12,6 +12,7 @@ import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.IORef +import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import Data.Maybe import Data.Monoid @@ -313,7 +314,7 @@ cfgA = DirectoryConfig { indexFiles = [] , indexGenerator = const pass - , dynamicHandlers = Map.empty + , dynamicHandlers = HashMap.empty , mimeTypes = defaultMimeTypes , preServeHook = const $ return () } @@ -321,7 +322,7 @@ cfgB = DirectoryConfig { indexFiles = ["index.txt", "altindex.html"] , indexGenerator = const pass - , dynamicHandlers = Map.empty + , dynamicHandlers = HashMap.empty , mimeTypes = defaultMimeTypes , preServeHook = const $ return () } @@ -329,7 +330,7 @@ cfgC = DirectoryConfig { indexFiles = ["index.txt", "altindex.html"] , indexGenerator = printName - , dynamicHandlers = Map.empty + , dynamicHandlers = HashMap.empty , mimeTypes = defaultMimeTypes , preServeHook = const $ return () } @@ -337,7 +338,7 @@ cfgD = DirectoryConfig { indexFiles = [] , indexGenerator = const pass - , dynamicHandlers = Map.fromList [ (".txt", printName) ] + , dynamicHandlers = HashMap.fromList [ (".txt", printName) ] , mimeTypes = defaultMimeTypes , preServeHook = const $ return () } @@ -569,7 +570,7 @@ ------------------------------------------------------------------------------ coverMimeMap :: (Monad m) => m () -coverMimeMap = Prelude.mapM_ f $ Map.toList defaultMimeTypes +coverMimeMap = Prelude.mapM_ f $ HashMap.toList defaultMimeTypes where f (!k,!v) = return $ case k `seq` v `seq` () of () -> ()