Changeset 1900


Ignore:
Timestamp:
Jun 11, 2011, 11:20:06 PM (10 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:
2 added
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/server/common/oursrc/scripts-static-cat/StaticCat.hs

    r1877 r1900  
    77import Control.Monad.CatchIO
    88import qualified Data.ByteString.Lazy as B
     9import Data.ByteString.Lazy.Char8 (pack)
    910import Data.Char
    1011import Data.Dynamic
    1112import Data.Int
     13import Data.List (unfoldr)
     14import Data.List.Split (splitOn)
     15import Data.Maybe (fromJust, isNothing, isJust)
    1216import qualified Data.Map as M
    1317import Data.Time.Clock.POSIX
    1418import Data.Time.Format
    15 import Network.CGI
     19import Network.CGI hiding (ContentType)
    1620import Numeric
    1721import System.FilePath
     
    2226import System.Posix
    2327import System.Posix.Handle
    24 
    25 encodings :: M.Map String String
     28import System.Random
     29
     30type Encoding = String
     31type ContentType = String
     32
     33encodings :: M.Map String Encoding
    2634encodings = M.fromList [
    2735             (".bz2", "bzip2"),
     
    3038            ]
    3139
    32 types :: M.Map String String
     40types :: M.Map String ContentType
    3341types = M.fromList [
    3442         (".avi", "video/x-msvideo"),
     
    122130outputMyError BadRange = outputError 416 "Requested Range Not Satisfiable" []
    123131
    124 checkExtension :: FilePath -> CGI ()
    125 checkExtension file = do
     132-- | Nothing if type is not whitelisted.
     133checkExtension :: FilePath -> Maybe (Maybe Encoding, ContentType)
     134checkExtension file =
    126135  let (base, ext) = splitExtension file
    127   ext' <- case M.lookup (map toLower ext) encodings of
    128             Nothing -> return ext
    129             Just e -> do
    130               setHeader "Content-Encoding" e
    131               return $ takeExtension base
    132 
    133   case M.lookup (map toLower ext') types of
    134     Nothing -> throw Forbidden
    135     Just t -> setHeader "Content-Type" t
     136      (file', enc) = case M.lookup (map toLower ext) encodings of
     137                        Nothing -> (file, Nothing)
     138                        Just e -> (base, Just e)
     139      (_, ext') = splitExtension file'
     140   in case M.lookup (map toLower ext') types of
     141            Nothing -> Nothing
     142            Just e -> Just (enc, e)
    136143
    137144checkMethod :: CGI CGIResult -> CGI CGIResult
     
    164171      return $ if parseHTTPDate ir == Just mTime then Just () else Nothing
    165172
    166 parseRange :: String -> FileOffset -> Maybe (FileOffset, FileOffset)
    167 parseRange (splitAt 6 -> ("bytes=", '-':(readDec -> [(len, "")]))) size =
    168     Just (max 0 (size - len), size - 1)
    169 parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, "-")])) size =
    170     Just (a, size - 1)
    171 parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, '-':(readDec -> [(b, "")]))])) size =
    172     Just (a, min (size - 1) b)
    173 parseRange _ _ = Nothing
    174 
    175 checkRange :: EpochTime -> FileOffset -> CGI (Maybe (FileOffset, FileOffset))
    176 checkRange mTime size = do
     173-- | parseRanges string size returns a list of ranges, or Nothing if parse fails.
     174parseRanges :: String -> FileOffset -> Maybe [(FileOffset, FileOffset)]
     175parseRanges (splitAt 6 -> ("bytes=", ranges)) size =
     176    mapM parseOneRange $ splitOn "," ranges
     177    where parseOneRange ('-':(readDec -> [(len, "")])) =
     178            Just (max 0 (size - len), size - 1)
     179          parseOneRange (readDec -> [(a, "-")]) =
     180            Just (a, size - 1)
     181          parseOneRange (readDec -> [(a, '-':(readDec -> [(b, "")]))]) =
     182            Just (a, min (size - 1) b)
     183          parseOneRange _ = Nothing
     184parseRanges _ _ = Nothing
     185
     186checkRanges :: EpochTime -> FileOffset -> CGI (Maybe [(FileOffset, FileOffset)])
     187checkRanges mTime size = do
    177188  setHeader "Accept-Ranges" "bytes"
    178189  (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do
    179190  (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
    180     case parseRange range size of
    181       Just (a, b) | a <= b -> return $ Just (a, b)
     191    case parseRanges range size of
     192      Just rs | all (\(a, b) -> a <= b) rs -> return $ Just rs
    182193      Just _ -> throw BadRange
    183194      Nothing -> return Nothing
    184195
    185 outputAll :: Handle -> FileOffset -> CGI CGIResult
    186 outputAll h size = do
     196outputAll :: Handle -> FileOffset -> ContentType -> CGI CGIResult
     197outputAll h size ctype = do
     198  setHeader "Content-Type" ctype
    187199  setHeader "Content-Length" $ show size
    188200  outputFPS =<< liftIO (B.hGetContents h)
     
    196208  return (B.append (B.take len contents) end)
    197209
    198 outputRange :: Handle -> FileOffset -> Maybe (FileOffset, FileOffset) -> CGI CGIResult
    199 outputRange h size Nothing = outputAll h size
    200 outputRange h size (Just (a, b)) = do
     210outputRange :: Handle -> FileOffset -> ContentType -> Maybe [(FileOffset, FileOffset)] -> CGI CGIResult
     211outputRange h size ctype Nothing = outputAll h size ctype
     212outputRange h size ctype (Just [(a, b)]) = do
    201213  let len = b - a + 1
    202214
    203215  setStatus 206 "Partial Content"
     216  setHeader "Content-Type" ctype
    204217  setHeader "Content-Range" $
    205218   "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
     
    207220  liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
    208221  outputFPS =<< liftIO (hGetClose h (fromIntegral len))
     222outputRange h size ctype (Just rs) = do
     223  seed <- liftIO getStdGen
     224  let ints = take 16 $ unfoldr (Just . random) seed :: [Int]
     225      sep  = concat $ map (flip showHex "" . (`mod` 16)) ints
     226  setStatus 206 "Partial Content"
     227
     228  setHeader "Content-Type" $ "multipart/byteranges; boundary=" ++ sep
     229  -- Need Content-Length? RFC doesn't seem to mandate it...
     230  chunks <- liftIO $ sequence $ map readChunk rs
     231  let parts = map (uncurry $ mkPartHeader sep) (zip rs chunks)
     232      body = B.concat [ pack "\r\n"
     233                      , B.concat parts
     234                      , pack "--", pack sep, pack "--\r\n"
     235                      ]
     236  end <- liftIO $ unsafeInterleaveIO (hClose h >> return B.empty)
     237  -- TODO figure out how to guarantee handle is ALWAYS closed, and NEVER before
     238  -- reading is finished...
     239  outputFPS (B.append body end)
     240   where readChunk :: (FileOffset, FileOffset) -> IO B.ByteString
     241         readChunk (a, b) = do
     242            hSeek h AbsoluteSeek (fromIntegral a)
     243            -- Carful here, hGetContents makes the handle unusable afterwards.
     244            -- TODO Anders says use hGetSome or some other way lazy way
     245            B.hGet h (fromIntegral $ b - a + 1)
     246         mkPartHeader :: String -> (FileOffset, FileOffset) -> B.ByteString -> B.ByteString
     247         mkPartHeader sep (a, b) chunk = B.concat [ pack "--" , pack sep
     248                                                  , pack "\r\nContent-Type: ", pack ctype
     249                                                  , pack "\r\nContent-Range: bytes "
     250                                                  , pack $ show a, pack "-", pack $ show b
     251                                                  , pack "/", pack $ show size
     252                                                  , pack "\r\n\r\n", chunk, pack "\r\n"
     253                                                  ]
     254
    209255
    210256serveFile :: FilePath -> CGI CGIResult
    211257serveFile file = (`catch` outputMyError) $ do
    212   checkExtension file
     258  let menctype = checkExtension file
     259  when (isNothing menctype) $ throw Forbidden
     260  let (menc, ctype) = fromJust menctype
     261  when (isJust menc) $ setHeader "Content-Encoding" (fromJust menc)
    213262
    214263  checkMethod $ do
     
    226275  checkModified mTime
    227276
    228   range <- checkRange mTime size
    229   outputRange h size range
     277  ranges <- checkRanges mTime size
     278  outputRange h size ctype ranges
    230279
    231280main :: IO ()
  • trunk/server/common/oursrc/scripts-static-cat/scripts-static-cat.cabal

    r1590 r1900  
    1919    MonadCatchIO-mtl,
    2020    old-locale,
     21    random,
     22    split,
    2123    time,
    2224    unix,
Note: See TracChangeset for help on using the changeset viewer.