Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

More tests and a couple of small bugfixes for range support

  • Loading branch information...
commit 5160fec00d245a612f691780eccd56d97d2c01eb 1 parent edca479
@gregorycollins gregorycollins authored
Showing with 120 additions and 7 deletions.
  1. +22 −6 src/Snap/Util/FileServe.hs
  2. +98 −1 test/suite/Snap/Util/FileServe/Tests.hs
View
28 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)
View
99 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
Please sign in to comment.
Something went wrong with that request. Please try again.