- Timestamp:
- Jul 16, 2011, 8:10:46 PM (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/server/common/oursrc/scripts-static-cat/StaticCat.hs
r1900 r1931 7 7 import Control.Monad.CatchIO 8 8 import qualified Data.ByteString.Lazy as B 9 import Data.ByteString.Lazy.Char8 (pack)10 9 import Data.Char 11 10 import Data.Dynamic 12 11 import Data.Int 13 import Data.List (unfoldr)14 import Data.List.Split (splitOn)15 import Data.Maybe (fromJust, isNothing, isJust)16 12 import qualified Data.Map as M 17 13 import Data.Time.Clock.POSIX 18 14 import Data.Time.Format 19 import Network.CGI hiding (ContentType)15 import Network.CGI 20 16 import Numeric 21 17 import System.FilePath … … 26 22 import System.Posix 27 23 import System.Posix.Handle 28 import System.Random 29 30 type Encoding = String 31 type ContentType = String 32 33 encodings :: M.Map String Encoding 24 25 encodings :: M.Map String String 34 26 encodings = M.fromList [ 35 27 (".bz2", "bzip2"), … … 38 30 ] 39 31 40 types :: M.Map String ContentType32 types :: M.Map String String 41 33 types = M.fromList [ 42 34 (".avi", "video/x-msvideo"), … … 130 122 outputMyError BadRange = outputError 416 "Requested Range Not Satisfiable" [] 131 123 132 -- | Nothing if type is not whitelisted. 133 checkExtension :: FilePath -> Maybe (Maybe Encoding, ContentType) 134 checkExtension file = 124 checkExtension :: FilePath -> CGI () 125 checkExtension file = do 135 126 let (base, ext) = splitExtension file 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) 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 143 136 144 137 checkMethod :: CGI CGIResult -> CGI CGIResult … … 171 164 return $ if parseHTTPDate ir == Just mTime then Just () else Nothing 172 165 173 -- | parseRanges string size returns a list of ranges, or Nothing if parse fails. 174 parseRanges :: String -> FileOffset -> Maybe [(FileOffset, FileOffset)] 175 parseRanges (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 184 parseRanges _ _ = Nothing 185 186 checkRanges :: EpochTime -> FileOffset -> CGI (Maybe [(FileOffset, FileOffset)]) 187 checkRanges mTime size = do 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 188 177 setHeader "Accept-Ranges" "bytes" 189 178 (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do 190 179 (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do 191 case parseRange srange size of192 Just rs | all (\(a, b) -> a <= b) rs -> return $ Just rs180 case parseRange range size of 181 Just (a, b) | a <= b -> return $ Just (a, b) 193 182 Just _ -> throw BadRange 194 183 Nothing -> return Nothing 195 184 196 outputAll :: Handle -> FileOffset -> ContentType -> CGI CGIResult 197 outputAll h size ctype = do 198 setHeader "Content-Type" ctype 185 outputAll :: Handle -> FileOffset -> CGI CGIResult 186 outputAll h size = do 199 187 setHeader "Content-Length" $ show size 200 188 outputFPS =<< liftIO (B.hGetContents h) … … 208 196 return (B.append (B.take len contents) end) 209 197 210 outputRange :: Handle -> FileOffset -> ContentType -> Maybe [(FileOffset, FileOffset)]-> CGI CGIResult211 outputRange h size ctype Nothing = outputAll h size ctype212 outputRange h size ctype (Just [(a, b)]) = do198 outputRange :: Handle -> FileOffset -> Maybe (FileOffset, FileOffset) -> CGI CGIResult 199 outputRange h size Nothing = outputAll h size 200 outputRange h size (Just (a, b)) = do 213 201 let len = b - a + 1 214 202 215 203 setStatus 206 "Partial Content" 216 setHeader "Content-Type" ctype217 204 setHeader "Content-Range" $ 218 205 "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size … … 220 207 liftIO $ hSeek h AbsoluteSeek (fromIntegral a) 221 208 outputFPS =<< liftIO (hGetClose h (fromIntegral len)) 222 outputRange h size ctype (Just rs) = do223 seed <- liftIO getStdGen224 let ints = take 16 $ unfoldr (Just . random) seed :: [Int]225 sep = concat $ map (flip showHex "" . (`mod` 16)) ints226 setStatus 206 "Partial Content"227 228 setHeader "Content-Type" $ "multipart/byteranges; boundary=" ++ sep229 -- Need Content-Length? RFC doesn't seem to mandate it...230 chunks <- liftIO $ sequence $ map readChunk rs231 let parts = map (uncurry $ mkPartHeader sep) (zip rs chunks)232 body = B.concat [ pack "\r\n"233 , B.concat parts234 , 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 before238 -- reading is finished...239 outputFPS (B.append body end)240 where readChunk :: (FileOffset, FileOffset) -> IO B.ByteString241 readChunk (a, b) = do242 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 way245 B.hGet h (fromIntegral $ b - a + 1)246 mkPartHeader :: String -> (FileOffset, FileOffset) -> B.ByteString -> B.ByteString247 mkPartHeader sep (a, b) chunk = B.concat [ pack "--" , pack sep248 , pack "\r\nContent-Type: ", pack ctype249 , pack "\r\nContent-Range: bytes "250 , pack $ show a, pack "-", pack $ show b251 , pack "/", pack $ show size252 , pack "\r\n\r\n", chunk, pack "\r\n"253 ]254 255 209 256 210 serveFile :: FilePath -> CGI CGIResult 257 211 serveFile file = (`catch` outputMyError) $ do 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) 212 checkExtension file 262 213 263 214 checkMethod $ do … … 275 226 checkModified mTime 276 227 277 range s <- checkRangesmTime size278 outputRange h size ctype ranges228 range <- checkRange mTime size 229 outputRange h size range 279 230 280 231 main :: IO ()
Note: See TracChangeset
for help on using the changeset viewer.