git.iko.soy/typeable/wai
on master help sign in
Byte range support

Note that this only supports single ranges

commitfea69668b6726e1957255b1c8c76241a65b432ce authorMichael Snoyman <michael@snoyman.com> dateSun 23 Jun 2013, 14:20 (13 years ago) parentc3eafc2
5 files changed+127−16
compare with master
unifiedsplit
warp/Network/Wai/Handler/Warp/Response.hs+45−15 warp/attic/hex+1 warp/test/PartialFileSpec.hs+77 warp/test/RunSpec.hs+1−1 warp/warp.cabal+3
warp/Network/Wai/Handler/Warp/Response.hs+45−15
@@ -1,5 +1,6 @@
11{-# LANGUAGE OverloadedStrings #-}
22{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE TupleSections #-}
34
45module Network.Wai.Handler.Warp.Response (
56 sendResponse
@@ -16,7 +17,7 @@ import qualified Data.CaseInsensitive as CI
1617import Data.Conduit
1718import Data.Conduit.Blaze (builderToByteString)
1819import qualified Data.Conduit.List as CL
19−import Data.Maybe (isJust)
20+import Data.Maybe (isJust, listToMaybe)
2021import Data.Monoid (mappend)
2122import qualified Network.HTTP.Types as H
2223import Network.Wai
@@ -26,6 +27,8 @@ import qualified Network.Wai.Handler.Warp.ResponseHeader as RH
2627import qualified Network.Wai.Handler.Warp.Timeout as T
2728import Network.Wai.Handler.Warp.Types
2829import qualified System.PosixCompat.Files as P
30+import Network.HTTP.Attoparsec (parseByteRanges)
31+import Numeric (showInt)
2932
3033----------------------------------------------------------------
3134----------------------------------------------------------------
@@ -36,20 +39,47 @@ sendResponse :: Settings
3639
3740----------------------------------------------------------------
3841
39−sendResponse settings cleaner req conn (ResponseFile s hs path mpart) =
42+sendResponse settings cleaner req conn (ResponseFile s0 hs0 path mpart0) =
4043 headerAndLength >>= sendResponse'
4144 where
45+ hs = addAccept hs0
4246 th = threadHandle cleaner
43− headerAndLength = case (readInt <$> checkLength hs, mpart) of
44− (Just cl, _) -> return $ Right (hs, cl)
45− (Nothing, Nothing) -> liftIO . try $ do
46− cl <- fromIntegral . P.fileSize <$> P.getFileStatus path
47− return (addLength cl hs, cl)
48− (Nothing, Just part) -> do
49− let cl = fromIntegral $ filePartByteCount part
50− return $ Right (addLength cl hs, cl)
51−
52− sendResponse' (Right (lengthyHeaders, cl))
47+ headerAndLength = liftIO . try $ do
48+ (hadLength, cl) <-
49+ case readInt <$> checkLength hs of
50+ Just cl -> return (True, cl)
51+ Nothing ->
52+ case mpart0 of
53+ Just part -> return (False, fromIntegral $ filePartByteCount part)
54+ Nothing -> (False, ) . fromIntegral . P.fileSize
55+ <$> P.getFileStatus path
56+ let (s, addRange, beg, end) =
57+ case mpart0 of
58+ Just part -> (s0, id, filePartOffset part, filePartByteCount part)
59+ Nothing ->
60+ case lookup H.hRange (requestHeaders req) >>= parseByteRanges >>= listToMaybe of
61+ Just range | s0 == H.status200 ->
62+ case range of
63+ H.ByteRangeFrom from -> rangeRes cl from (cl - 1)
64+ H.ByteRangeFromTo from to -> rangeRes cl from to
65+ H.ByteRangeSuffix count -> rangeRes cl (cl - count) (cl - 1)
66+ _ -> (s0, id, 0, cl)
67+ hs'
68+ | hadLength = hs
69+ | otherwise = addLength end hs
70+ return (s, addRange hs', beg, end)
71+
72+ rangeRes cl from to = (H.status206, (("Content-Range", rangeHeader cl from to):), from, to - from + 1)
73+
74+ rangeHeader total from to = B.pack
75+ $ 'b' : 'y': 't' : 'e' : 's' : ' '
76+ : showInt from
77+ ( '-'
78+ : showInt to
79+ ( '/'
80+ : showInt total ""))
81+
82+ sendResponse' (Right (s, lengthyHeaders, beg, end))
5383 | hasBody s req = liftIO $ do
5484 lheader <- composeHeader settings version s lengthyHeaders
5585 connSendFile conn path beg end (T.tickle th) [lheader] cleaner
@@ -60,9 +90,6 @@ sendResponse settings cleaner req conn (ResponseFile s hs path mpart) =
6090 T.tickle th
6191 return isPersist -- FIXME isKeepAlive?
6292 where
63− (beg,end) = case mpart of
64− Nothing -> (0,cl)
65− Just prt -> (filePartOffset prt, filePartByteCount prt)
6693 version = httpVersion req
6794 (isPersist,_) = infoFromRequest req
6895
@@ -192,6 +219,9 @@ hasBody s req = sc /= 204
192219addLength :: Integer -> H.ResponseHeaders -> H.ResponseHeaders
193220addLength cl hdrs = (H.hContentLength, B.pack $ show cl) : hdrs
194221
222+addAccept :: H.ResponseHeaders -> H.ResponseHeaders
223+addAccept = (("Accept-Ranges", "bytes"):)
224+
195225addEncodingHeader :: H.ResponseHeaders -> H.ResponseHeaders
196226addEncodingHeader hdrs = (hTransferEncoding, "chunked") : hdrs
197227
warp/attic/hexnew file+1
@@ -0,0 +1 @@
1+0123456789abcdef
warp/test/PartialFileSpec.hsnew file+77
@@ -0,0 +1,77 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module PartialFileSpec (main, spec) where
3+
4+import Network.Wai.Handler.Warp.Conduit
5+import Data.Conduit
6+import qualified Data.Conduit.List as CL
7+import Test.Hspec
8+import qualified Data.IORef as I
9+import qualified Data.ByteString as S
10+import qualified Data.ByteString.Char8 as S8
11+import Control.Monad.Trans.Class (lift)
12+import RunSpec (withApp)
13+import Network.HTTP.Types (status200)
14+import Network.Wai
15+import System.IO (hClose)
16+import Network (connectTo, PortID (PortNumber))
17+import Network.Wai.Handler.Warp
18+import Data.Maybe (mapMaybe)
19+
20+main :: IO ()
21+main = hspec spec
22+
23+testRange :: S.ByteString -- ^ range value
24+ -> String -- ^ expected output
25+ -> String -- ^ expected content-range value
26+ -> Spec
27+testRange range out crange = it title $ withApp defaultSettings app $ \port -> do
28+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
29+ S.hPutStr handle "GET / HTTP/1.0\r\n"
30+ S.hPutStr handle "Range: bytes="
31+ S.hPutStr handle range
32+ S.hPutStr handle "\r\n\r\n"
33+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetContents handle
34+ hClose handle
35+ out `shouldBe` last bss
36+ let hs = mapMaybe toHeader bss
37+ lookup "Content-Range" hs `shouldBe` Just ("bytes " ++ crange)
38+ lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)
39+ where
40+ app _ = return $ ResponseFile status200 [] "attic/hex" Nothing
41+ title = show (range, out, crange)
42+ toHeader s =
43+ case break (== ':') s of
44+ (x, ':':y) -> Just (x, dropWhile (== ' ') y)
45+ _ -> Nothing
46+
47+testPartial :: Integer -- ^ offset
48+ -> Integer -- ^ byte count
49+ -> String -- ^ expected output
50+ -> Spec
51+testPartial offset count out = it title $ withApp defaultSettings app $ \port -> do
52+ handle <- connectTo "127.0.0.1" $ PortNumber $ fromIntegral port
53+ S.hPutStr handle "GET / HTTP/1.0\r\n\r\n"
54+ bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ S.hGetContents handle
55+ hClose handle
56+ out `shouldBe` last bss
57+ let hs = mapMaybe toHeader bss
58+ lookup "Content-Length" hs `shouldBe` Just (show $ length $ last bss)
59+ where
60+ app _ = return $ ResponseFile status200 [] "attic/hex" $ Just $ FilePart offset count
61+ title = show (offset, count, out)
62+ toHeader s =
63+ case break (== ':') s of
64+ (x, ':':y) -> Just (x, dropWhile (== ' ') y)
65+ _ -> Nothing
66+
67+spec :: Spec
68+spec = do
69+ describe "range requests" $ do
70+ testRange "2-3" "23" "2-3/16"
71+ testRange "5-" "56789abcdef" "5-15/16"
72+ testRange "5-8" "5678" "5-8/16"
73+ testRange "-3" "def" "13-15/16"
74+ describe "partial files" $ do
75+ testPartial 2 2 "23"
76+ testPartial 0 2 "01"
77+ testPartial 3 8 "3456789a"
warp/test/RunSpec.hs+1−1
@@ -1,7 +1,7 @@
11{-# LANGUAGE OverloadedStrings #-}
22{-# LANGUAGE ScopedTypeVariables #-}
33
4−module RunSpec (main, spec) where
4+module RunSpec (main, spec, withApp) where
55
66import Control.Concurrent (forkIO, killThread, threadDelay)
77import Control.Monad (forM_)
warp/warp.cabal+3
@@ -16,6 +16,7 @@ Description:
1616 Changelog
1717 .
1818 [1.3.7] Sockets now have FD_CLOEXEC set on them. This behavior is more secure, and the change should not affect the vast majority of use cases.
19+extra-source-files: attic/hex
1920
2021Flag network-bytestring
2122 Default: False
@@ -40,6 +41,7 @@ Library
4041 , unix-compat >= 0.2
4142 , void
4243 , wai >= 1.3 && < 1.5
44+ , http-attoparsec
4345 if flag(network-bytestring)
4446 Build-Depends: network >= 2.2.1.5 && < 2.2.3
4547 , network-bytestring >= 0.1.3 && < 0.1.4
@@ -88,6 +90,7 @@ Test-Suite spec
8890 , unix-compat >= 0.2
8991 , void
9092 , wai
93+ , http-attoparsec
9194 , network
9295 , HUnit
9396 , QuickCheck