Improve range handling to return 416

Prevent parsing negative range end-points, truncate ranges to file size, and
correctly return 416 when requested range is outside file bounds.

warp/Network/Wai/Handler/Warp/RequestHeader.hs

@@ -137,23 +137,21 @@ parseByteRanges bs1 = do
     (r, bs3) <- range bs2
     ranges (r:) bs3
   where
-    range bs2 =
-        case stripPrefix "-" bs2 of
-            Just bs3 -> do
-                (i, bs4) <- B.readInteger bs3
-                Just (HH.ByteRangeSuffix i, bs4)
-            Nothing -> do
-                (i, bs3) <- B.readInteger bs2
+    range bs2 = do
+        (i, bs3) <- B.readInteger bs2
+        if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-")
+            then Just (HH.ByteRangeSuffix (negate i), bs3)
+            else do
                 bs4 <- stripPrefix "-" bs3
                 case B.readInteger bs4 of
-                    Nothing -> Just (HH.ByteRangeFrom i, bs4)
-                    Just (j, bs5) -> Just (HH.ByteRangeFromTo i j, bs5)
-    ranges front bs3 =
-        case stripPrefix "," bs3 of
-            Nothing -> Just (front [])
-            Just bs4 -> do
-                (r, bs5) <- range bs4
-                ranges (front . (r:)) bs5
+                    Just (j, bs5) | j >= i -> Just (HH.ByteRangeFromTo i j, bs5)
+                    _ -> Just (HH.ByteRangeFrom i, bs4)
+    ranges front bs3 
+        | S.null bs3 = Just (front [])
+        | otherwise = do
+            bs4 <- stripPrefix "," bs3
+            (r, bs5) <- range bs4
+            ranges (front . (r:)) bs5
 
     stripPrefix x y
         | x `S.isPrefixOf` y = Just (S.drop (S.length x) y)

warp/Network/Wai/Handler/Warp/Response.hs

@@ -30,9 +30,9 @@ import Data.Function (on)
 import Data.List (deleteBy)
 import Data.Maybe (isJust, listToMaybe)
 #if MIN_VERSION_base(4,5,0)
-import Data.Monoid ((<>))
+import Data.Monoid ((<>), mempty)
 #else
-import Data.Monoid (mappend)
+import Data.Monoid (mappend, mempty)
 #endif
 import Data.Version (showVersion)
 import qualified Network.HTTP.Types as H
@@ -109,8 +109,8 @@ checkPartRange fileSize = checkPart
         isEntire = beg == 0 && len == fileSize
 
     checkRange (H.ByteRangeFrom   beg)     = fromRange beg (fileSize - 1)
-    checkRange (H.ByteRangeFromTo beg end) = fromRange beg end
-    checkRange (H.ByteRangeSuffix count)   = fromRange (fileSize - count) (fileSize - 1)
+    checkRange (H.ByteRangeFromTo beg end) = fromRange beg (min (fileSize - 1) end)
+    checkRange (H.ByteRangeSuffix count)   = fromRange (max 0 (fileSize - count)) (fileSize - 1)
 
     fromRange beg end = (beg, end, len, isEntire)
       where
@@ -225,9 +225,11 @@ sendRsp conn ver s0 hs0 (RspFile path mPart mRange hook) = do
           print _ex >>
 #endif
           sendRsp conn ver s2 hs2 (RspBuilder body True)
-        Right (s, hs1, beg, len) -> do
+        Right (s, hs1, beg, len) | len > 0 -> do
             lheader <- composeHeader ver s hs1
             connSendFile conn path beg len hook [lheader]
+          | otherwise -> do
+            sendRsp conn ver H.status416 hs1 (RspBuilder mempty True)
   where
     hs = addAcceptRanges hs0
     s2 = H.status404
@@ -373,11 +375,12 @@ addContentRange beg end total hdrs = (hContentRange, range) : hdrs
     range = B.pack
       -- building with ShowS
       $ 'b' : 'y': 't' : 'e' : 's' : ' '
-      : showInt beg
-      ( '-'
-      : showInt end
+      : (if beg > end then ('*':) else
+          (showInt beg)
+          . ('-' :)
+          . (showInt end))
       ( '/'
-      : showInt total ""))
+      : showInt total "")
 
 addDate :: D.DateCache -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders
 addDate dc rspidxhdr hdrs = case rspidxhdr ! idxDate of

warp/test/ResponseSpec.hs

@@ -19,7 +19,7 @@ main = hspec spec
 
 testRange :: S.ByteString -- ^ range value
           -> String -- ^ expected output
-          -> String -- ^ expected content-range value
+          -> Maybe String -- ^ expected content-range value
           -> Spec
 testRange range out crange = it title $ withApp defaultSettings app $ \port -> do
     handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
@@ -31,9 +31,9 @@ testRange range out crange = it title $ withApp defaultSettings app $ \port -> d
     threadDelay 10000
     bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetSome handle 1024
     hClose handle
-    out `shouldBe` last bss
+    last bss `shouldBe` out
     let hs = mapMaybe toHeader bss
-    lookup "Content-Range" hs `shouldBe` Just ("bytes " ++ crange)
+    lookup "Content-Range" hs `shouldBe` fmap ("bytes " ++) crange
     lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)
   where
     app _ = ($ responseFile status200 [] "attic/hex" Nothing)
@@ -83,10 +83,12 @@ testFileRange desc s rsphdr file mPart mRange ans = it desc $ do
 spec :: Spec
 spec = do
     describe "range requests" $ do
-        testRange "2-3" "23" "2-3/16"
-        testRange "5-" "56789abcdef" "5-15/16"
-        testRange "5-8" "5678" "5-8/16"
-        testRange "-3" "def" "13-15/16"
+        testRange "2-3" "23" $ Just "2-3/16"
+        testRange "5-" "56789abcdef" $ Just "5-15/16"
+        testRange "5-8" "5678" $ Just "5-8/16"
+        testRange "-3" "def" $ Just "13-15/16"
+        testRange "16-" "" $ Just "*/16"
+        testRange "-17" "0123456789abcdef" Nothing
 
     describe "partial files" $ do
         testPartial 16 2 2 "23"
@@ -114,6 +116,10 @@ spec = do
             "gets a file size from file system and handles Range and returns Partical Content"
             status200 [] "attic/hex" Nothing (Just "bytes=2-14")
             $ Right (status206,[("Content-Range","bytes 2-14/16"),("Content-Length","13")],2,13)
+        testFileRange
+            "truncates end point of range to file size"
+            status200 [] "attic/hex" Nothing (Just "bytes=10-20")
+            $ Right (status206,[("Content-Range","bytes 10-15/16"),("Content-Length","6")],10,6)
         testFileRange
             "gets a file size from file system and handles Range and returns OK if Range means the entire"
             status200 [] "attic/hex" Nothing (Just "bytes=0-15")