snap-core 0.8.1 → 0.9.0
raw patch · 7 files changed
+119/−14 lines, 7 files
Files
- snap-core.cabal +1/−1
- src/Snap/Internal/Http/Types.hs +26/−2
- src/Snap/Util/FileServe.hs +5/−5
- src/Snap/Util/FileUploads.hs +16/−0
- src/Snap/Util/GZip.hs +1/−0
- test/suite/Snap/Core/Tests.hs +64/−1
- test/suite/Snap/Util/FileServe/Tests.hs +6/−5
snap-core.cabal view
@@ -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:
src/Snap/Internal/Http/Types.hs view
@@ -131,9 +131,33 @@ ------------------------------------------------------------------------------ -- | 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)
src/Snap/Util/FileServe.hs view
@@ -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
src/Snap/Util/FileUploads.hs view
@@ -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 } ------------------------------------------------------------------------------
src/Snap/Util/GZip.hs view
@@ -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"
test/suite/Snap/Core/Tests.hs view
@@ -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
test/suite/Snap/Util/FileServe/Tests.hs view
@@ -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 () -> ()