This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-core".
The branch, 0.2-stable has been updated
via 5160fec00d245a612f691780eccd56d97d2c01eb (commit)
from edca479ff52b933a2c1a0c9e3dd7e4bf583d2177 (commit)
Summary of changes:
src/Snap/Util/FileServe.hs | 28 +++++++--
test/suite/Snap/Util/FileServe/Tests.hs | 99 ++++++++++++++++++++++++++++++-
2 files changed, 120 insertions(+), 7 deletions(-)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 5160fec00d245a612f691780eccd56d97d2c01eb
Author: Gregory Collins <[email protected]>
Date: Sun Oct 10 16:19:13 2010 +0200
More tests and a couple of small bugfixes for range support
diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs
index 41afc2d..bd8222b 100644
--- a/src/Snap/Util/FileServe.hs
+++ b/src/Snap/Util/FileServe.hs
@@ -26,7 +26,7 @@ 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
@@ -227,7 +227,13 @@ fileServeSingle' :: ByteString -- ^ MIME type
mapping
-> 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
@@ -235,15 +241,22 @@ fileServeSingle' mime fp = do
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 ()) (\lt -> when (mt <= lt) notModified) mbIfModified
+ maybe (return $! ()) (\lt -> when (mt <= lt) notModified) mbIfModified
let sz = fromIntegral $ fileSize filestat
lm <- liftIO $ formatHttpTime mt
@@ -261,7 +274,6 @@ fileServeSingle' mime fp = do
(\lt -> mt > lt)
mbIfRange
-
-- checkRangeReq checks for a Range: header in the request and sends a
-- partial response if it matches.
wasRange <- if skipRangeCheck
@@ -310,11 +322,14 @@ data RangeReq = RangeReq { _rangeFirst :: !Int64
------------------------------------------------------------------------------
rangeParser :: Parser RangeReq
-rangeParser = string "bytes=" *> (byteRangeSpec <|> suffixByteRangeSpec)
+rangeParser = string "bytes=" *>
+ (byteRangeSpec <|> suffixByteRangeSpec) <*
+ endOfInput
where
byteRangeSpec = do
start <- parseNum
- end <- option Nothing $ liftM Just (char '-' *> parseNum)
+ char '-'
+ end <- option Nothing $ liftM Just parseNum
return $ RangeReq start end
@@ -324,6 +339,7 @@ rangeParser = string "bytes=" *> (byteRangeSpec <|>
suffixByteRangeSpec)
------------------------------------------------------------------------------
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)
diff --git a/test/suite/Snap/Util/FileServe/Tests.hs
b/test/suite/Snap/Util/FileServe/Tests.hs
index 6b1a5c9..fd05e34 100644
--- a/test/suite/Snap/Util/FileServe/Tests.hs
+++ b/test/suite/Snap/Util/FileServe/Tests.hs
@@ -26,7 +26,9 @@ tests :: [Test]
tests = [ testFs
, testFsSingle
, testRangeOK
- , testRangeBad ]
+ , testRangeBad
+ , testMultiRange
+ , testIfRange ]
expect404 :: IO Response -> IO ()
@@ -44,6 +46,7 @@ go m s = do
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
@@ -51,6 +54,16 @@ goIfModifiedSince m s lm = do
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
@@ -60,6 +73,34 @@ goRange m s (start,end) = do
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
@@ -91,6 +132,9 @@ testFs = testCase "fileServe/multi" $ do
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
@@ -149,19 +193,72 @@ testFsSingle = testCase "fileServe/Single" $ do
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
-----------------------------------------------------------------------
hooks/post-receive
--
snap-core
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
