Changeset 1900 for trunk/server/common/oursrc

Timestamp:

Jun 11, 2011, 11:20:06 PM (13 years ago)

Author:

cberzan

Message:

static-cat: add support for multiple ranges

Also added the skeleton for a unit test. The test does not work yet, but the
included test cases are useful.

Location:

trunk/server/common/oursrc/scripts-static-cat

Files:

• StaticCat.hs (modified) (8 diffs)
• scripts-static-cat.cabal (modified) (1 diff)
• test.html (added)
• test.py (added)

trunk/server/common/oursrc/scripts-static-cat/StaticCat.hs

@@ -7 +7 @@
 import Control.Monad.CatchIO
 import qualified Data.ByteString.Lazy as B
+import Data.ByteString.Lazy.Char8 (pack)
 import Data.Char
 import Data.Dynamic
 import Data.Int
+import Data.List (unfoldr)
+import Data.List.Split (splitOn)
+import Data.Maybe (fromJust, isNothing, isJust)
 import qualified Data.Map as M
 import Data.Time.Clock.POSIX
 import Data.Time.Format
-import Network.CGI
+import Network.CGI hiding (ContentType)
 import Numeric
 import System.FilePath
@@ -22 +26 @@
 import System.Posix
 import System.Posix.Handle
-
-encodings :: M.Map String String
+import System.Random
+
+type Encoding = String
+type ContentType = String
+
+encodings :: M.Map String Encoding
 encodings = M.fromList [
              (".bz2", "bzip2"),
@@ -30 +38 @@
             ]
 
-types :: M.Map String String
+types :: M.Map String ContentType
 types = M.fromList [
          (".avi", "video/x-msvideo"),
@@ -122 +130 @@
 outputMyError BadRange = outputError 416 "Requested Range Not Satisfiable" []
 
-checkExtension :: FilePath -> CGI ()
-checkExtension file = do
+-- | Nothing if type is not whitelisted.
+checkExtension :: FilePath -> Maybe (Maybe Encoding, ContentType)
+checkExtension file =
   let (base, ext) = splitExtension file
-  ext' <- case M.lookup (map toLower ext) encodings of
-            Nothing -> return ext
-            Just e -> do
-              setHeader "Content-Encoding" e
-              return $ takeExtension base
-
-  case M.lookup (map toLower ext') types of
-    Nothing -> throw Forbidden
-    Just t -> setHeader "Content-Type" t
+      (file', enc) = case M.lookup (map toLower ext) encodings of
+                        Nothing -> (file, Nothing)
+                        Just e -> (base, Just e)
+      (_, ext') = splitExtension file'
+   in case M.lookup (map toLower ext') types of
+            Nothing -> Nothing
+            Just e -> Just (enc, e)
 
 checkMethod :: CGI CGIResult -> CGI CGIResult
@@ -164 +171 @@
       return $ if parseHTTPDate ir == Just mTime then Just () else Nothing
 
-parseRange :: String -> FileOffset -> Maybe (FileOffset, FileOffset)
-parseRange (splitAt 6 -> ("bytes=", '-':(readDec -> [(len, "")]))) size =
-    Just (max 0 (size - len), size - 1)
-parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, "-")])) size =
-    Just (a, size - 1)
-parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, '-':(readDec -> [(b, "")]))])) size =
-    Just (a, min (size - 1) b)
-parseRange _ _ = Nothing
-
-checkRange :: EpochTime -> FileOffset -> CGI (Maybe (FileOffset, FileOffset))
-checkRange mTime size = do
+-- | parseRanges string size returns a list of ranges, or Nothing if parse fails.
+parseRanges :: String -> FileOffset -> Maybe [(FileOffset, FileOffset)]
+parseRanges (splitAt 6 -> ("bytes=", ranges)) size =
+    mapM parseOneRange $ splitOn "," ranges
+    where parseOneRange ('-':(readDec -> [(len, "")])) =
+            Just (max 0 (size - len), size - 1)
+          parseOneRange (readDec -> [(a, "-")]) =
+            Just (a, size - 1)
+          parseOneRange (readDec -> [(a, '-':(readDec -> [(b, "")]))]) =
+            Just (a, min (size - 1) b)
+          parseOneRange _ = Nothing
+parseRanges _ _ = Nothing
+
+checkRanges :: EpochTime -> FileOffset -> CGI (Maybe [(FileOffset, FileOffset)])
+checkRanges mTime size = do
   setHeader "Accept-Ranges" "bytes"
   (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do
   (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
-    case parseRange range size of
-      Just (a, b) | a <= b -> return $ Just (a, b)
+    case parseRanges range size of
+      Just rs | all (\(a, b) -> a <= b) rs -> return $ Just rs
       Just _ -> throw BadRange
       Nothing -> return Nothing
 
-outputAll :: Handle -> FileOffset -> CGI CGIResult
-outputAll h size = do
+outputAll :: Handle -> FileOffset -> ContentType -> CGI CGIResult
+outputAll h size ctype = do
+  setHeader "Content-Type" ctype
   setHeader "Content-Length" $ show size
   outputFPS =<< liftIO (B.hGetContents h)
@@ -196 +208 @@
   return (B.append (B.take len contents) end)
 
-outputRange :: Handle -> FileOffset -> Maybe (FileOffset, FileOffset) -> CGI CGIResult
-outputRange h size Nothing = outputAll h size
-outputRange h size (Just (a, b)) = do
+outputRange :: Handle -> FileOffset -> ContentType -> Maybe [(FileOffset, FileOffset)] -> CGI CGIResult
+outputRange h size ctype Nothing = outputAll h size ctype
+outputRange h size ctype (Just [(a, b)]) = do
   let len = b - a + 1
 
   setStatus 206 "Partial Content"
+  setHeader "Content-Type" ctype
   setHeader "Content-Range" $
    "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
@@ -207 +220 @@
   liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
   outputFPS =<< liftIO (hGetClose h (fromIntegral len))
+outputRange h size ctype (Just rs) = do
+  seed <- liftIO getStdGen
+  let ints = take 16 $ unfoldr (Just . random) seed :: [Int]
+      sep  = concat $ map (flip showHex "" . (`mod` 16)) ints
+  setStatus 206 "Partial Content"
+
+  setHeader "Content-Type" $ "multipart/byteranges; boundary=" ++ sep
+  -- Need Content-Length? RFC doesn't seem to mandate it...
+  chunks <- liftIO $ sequence $ map readChunk rs
+  let parts = map (uncurry $ mkPartHeader sep) (zip rs chunks)
+      body = B.concat [ pack "\r\n"
+                      , B.concat parts
+                      , pack "--", pack sep, pack "--\r\n"
+                      ]
+  end <- liftIO $ unsafeInterleaveIO (hClose h >> return B.empty)
+  -- TODO figure out how to guarantee handle is ALWAYS closed, and NEVER before
+  -- reading is finished...
+  outputFPS (B.append body end)
+   where readChunk :: (FileOffset, FileOffset) -> IO B.ByteString
+         readChunk (a, b) = do
+            hSeek h AbsoluteSeek (fromIntegral a)
+            -- Carful here, hGetContents makes the handle unusable afterwards.
+            -- TODO Anders says use hGetSome or some other way lazy way
+            B.hGet h (fromIntegral $ b - a + 1)
+         mkPartHeader :: String -> (FileOffset, FileOffset) -> B.ByteString -> B.ByteString
+         mkPartHeader sep (a, b) chunk = B.concat [ pack "--" , pack sep
+                                                  , pack "\r\nContent-Type: ", pack ctype
+                                                  , pack "\r\nContent-Range: bytes "
+                                                  , pack $ show a, pack "-", pack $ show b
+                                                  , pack "/", pack $ show size
+                                                  , pack "\r\n\r\n", chunk, pack "\r\n"
+                                                  ]
+
 
 serveFile :: FilePath -> CGI CGIResult
 serveFile file = (`catch` outputMyError) $ do
-  checkExtension file
+  let menctype = checkExtension file
+  when (isNothing menctype) $ throw Forbidden
+  let (menc, ctype) = fromJust menctype
+  when (isJust menc) $ setHeader "Content-Encoding" (fromJust menc)
 
   checkMethod $ do
@@ -226 +275 @@
   checkModified mTime
 
-  range <- checkRange mTime size
-  outputRange h size range
+  ranges <- checkRanges mTime size
+  outputRange h size ctype ranges
 
 main :: IO ()

trunk/server/common/oursrc/scripts-static-cat/scripts-static-cat.cabal

@@ -19 +19 @@
     MonadCatchIO-mtl,
     old-locale,
+    random,
+    split,
     time,
     unix,