snap-core 0.2.12 → 0.2.13
raw patch · 18 files changed
+647/−133 lines, 18 filesdep +bytestring-show
Dependencies added: bytestring-show
Files
- snap-core.cabal +4/−1
- src/Snap/Internal/Debug.hs +4/−4
- src/Snap/Internal/Http/Types.hs +14/−3
- src/Snap/Internal/Iteratee/Debug.hs +4/−2
- src/Snap/Internal/Parsing.hs +26/−0
- src/Snap/Internal/Types.hs +18/−2
- src/Snap/Iteratee.hs +84/−9
- src/Snap/Starter.hs +3/−1
- src/Snap/Types.hs +2/−0
- src/Snap/Util/FileServe.hs +170/−12
- src/Snap/Util/GZip.hs +21/−39
- test/runTestsAndCoverage.sh +5/−1
- test/snap-core-testsuite.cabal +2/−0
- test/suite/Snap/Internal/Http/Types/Tests.hs +1/−1
- test/suite/Snap/Iteratee/Tests.hs +4/−4
- test/suite/Snap/Types/Tests.hs +7/−5
- test/suite/Snap/Util/FileServe/Tests.hs +127/−5
- test/suite/Snap/Util/GZip/Tests.hs +151/−44
snap-core.cabal view
@@ -1,5 +1,5 @@ name: snap-core-version: 0.2.12+version: 0.2.13 synopsis: Snap: A Haskell Web Framework (Core) description:@@ -140,6 +140,7 @@ Snap.Util.GZip other-modules:+ Snap.Internal.Parsing, Snap.Internal.Routing, Snap.Internal.Types @@ -148,6 +149,7 @@ base >= 4 && < 5, bytestring, bytestring-nums,+ bytestring-show >= 0.3.2 && < 0.4, cereal >= 0.3 && < 0.4, containers, deepseq >= 1.1 && <1.2,@@ -189,6 +191,7 @@ base >= 4 && < 5, bytestring, bytestring-nums,+ bytestring-show >= 0.3.2 && < 0.4, cereal >= 0.3 && < 0.4, containers, deepseq >= 1.1 && <1.2,
src/Snap/Internal/Debug.hs view
@@ -39,9 +39,9 @@ !e <- try $ getEnv "DEBUG" !f <- either (\(_::SomeException) -> return debugIgnore)- (\x -> if x == "1" || x == "on"+ (\y -> if y == "1" || y == "on" then return debugOn- else if x == "testsuite"+ else if y == "testsuite" then return debugSeq else return debugIgnore) (fmap (map toLower) e)@@ -54,9 +54,9 @@ e <- try $ getEnv "DEBUG" !f <- either (\(_::SomeException) -> return debugErrnoIgnore)- (\x -> if x == "1" || x == "on"+ (\y -> if y == "1" || y == "on" then return debugErrnoOn- else if x == "testsuite"+ else if y == "testsuite" then return debugErrnoSeq else return debugErrnoIgnore) (fmap (map toLower) e)
src/Snap/Internal/Http/Types.hs view
@@ -126,6 +126,12 @@ ------------------------------------------------------------------------------+-- | Clears a header value from a 'HasHeaders' datatype.+deleteHeader :: (HasHeaders a) => CIByteString -> a -> a+deleteHeader k = updateHeaders $ Map.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@@ -345,10 +351,14 @@ -- response type ------------------------------------------------------------------------------ -data ResponseBody = Enum (forall a . Enumerator a) -- ^ output body is enumerator- | SendFile FilePath -- ^ output body is sendfile()+data ResponseBody = Enum (forall a . Enumerator a)+ -- ^ output body is enumerator + | SendFile FilePath (Maybe (Int64,Int64))+ -- ^ output body is sendfile(), optional second argument+ -- is a byte range to send + ------------------------------------------------------------------------------ rspBodyMap :: (forall a . Enumerator a -> Enumerator a) -> ResponseBody@@ -359,7 +369,8 @@ ------------------------------------------------------------------------------ rspBodyToEnum :: ResponseBody -> Enumerator a rspBodyToEnum (Enum e) = e-rspBodyToEnum (SendFile fp) = I.enumFile fp+rspBodyToEnum (SendFile fp Nothing) = I.enumFile fp+rspBodyToEnum (SendFile fp (Just s)) = I.enumFilePartial fp s ------------------------------------------------------------------------------
src/Snap/Internal/Iteratee/Debug.hs view
@@ -18,7 +18,9 @@ import Data.Word (Word8) import System.IO ------------------------------------------------------------------------------+#ifndef NODEBUG import Snap.Internal.Debug+#endif import Snap.Iteratee ------------------------------------------------------------------------------ @@ -43,7 +45,7 @@ return $ Cont debugIteratee Nothing -#if defined(DEBUG)+#ifndef NODEBUG iterateeDebugWrapper :: String -> Iteratee IO a -> Iteratee IO a iterateeDebugWrapper name iter = IterateeG f@@ -52,7 +54,7 @@ debug $ name ++ ": got EOF: " ++ show c runIter iter c - f c@(EOF (Just e)) = do+ f c@(EOF (Just _)) = do debug $ name ++ ": got EOF **error**: " ++ show c runIter iter c
+ src/Snap/Internal/Parsing.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Internal.Parsing where++import Control.Monad+import Data.Attoparsec.Char8 hiding (Done)+import qualified Data.Attoparsec.Char8 as Atto+import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Nums.Careless.Int (int)+import Data.Int++------------------------------------------------------------------------------+fullyParse :: ByteString -> Parser a -> Either String a+fullyParse s p =+ case r' of+ (Fail _ _ e) -> Left e+ (Partial _) -> Left "parse failed"+ (Atto.Done _ x) -> Right x+ where+ r = parse p s+ r' = feed r ""+++------------------------------------------------------------------------------+parseNum :: Parser Int64+parseNum = liftM int $ Atto.takeWhile1 Atto.isDigit
src/Snap/Internal/Types.hs view
@@ -14,6 +14,7 @@ import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.CIByteString as CIB+import Data.Int import Data.IORef import qualified Data.Iteratee as Iter import Data.Maybe@@ -27,7 +28,6 @@ ------------------------------------------------------------------------------ import Snap.Iteratee hiding (Enumerator) import Snap.Internal.Http.Types-import Snap.Internal.Debug import Snap.Internal.Iteratee.Debug @@ -480,7 +480,23 @@ -- If the response body is modified (using 'modifyResponseBody'), the file will -- be read using @mmap()@. sendFile :: FilePath -> Snap ()-sendFile f = modifyResponse $ \r -> r { rspBody = SendFile f }+sendFile f = modifyResponse $ \r -> r { rspBody = SendFile f Nothing }+++------------------------------------------------------------------------------+-- | Sets the output to be the contents of the specified file, within the given+-- (start,end) range.+--+-- Calling 'sendFilePartial' will overwrite any output queued to be sent in the+-- 'Response'. If the response body is not modified after the call to+-- 'sendFilePartial', Snap will use the efficient @sendfile()@ system call on+-- platforms that support it.+--+-- If the response body is modified (using 'modifyResponseBody'), the file will+-- be read using @mmap()@.+sendFilePartial :: FilePath -> (Int64,Int64) -> Snap ()+sendFilePartial f rng = modifyResponse $ \r ->+ r { rspBody = SendFile f (Just rng) } ------------------------------------------------------------------------------
src/Snap/Iteratee.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Snap Framework type aliases and utilities for iteratees. Note that as a -- convenience, this module also exports everything from @Data.Iteratee@ in the@@ -28,6 +31,8 @@ , enumBS , enumLBS , enumFile+ , enumFilePartial+ , InvalidRangeException -- ** Conversion to/from 'WrappedByteString' , fromWrap@@ -47,6 +52,7 @@ ------------------------------------------------------------------------------ import Control.Monad import Control.Monad.CatchIO+import Control.Exception (SomeException) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as S@@ -60,6 +66,7 @@ import Data.Iteratee.WrappedByteString import qualified Data.ListLike as LL import Data.Monoid (mappend)+import Data.Typeable import Foreign import Foreign.C.Types import GHC.ForeignPtr@@ -68,7 +75,6 @@ import "monads-fd" Control.Monad.Trans (liftIO) #ifndef PORTABLE-import Control.Exception (SomeException) import System.IO.Posix.MMap import System.PosixCompat.Files #endif@@ -411,18 +417,53 @@ ------------------------------------------------------------------------------+{-# INLINE _enumFile #-} _enumFile :: FilePath -> Iteratee IO a -> IO (Iteratee IO a) _enumFile fp iter = do h <- liftIO $ openBinaryFile fp ReadMode- i' <- enumHandle h iter- return (i' `finally` liftIO (hClose h))+ enumHandle h iter `finally` hClose h +------------------------------------------------------------------------------+data InvalidRangeException = InvalidRangeException+ deriving (Typeable)++instance Show InvalidRangeException where+ show InvalidRangeException = "Invalid range"++instance Exception InvalidRangeException+++------------------------------------------------------------------------------+{-# INLINE _enumFilePartial #-}+_enumFilePartial :: FilePath+ -> (Int64,Int64)+ -> Iteratee IO a+ -> IO (Iteratee IO a)+_enumFilePartial fp (start,end) iter = do+ let len = end - start++ h <- liftIO $ openBinaryFile fp ReadMode+ unless (start == 0) $+ hSeek h AbsoluteSeek $ toInteger start++ let i' = joinI $ takeExactly len iter++ enumHandle h i' `finally` hClose h++ enumFile :: FilePath -> Iteratee IO a -> IO (Iteratee IO a)+enumFilePartial :: FilePath+ -> (Int64,Int64)+ -> Iteratee IO a+ -> IO (Iteratee IO a) #ifdef PORTABLE enumFile = _enumFile+enumFilePartial fp rng@(start,end) iter = do+ when (end < start) $ throw InvalidRangeException+ _enumFilePartial fp rng iter #else @@ -430,19 +471,53 @@ maxMMapFileSize :: FileOffset maxMMapFileSize = 41943040 +tooBigForMMap :: FilePath -> IO Bool+tooBigForMMap fp = do+ stat <- getFileStatus fp+ return $ fileSize stat > maxMMapFileSize++ enumFile fp iter = do -- for small files we'll use mmap to save ourselves a copy, otherwise we'll -- stream it- stat <- getFileStatus fp- if fileSize stat > maxMMapFileSize+ tooBig <- tooBigForMMap fp++ if tooBig then _enumFile fp iter else do- es <- (try $- liftM WrapBS $- unsafeMMapFile fp) :: IO (Either SomeException (WrappedByteString Word8))+ es <- try $+ liftM WrapBS $+ unsafeMMapFile fp case es of- (Left e) -> return $ throwErr $ Err $ "IO error" ++ show e+ (Left (e :: SomeException)) -> return $ throwErr+ $ Err+ $ "IO error" ++ show e+ (Right s) -> liftM liftI $ runIter iter $ Chunk s+++enumFilePartial fp rng@(start,end) iter = do+ when (end < start) $ throw InvalidRangeException++ let len = end - start++ tooBig <- tooBigForMMap fp++ if tooBig+ then _enumFilePartial fp rng iter+ else do+ es <- try $ unsafeMMapFile fp++ case es of+ (Left (e::SomeException)) -> return $ throwErr+ $ Err+ $ "IO error" ++ show e++ (Right s) -> liftM liftI $ runIter iter+ $ Chunk+ $ WrapBS+ $ S.take (fromEnum len)+ $ S.drop (fromEnum start) s #endif
src/Snap/Starter.hs view
@@ -2,6 +2,7 @@ module Main where ------------------------------------------------------------------------------+import Char import Data.List import qualified Data.Text as T import System@@ -46,9 +47,10 @@ if isSuffixOf "foo.cabal" f then writeFile (projName++".cabal") (insertProjName $ T.pack c) else writeFile f c+ isNameChar c = isAlphaNum c || c == '-' insertProjName c = T.unpack $ T.replace (T.pack "projname")- (T.pack $ filter (/='_') projName) c+ (T.pack $ filter isNameChar projName) c ------------------------------------------------------------------------------ initProject :: [String] -> IO ()
src/Snap/Types.hs view
@@ -58,6 +58,7 @@ , addHeader , setHeader , getHeader+ , deleteHeader , ipHeaderFilter , ipHeaderFilter' @@ -105,6 +106,7 @@ , writeText , writeLBS , sendFile+ , sendFilePartial -- * Iteratee , Enumerator
src/Snap/Util/FileServe.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -15,23 +16,32 @@ ) where ------------------------------------------------------------------------------+import Control.Applicative import Control.Monad import Control.Monad.Trans+import Data.Attoparsec.Char8 hiding (Done) import qualified Data.ByteString.Char8 as S+import qualified Data.ByteString.Lazy.Char8 as L import Data.ByteString.Char8 (ByteString)+import Data.Int import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, isNothing)+import Prelude hiding (show, Show)+import qualified Prelude import System.Directory import System.FilePath import System.PosixCompat.Files-+import Text.Show.ByteString hiding (runPut) ------------------------------------------------------------------------------+import Snap.Internal.Debug+import Snap.Internal.Parsing+import Snap.Iteratee hiding (drop) import Snap.Types --------------------------------------------------------------------------------- | A type alias for MIME type +-- | A type alias for MIME type type MimeMap = Map FilePath ByteString @@ -217,33 +227,71 @@ -> FilePath -- ^ path to file -> Snap () fileServeSingle' mime fp = do- req <- getRequest- + reqOrig <- getRequest++ -- If-Range header must be ignored if there is no Range: header in the+ -- request (RFC 2616 section 14.27)+ let req = if isNothing $ getHeader "range" reqOrig+ then deleteHeader "if-range" reqOrig+ else reqOrig++ -- check "If-Modified-Since" and "If-Range" headers let mbH = getHeader "if-modified-since" req mbIfModified <- liftIO $ case mbH of Nothing -> return Nothing (Just s) -> liftM Just $ parseHttpTime s + -- If-Range header could contain an entity, but then parseHttpTime will+ -- fail and return 0 which means a 200 response will be generated anyways+ mbIfRange <- liftIO $ case getHeader "if-range" req of+ Nothing -> return Nothing+ (Just s) -> liftM Just $ parseHttpTime s++ dbg $ "mbIfModified: " ++ Prelude.show mbIfModified+ dbg $ "mbIfRange: " ++ Prelude.show mbIfRange+ -- check modification time and bug out early if the file is not modified.+ --+ -- TODO: a stat cache would be nice here, but it'd need the date thread+ -- stuff from snap-server to be folded into snap-core filestat <- liftIO $ getFileStatus fp let mt = modificationTime filestat- maybe (return ()) (chkModificationTime mt) mbIfModified+ maybe (return $! ()) (\lt -> when (mt <= lt) notModified) mbIfModified let sz = fromIntegral $ fileSize filestat lm <- liftIO $ formatHttpTime mt + -- ok, at this point we know the last-modified time and the+ -- content-type. set those. modifyResponse $ setHeader "Last-Modified" lm+ . setHeader "Accept-Ranges" "bytes" . setContentType mime- . setContentLength sz- sendFile fp - where- --------------------------------------------------------------------------- chkModificationTime mt lt = when (mt <= lt) notModified + -- now check: is this a range request? If there is an 'If-Range' header+ -- with an old modification time we skip this check and send a 200 response+ let skipRangeCheck = maybe (False)+ (\lt -> mt > lt)+ mbIfRange++ -- checkRangeReq checks for a Range: header in the request and sends a+ -- partial response if it matches.+ wasRange <- if skipRangeCheck+ then return False+ else checkRangeReq req fp sz++ dbg $ "was this a range request? " ++ Prelude.show wasRange++ -- if we didn't have a range request, we just do normal sendfile+ unless wasRange $ do+ modifyResponse $ setResponseCode 200+ . setContentLength sz+ sendFile fp++ where -------------------------------------------------------------------------- notModified = finishWith $- setResponseStatus 304 "Not Modified" emptyResponse+ setResponseCode 304 emptyResponse ------------------------------------------------------------------------------@@ -262,3 +310,113 @@ ------------------------------------------------------------------------------ defaultMimeType :: ByteString defaultMimeType = "application/octet-stream"+++------------------------------------------------------------------------------+data RangeReq = RangeReq { _rangeFirst :: !Int64+ , _rangeLast :: !(Maybe Int64)+ }+ | SuffixRangeReq { _suffixLength :: !Int64 }+ deriving (Eq, Prelude.Show)+++------------------------------------------------------------------------------+rangeParser :: Parser RangeReq+rangeParser = string "bytes=" *>+ (byteRangeSpec <|> suffixByteRangeSpec) <*+ endOfInput+ where+ byteRangeSpec = do+ start <- parseNum+ char '-'+ end <- option Nothing $ liftM Just parseNum++ return $ RangeReq start end++ suffixByteRangeSpec = liftM SuffixRangeReq $ char '-' *> parseNum+++------------------------------------------------------------------------------+checkRangeReq :: Request -> FilePath -> Int64 -> Snap Bool+checkRangeReq req fp sz = do+ -- TODO/FIXME: multiple ranges+ dbg $ "checkRangeReq, fp=" ++ fp ++ ", sz=" ++ Prelude.show sz+ maybe (return False)+ (\s -> either (const $ return False)+ withRange+ (fullyParse s rangeParser))+ (getHeader "range" req)++ where+ withRange rng@(RangeReq start mend) = do+ dbg $ "withRange: got Range request: " ++ Prelude.show rng+ let end = fromMaybe (sz-1) mend+ dbg $ "withRange: start=" ++ Prelude.show start+ ++ ", end=" ++ Prelude.show end++ if start < 0 || end < start || start >= sz || end >= sz+ then send416+ else send206 start end++ withRange rng@(SuffixRangeReq nbytes) = do+ dbg $ "withRange: got Range request: " ++ Prelude.show rng+ let end = sz-1+ let start = sz - nbytes++ dbg $ "withRange: start=" ++ Prelude.show start+ ++ ", end=" ++ Prelude.show end++ if start < 0 || end < start || start >= sz || end >= sz+ then send416+ else send206 start end++ -- note: start and end INCLUSIVE here+ send206 start end = do+ dbg "inside send206"+ let len = end-start+1+ let crng = S.concat $+ L.toChunks $+ L.concat [ "bytes "+ , show start+ , "-"+ , show end+ , "/"+ , show sz ]++ modifyResponse $ setResponseCode 206+ . setHeader "Content-Range" crng+ . setContentLength len++ dbg $ "send206: sending range (" ++ Prelude.show start+ ++ "," ++ Prelude.show (end+1) ++ ") to sendFilePartial"++ -- end here was inclusive, sendFilePartial is exclusive+ sendFilePartial fp (start,end+1)+ return True+++ send416 = do+ dbg "inside send416"+ -- if there's an "If-Range" header in the request, then we just send+ -- back 200+ if getHeader "If-Range" req /= Nothing+ then return False+ else do+ let crng = S.concat $+ L.toChunks $+ L.concat ["bytes */", show sz]+ + modifyResponse $ setResponseCode 416+ . setHeader "Content-Range" crng+ . setContentLength 0+ . deleteHeader "Content-Type"+ . deleteHeader "Content-Encoding"+ . deleteHeader "Transfer-Encoding"+ . setResponseBody (enumBS "")+ + return True++++dbg :: (MonadIO m) => String -> m ()+dbg s = debug $ "FileServe:" ++ s
src/Snap/Util/GZip.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Snap.Util.GZip ( withCompression@@ -15,7 +15,6 @@ import Control.Monad import Control.Monad.Trans import Data.Attoparsec.Char8 hiding (Done)-import qualified Data.Attoparsec.Char8 as Atto import qualified Data.ByteString.Lazy.Char8 as L import Data.ByteString.Char8 (ByteString) import Data.Iteratee.WrappedByteString@@ -27,6 +26,7 @@ ------------------------------------------------------------------------------ import Snap.Internal.Debug+import Snap.Internal.Parsing import Snap.Iteratee hiding (Enumerator) import Snap.Types @@ -80,18 +80,14 @@ -- If a content-encoding is already set, do nothing. This prevents -- "withCompression $ withCompression m" from ruining your day.- if isJust $ getHeader "Content-Encoding" resp- then return ()- else do- let mbCt = getHeader "Content-Type" resp+ when (not $ isJust $ getHeader "Content-Encoding" resp) $ do+ let mbCt = getHeader "Content-Type" resp - debug $ "withCompression', content-type is " ++ show mbCt+ debug $ "withCompression', content-type is " ++ show mbCt - case mbCt of- (Just ct) -> if Set.member ct mimeTable- then chkAcceptEncoding- else return ()- _ -> return ()+ case mbCt of+ (Just ct) -> when (Set.member ct mimeTable) chkAcceptEncoding+ _ -> return $! () getResponse >>= finishWith@@ -110,7 +106,7 @@ chooseType types - chooseType [] = return ()+ chooseType [] = return $! () chooseType ("gzip":_) = gzipCompression "gzip" chooseType ("compress":_) = compressCompression "compress" chooseType ("x-gzip":_) = gzipCompression "x-gzip"@@ -197,9 +193,7 @@ ch <- readChan writeEnd iter' <- liftM liftI $ runIter iter ch- if (streamFinished ch)- then return iter'- else consumeSomeOutput writeEnd iter'+ consumeSomeOutput writeEnd iter' --------------------------------------------------------------------------@@ -222,10 +216,9 @@ killThread tid return x - f _ _ tid i ch@(EOF (Just _)) = do- x <- runIter i ch+ f _ _ tid _ (EOF (Just e)) = do killThread tid- return x+ return $ Cont undefined (Just e) f readEnd writeEnd tid i (Chunk s') = do let s = unWrap s'@@ -240,18 +233,19 @@ -> IO () threadProc readEnd writeEnd = do stream <- getChanContents readEnd- let bs = L.fromChunks $ streamToChunks stream + let bs = L.fromChunks $ streamToChunks stream let output = L.toChunks $ compFunc bs- let runIt = do- --Prelude specified to work with iteratee-0.3.6- Prelude.mapM_ (writeChan writeEnd . toChunk) output- writeChan writeEnd $ EOF Nothing - runIt `catch` \(e::SomeException) ->+ runIt output `catch` \(e::SomeException) -> writeChan writeEnd $ EOF (Just $ Err $ show e) + where+ runIt (x:xs) = do+ writeChan writeEnd (toChunk x) >> runIt xs + runIt [] = do+ writeChan writeEnd $ EOF Nothing -------------------------------------------------------------------------- streamToChunks [] = [] streamToChunks (Nothing:_) = []@@ -260,18 +254,6 @@ -------------------------------------------------------------------------- toChunk = Chunk . WrapBS----------------------------------------------------------------------------------fullyParse :: ByteString -> Parser a -> Either String a-fullyParse s p =- case r' of- (Fail _ _ e) -> Left e- (Partial _) -> Left "parse failed"- (Atto.Done _ x) -> Right x- where- r = parse p s- r' = feed r "" ------------------------------------------------------------------------------
test/runTestsAndCoverage.sh view
@@ -2,7 +2,10 @@ set -e -export DEBUG=testsuite+if [ -z "$DEBUG" ]; then+ export DEBUG="testsuite"+fi+ SUITE=./dist/build/testsuite/testsuite export LC_ALL=C@@ -30,6 +33,7 @@ EXCLUDES='Main Data.CIByteString Snap.Internal.Debug+Snap.Internal.Iteratee.Debug Snap.Iteratee.Tests Snap.Internal.Http.Parser.Tests Snap.Internal.Http.Server.Tests
test/snap-core-testsuite.cabal view
@@ -25,6 +25,7 @@ base >= 4 && < 5, bytestring, bytestring-nums,+ bytestring-show >= 0.3.2 && < 0.4, cereal >= 0.3 && < 0.4, containers, deepseq >= 1.1 && <1.2,@@ -39,6 +40,7 @@ old-locale, old-time, parallel >= 2.2 && <2.3,+ pureMD5 == 2.1.*, regex-posix >= 0.94.4 && <0.95, test-framework >= 0.3.1 && <0.4, test-framework-hunit >= 0.2.5 && < 0.3,
test/suite/Snap/Internal/Http/Types/Tests.hs view
@@ -40,7 +40,7 @@ testFormatLogTime = testCase "formatLogTime" $ do b <- formatLogTime 3804938 - let re = ("^[0-9]{1,2}/[A-Za-z]{3}/[0-9]{4}:[0-9]{2}:[0-9]{2}:[0-9]{2} -[0-9]{4}$"+ let re = ("^[0-9]{1,2}/[A-Za-z]{3}/[0-9]{4}:[0-9]{2}:[0-9]{2}:[0-9]{2} (-|\\+)[0-9]{4}$" :: ByteString) assertBool "formatLogTime" $ b =~ re
test/suite/Snap/Iteratee/Tests.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Snap.Iteratee.Tests ( tests ) where@@ -24,7 +25,6 @@ import Test.QuickCheck.Monadic hiding (run) import Test.Framework.Providers.HUnit import qualified Test.HUnit as H-import System.IO.Unsafe import Snap.Iteratee import Snap.Test.Common ()
test/suite/Snap/Types/Tests.hs view
@@ -105,7 +105,9 @@ mkIpHeaderRq :: IO Request mkIpHeaderRq = do rq <- mkZomgRq- return $ setHeader "X-Forwarded-For" "1.2.3.4" rq+ return $ setHeader "X-Forwarded-For" "1.2.3.4"+ $ deleteHeader "X-Forwarded-For"+ $ setHeader "X-Forwarded-For" "1.2.3.4" rq mkRqWithBody :: IO Request@@ -409,8 +411,8 @@ assertEqual "status description" "Found" $ rspStatusReason rsp - (_,rsp) <- go (redirect' "/bar/foo" 307)+ (_,rsp2) <- go (redirect' "/bar/foo" 307) - assertEqual "redirect path" (Just "/bar/foo") $ getHeader "Location" rsp- assertEqual "redirect status" 307 $ rspStatus rsp- assertEqual "status description" "Temporary Redirect" $ rspStatusReason rsp+ assertEqual "redirect path" (Just "/bar/foo") $ getHeader "Location" rsp2+ assertEqual "redirect status" 307 $ rspStatus rsp2+ assertEqual "status description" "Temporary Redirect" $ rspStatusReason rsp2
test/suite/Snap/Util/FileServe/Tests.hs view
@@ -7,7 +7,7 @@ import Control.Monad import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.IORef import qualified Data.Map as Map@@ -24,7 +24,11 @@ tests :: [Test] tests = [ testFs- , testFsSingle ]+ , testFsSingle+ , testRangeOK+ , testRangeBad+ , testMultiRange+ , testIfRange ] expect404 :: IO Response -> IO ()@@ -42,6 +46,7 @@ rq <- mkRequest s liftM snd (run $ runSnap m (const $ return ()) rq) + goIfModifiedSince :: Snap a -> ByteString -> ByteString -> IO Response goIfModifiedSince m s lm = do rq <- mkRequest s@@ -49,12 +54,59 @@ liftM snd (run $ runSnap m (const $ return ()) r) +goIfRange :: Snap a -> ByteString -> (Int,Int) -> ByteString -> IO Response+goIfRange m s (start,end) lm = do+ rq <- mkRequest s+ let r = setHeader "if-range" lm $+ setHeader "Range"+ (S.pack $ "bytes=" ++ show start ++ "-" ++ show end)+ rq+ liftM snd (run $ runSnap m (const $ return ()) r)+++goRange :: Snap a -> ByteString -> (Int,Int) -> IO Response+goRange m s (start,end) = do+ rq' <- mkRequest s+ let rq = setHeader "Range"+ (S.pack $ "bytes=" ++ show start ++ "-" ++ show end)+ rq'+ liftM snd (run $ runSnap m (const $ return ()) rq)+++goMultiRange :: Snap a -> ByteString -> (Int,Int) -> (Int,Int) -> IO Response+goMultiRange m s (start,end) (start2,end2) = do+ rq' <- mkRequest s+ let rq = setHeader "Range"+ (S.pack $ "bytes=" ++ show start ++ "-" ++ show end+ ++ "," ++ show start2 ++ "-" ++ show end2)+ rq'+ liftM snd (run $ runSnap m (const $ return ()) rq)+++goRangePrefix :: Snap a -> ByteString -> Int -> IO Response+goRangePrefix m s start = do+ rq' <- mkRequest s+ let rq = setHeader "Range"+ (S.pack $ "bytes=" ++ show start ++ "-")+ rq'+ liftM snd (run $ runSnap m (const $ return ()) rq)+++goRangeSuffix :: Snap a -> ByteString -> Int -> IO Response+goRangeSuffix m s end = do+ rq' <- mkRequest s+ let rq = setHeader "Range"+ (S.pack $ "bytes=-" ++ show end)+ rq'+ liftM snd (run $ runSnap m (const $ return ()) rq)++ mkRequest :: ByteString -> IO Request mkRequest uri = do enum <- newIORef $ SomeEnumerator return return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False Map.empty enum Nothing GET (1,1) [] "" uri "/"- (B.concat ["/",uri]) "" Map.empty+ (S.concat ["/",uri]) "" Map.empty fs :: Snap () fs = do@@ -68,7 +120,7 @@ testFs :: Test-testFs = testCase "fileServe" $ do+testFs = testCase "fileServe/multi" $ do r1 <- go fs "foo.bin" b1 <- getBody r1 @@ -80,6 +132,9 @@ assertEqual "foo.bin size" (Just 4) (rspContentLength r1) assertBool "last-modified header" (isJust $ getHeader "last-modified" r1)+ assertEqual "accept-ranges header" (Just "bytes")+ (getHeader "accept-ranges" r1)+ let !lm = fromJust $ getHeader "last-modified" r1 -- check last modified stuff@@ -123,7 +178,7 @@ testFsSingle :: Test-testFsSingle = testCase "fileServeSingle" $ do+testFsSingle = testCase "fileServe/Single" $ do r1 <- go fsSingle "foo.html" b1 <- getBody r1 @@ -135,8 +190,75 @@ assertEqual "foo.html size" (Just 4) (rspContentLength r1) +testRangeOK :: Test+testRangeOK = testCase "fileServe/range/ok" $ do+ r1 <- goRange fsSingle "foo.html" (1,2)+ assertEqual "foo.html 206" 206 $ rspStatus r1+ b1 <- getBody r1 + assertEqual "foo.html partial" "OO" b1+ assertEqual "foo.html partial size" (Just 2) (rspContentLength r1)+ assertEqual "foo.html content-range"+ (Just "bytes 1-2/4")+ (getHeader "Content-Range" r1)++ r2 <- goRangeSuffix fsSingle "foo.html" 3+ assertEqual "foo.html 206" 206 $ rspStatus r2+ b2 <- getBody r2+ assertEqual "foo.html partial suffix" "OO\n" b2++ r3 <- goRangePrefix fsSingle "foo.html" 2+ assertEqual "foo.html 206" 206 $ rspStatus r3+ b3 <- getBody r3+ assertEqual "foo.html partial prefix" "O\n" b3+++testMultiRange :: Test+testMultiRange = testCase "fileServe/range/multi" $ do+ r1 <- goMultiRange fsSingle "foo.html" (1,2) (3,3)++ -- we don't support multiple ranges so it's ok for us to return 200 here;+ -- test this behaviour+ assertEqual "foo.html 200" 200 $ rspStatus r1+ b1 <- getBody r1++ assertEqual "foo.html" "FOO\n" b1+++testRangeBad :: Test+testRangeBad = testCase "fileServe/range/bad" $ do+ r1 <- goRange fsSingle "foo.html" (1,17)+ assertEqual "bad range" 416 (rspStatus r1)+ assertEqual "bad range content-range"+ (Just "bytes */4")+ (getHeader "Content-Range" r1)+ assertEqual "bad range content-length" (Just 0) (rspContentLength r1)+ b1 <- getBody r1+ assertEqual "bad range empty body" "" b1++ r2 <- goRangeSuffix fsSingle "foo.html" 4893+ assertEqual "bad suffix range" 416 $ rspStatus r2++ coverMimeMap :: (Monad m) => m () coverMimeMap = Prelude.mapM_ f $ Map.toList defaultMimeTypes where f (!k,!v) = return $ case k `seq` v `seq` () of () -> ()+++testIfRange :: Test+testIfRange = testCase "fileServe/range/if-range" $ do+ r <- goIfRange fs "foo.bin" (1,2) "Wed, 15 Nov 1995 04:58:08 GMT"+ assertEqual "foo.bin 200" 200 $ rspStatus r+ b <- getBody r+ assertEqual "foo.bin" "FOO\n" b++ r2 <- goIfRange fs "foo.bin" (1,2) "Tue, 1 Oct 2030 04:58:08 GMT"+ assertEqual "foo.bin 206" 206 $ rspStatus r2+ b2 <- getBody r2+ assertEqual "foo.bin partial" "OO" b2++ r3 <- goIfRange fs "foo.bin" (1,24324) "Tue, 1 Oct 2030 04:58:08 GMT"+ assertEqual "foo.bin 200" 200 $ rspStatus r3+ b3 <- getBody r3+ assertEqual "foo.bin" "FOO\n" b3
test/suite/Snap/Util/GZip/Tests.hs view
@@ -10,14 +10,18 @@ import qualified Codec.Compression.Zlib as Zlib import Control.Exception hiding (assert) import qualified Data.ByteString.Lazy.Char8 as L+import Data.Digest.Pure.MD5 import Data.IORef import Data.Iteratee import qualified Data.Map as Map+import Data.Serialize import Test.Framework import Test.Framework.Providers.QuickCheck2 import Test.QuickCheck import qualified Test.QuickCheck.Monadic as QC import Test.QuickCheck.Monadic hiding (run)+import Test.Framework.Providers.HUnit+import qualified Test.HUnit as H import Snap.Types import Snap.Internal.Http.Types@@ -33,9 +37,13 @@ , testIdentity3 , testIdentity4 , testIdentity5+ , testNoHeaders+ , testNoAcceptEncoding , testNopWhenContentEncodingSet , testCompositionDoesn'tExplode- , testBadHeaders ]+ , testGzipLotsaChunks+ , testBadHeaders+ , testIterateeException ] ------------------------------------------------------------------------------@@ -64,6 +72,14 @@ ------------------------------------------------------------------------------+mkNoHeaders :: IO Request+mkNoHeaders = do+ enum <- newIORef $ SomeEnumerator return++ return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False emptyHdrs+ enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty++ mkGzipRq :: IO Request mkGzipRq = do enum <- newIORef $ SomeEnumerator return@@ -106,29 +122,40 @@ enum Nothing GET (1,1) [] "" "/" "/" "/" "" Map.empty -------------------------------------------------------------------------------goGZip, goCompress, goXGZip, goXCompress, goBad :: Snap a -> IO (Request,Response)-goGZip m = do- gzipRq <- mkGzipRq- run $ runSnap m (const $ return ()) gzipRq+seqSnap :: Snap a -> Snap a+seqSnap m = do+ !x <- m+ return $! x `seq` x -goCompress m = do- compressRq <- mkCompressRq- run $ runSnap m (const $ return ()) compressRq -goXGZip m = do- gzipRq <- mkXGzipRq- run $ runSnap m (const $ return ()) gzipRq+------------------------------------------------------------------------------+goGeneric :: IO Request -> Snap a -> IO (Request, Response)+goGeneric mkRq m = do+ rq <- mkRq+ run $! runSnap (seqSnap m) (const $ return ()) rq -goXCompress m = do- compressRq <- mkXCompressRq- run $ runSnap m (const $ return ()) compressRq+goGZip, goCompress, goXGZip :: Snap a -> IO (Request,Response)+goNoHeaders, goXCompress, goBad :: Snap a -> IO (Request,Response) +goGZip = goGeneric mkGzipRq+goCompress = goGeneric mkCompressRq+goXGZip = goGeneric mkXGzipRq+goXCompress = goGeneric mkXCompressRq+goBad = goGeneric mkBadRq+goNoHeaders = goGeneric mkNoHeaders -goBad m = do- badRq <- mkBadRq- run $ runSnap m (const $ return ()) badRq+------------------------------------------------------------------------------+noContentType :: L.ByteString -> Snap ()+noContentType s = modifyResponse $ setResponseBody (enumLBS s) + ------------------------------------------------------------------------------+textPlainErr :: L.ByteString -> Snap ()+textPlainErr s = modifyResponse $+ setResponseBody (enumLBS s >. enumErr "blah") .+ setContentType "text/plain"++ textPlain :: L.ByteString -> Snap () textPlain s = modifyResponse $ setResponseBody (enumLBS s) .@@ -143,13 +170,56 @@ ------------------------------------------------------------------------------+testNoHeaders :: Test+testNoHeaders = testProperty "gzip/noheaders" $+ monadicIO $+ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = do+ -- if there's no content-type, withCompression should be a no-op+ (!_,!rsp) <- liftQ $ goNoHeaders (seqSnap $ withCompression+ $ noContentType s)+ assert $ getHeader "Content-Encoding" rsp == Nothing+ assert $ getHeader "Vary" rsp == Nothing+ let body = rspBodyToEnum $ rspBody rsp++ c <- liftQ $+ body stream2stream >>= run >>= return . fromWrap++ assert $ s == c+++------------------------------------------------------------------------------+testNoAcceptEncoding :: Test+testNoAcceptEncoding = testProperty "gzip/noAcceptEncoding" $+ monadicIO $+ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = do+ -- if there's no content-type, withCompression should be a no-op+ (!_,!rsp) <- liftQ $ goNoHeaders (seqSnap $ withCompression+ $ textPlain s)+ assert $ getHeader "Content-Encoding" rsp == Nothing+ assert $ getHeader "Vary" rsp == Nothing+ let body = rspBodyToEnum $ rspBody rsp++ c <- liftQ $+ body stream2stream >>= run >>= return . fromWrap++ assert $ s == c+++------------------------------------------------------------------------------ testIdentity1 :: Test-testIdentity1 = testProperty "identity1" $ monadicIO $ forAllM arbitrary prop+testIdentity1 = testProperty "gzip/identity1" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do- (_,rsp) <- liftQ $ goGZip (withCompression $ textPlain s)+ (!_,!rsp) <- liftQ $ goGZip (seqSnap $ withCompression $ textPlain s) assert $ getHeader "Content-Encoding" rsp == Just "gzip"+ assert $ getHeader "Vary" rsp == Just "Accept-Encoding" let body = rspBodyToEnum $ rspBody rsp c <- liftQ $@@ -161,29 +231,30 @@ ------------------------------------------------------------------------------ testIdentity2 :: Test-testIdentity2 = testProperty "identity2" $ monadicIO $ forAllM arbitrary prop+testIdentity2 = testProperty "gzip/identity2" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do- (_,rsp2) <- liftQ $ goCompress (withCompression $ textPlain s)+ (!_,!rsp) <- liftQ $ goCompress (seqSnap $ withCompression $ textPlain s) - assert $ getHeader "Content-Encoding" rsp2 == Just "compress"- let body2 = rspBodyToEnum $ rspBody rsp2+ assert $ getHeader "Content-Encoding" rsp == Just "compress"+ assert $ getHeader "Vary" rsp == Just "Accept-Encoding"+ let body = rspBodyToEnum $ rspBody rsp - c2 <- liftQ $- body2 stream2stream >>= run >>= return . fromWrap+ c <- liftQ $+ body stream2stream >>= run >>= return . fromWrap - let s2 = Zlib.decompress c2- assert $ s == s2+ let s' = Zlib.decompress c+ assert $ s == s' ------------------------------------------------------------------------------ testIdentity3 :: Test-testIdentity3 = testProperty "identity3" $ monadicIO $ forAllM arbitrary prop+testIdentity3 = testProperty "gzip/identity3" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do- (_,rsp3) <- liftQ $ goGZip (withCompression $ binary s)+ (!_,!rsp3) <- liftQ $ goGZip (seqSnap $ withCompression $ binary s) let body3 = rspBodyToEnum $ rspBody rsp3 s3 <- liftQ $@@ -194,11 +265,11 @@ ------------------------------------------------------------------------------ testIdentity4 :: Test-testIdentity4 = testProperty "identity4" $ monadicIO $ forAllM arbitrary prop+testIdentity4 = testProperty "gzip/identity4" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do- (_,rsp) <- liftQ $ goXGZip (withCompression $ textPlain s)+ (!_,!rsp) <- liftQ $ goXGZip (seqSnap $ withCompression $ textPlain s) assert $ getHeader "Content-Encoding" rsp == Just "x-gzip" let body = rspBodyToEnum $ rspBody rsp @@ -211,11 +282,11 @@ ------------------------------------------------------------------------------ testIdentity5 :: Test-testIdentity5 = testProperty "identity5" $ monadicIO $ forAllM arbitrary prop+testIdentity5 = testProperty "gzip/identity5" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do- (_,rsp2) <- liftQ $ goXCompress (withCompression $ textPlain s)+ (!_,!rsp2) <- liftQ $ goXCompress (seqSnap $ withCompression $ textPlain s) assert $ getHeader "Content-Encoding" rsp2 == Just "x-compress" let body2 = rspBodyToEnum $ rspBody rsp2@@ -229,11 +300,11 @@ ------------------------------------------------------------------------------ testBadHeaders :: Test-testBadHeaders = testProperty "bad headers" $ monadicIO $ forAllM arbitrary prop+testBadHeaders = testProperty "gzip/bad headers" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = expectException $ do- (_,rsp) <- goBad (withCompression $ textPlain s)+ (!_,!rsp) <- goBad (seqSnap $ withCompression $ textPlain s) let body = rspBodyToEnum $ rspBody rsp body stream2stream >>= run >>= return . fromWrap@@ -241,16 +312,17 @@ ------------------------------------------------------------------------------ testNopWhenContentEncodingSet :: Test-testNopWhenContentEncodingSet = testProperty "testNopWhenContentEncodingSet" $- monadicIO $- forAllM arbitrary prop+testNopWhenContentEncodingSet =+ testProperty "gzip/testNopWhenContentEncodingSet" $+ monadicIO $+ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do- (_,rsp) <- liftQ $ goGZip $ f s+ (!_,!rsp) <- liftQ $ goGZip $ f s assert $ getHeader "Content-Encoding" rsp == Just "identity" - f s = withCompression $ do+ f !s = seqSnap $ withCompression $ do modifyResponse $ setHeader "Content-Encoding" "identity" textPlain s @@ -258,15 +330,16 @@ ------------------------------------------------------------------------------ testCompositionDoesn'tExplode :: Test testCompositionDoesn'tExplode =- testProperty "testCompositionDoesn'tExplode" $+ testProperty "gzip/testCompositionDoesn'tExplode" $ monadicIO $ forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do- (_,rsp) <- liftQ $ goGZip (withCompression $- withCompression $- withCompression $ textPlain s)+ (!_,!rsp) <- liftQ $ goGZip (seqSnap $+ withCompression $+ withCompression $+ withCompression $ textPlain s) assert $ getHeader "Content-Encoding" rsp == Just "gzip" @@ -277,3 +350,37 @@ let s1 = GZip.decompress c assert $ s == s1+++------------------------------------------------------------------------------+testGzipLotsaChunks :: Test+testGzipLotsaChunks = testCase "gzip/lotsOfChunks" prop+ where+ prop = do+ let s = L.take 120000 $ L.fromChunks $ frobnicate "dshflkahdflkdhsaflk"+ (!_,!rsp) <- goGZip (seqSnap $ withCompression $ textPlain s)+ let body = rspBodyToEnum $ rspBody rsp++ c <- body stream2stream >>= run >>= return . fromWrap++ let s1 = GZip.decompress c+ H.assertBool "streams equal" $ s == s1++ + -- in order to get incompressible text (so that we can test whether the+ -- gzip thread is streaming properly!) we'll iteratively md5 the source+ -- string+ frobnicate s = let s' = encode $ md5 $ L.fromChunks [s]+ in (s:frobnicate s')+++------------------------------------------------------------------------------+testIterateeException :: Test+testIterateeException = testProperty "gzip/iterateeException" $+ monadicIO $ forAllM arbitrary prop+ where+ prop :: L.ByteString -> PropertyM IO ()+ prop s = expectException $ do+ (!_,!rsp) <- goGZip (seqSnap $ withCompression $ textPlainErr s)+ let body = rspBodyToEnum $ rspBody rsp+ body stream2stream >>= run >>= return . fromWrap