import Control.Exception
import Control.Monad
import qualified Data.ByteString.Lazy as B
+import Data.Char
import Data.Dynamic
import qualified Data.Map as M
import Data.Time.Clock.POSIX
encodings :: M.Map String String
encodings = M.fromList [
+ (".bz2", "bzip2"),
(".gz", "gzip"),
- (".bz2", "bzip2")
+ (".z", "compress")
]
types :: M.Map String String
types = M.fromList [
- (".html", "text/html")
+ (".avi", "video/x-msvideo"),
+ (".css", "text/css"),
+ (".doc", "application/msword"),
+ (".gif", "image/gif"),
+ (".htm", "text/html"),
+ (".html", "text/html"),
+ (".ico", "image/vnd.microsoft.icon"),
+ (".il", "application/octet-stream"),
+ (".jar", "application/java-archive"),
+ (".jpeg", "image/jpeg"),
+ (".jpg", "image/jpeg"),
+ (".js", "application/x-javascript"),
+ (".mid", "audio/midi"),
+ (".midi", "audio/midi"),
+ (".mov", "video/quicktime"),
+ (".mp3", "audio/mpeg"),
+ (".mpeg", "video/mpeg"),
+ (".mpg", "video/mpeg"),
+ (".pdf", "application/pdf"),
+ (".png", "image/png"),
+ (".ppt", "application/vnd.ms-powerpoint"),
+ (".ps", "application/postscript"),
+ (".svg", "image/svg+xml"),
+ (".swf", "application/x-shockwave-flash"),
+ (".tar", "application/x-tar"),
+ (".tgz", "application/x-gzip"),
+ (".tif", "image/tiff"),
+ (".tiff", "image/tiff"),
+ (".wav", "audio/x-wav"),
+ (".wmv", "video/x-ms-wmv"),
+ (".xaml", "application/xaml+xml"),
+ (".xap", "application/x-silverlight-app"),
+ (".xhtml", "application/xhtml+xml"),
+ (".xls", "application/vnd.ms-excel"),
+ (".xml", "text/xml"),
+ (".xsl", "text/xml"),
+ (".zip", "application/zip")
]
throwExceptionCGI :: Exception e => e -> CGI a
checkExtension :: FilePath -> CGI ()
checkExtension file = do
let (base, ext) = splitExtension file
- ext' <- case M.lookup ext encodings of
+ 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 ext' types of
+ case M.lookup (map toLower ext') types of
Nothing -> throwExceptionCGI Forbidden
Just t -> setHeader "Content-Type" t
Just (a, b) | a <= b -> return $ Just (a, b)
_ -> throwExceptionCGI BadRange
+outputAll :: Handle -> FileOffset -> CGI CGIResult
+outputAll h size = do
+ setHeader "Content-Length" $ show size
+ outputFPS =<< liftIO (B.hGetContents h)
+
+outputRange :: Handle -> FileOffset -> Maybe (FileOffset, FileOffset) -> CGI CGIResult
+outputRange h size Nothing = outputAll h size
+outputRange h size (Just (a, b)) = do
+ let len = b - a + 1
+
+ setStatus 206 "Partial Content"
+ setHeader "Content-Range" $
+ "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
+ setHeader "Content-Length" $ show len
+ liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
+ outputFPS =<< liftIO (B.hGet h (fromIntegral len))
+
serveFile :: FilePath -> CGI CGIResult
serveFile file = (`catchExceptionCGI` outputMyError) $ do
checkExtension file
checkMethod $ do
- h <- (`catchExceptionCGI` \e ->
- if isDoesNotExistError e then throwExceptionCGI NotFound
- else if isPermissionError e then throwExceptionCGI Forbidden
- else throwExceptionCGI e) $
- liftIO $ openBinaryFile file ReadMode
- (`catchCGI` \e ->
- (liftIO $ hClose h) >> throwCGI e) $ do
+ let handleOpenError e =
+ if isDoesNotExistError e then throwExceptionCGI NotFound
+ else if isPermissionError e then throwExceptionCGI Forbidden
+ else throwExceptionCGI e
+ h <- liftIO (openBinaryFile file ReadMode) `catchExceptionCGI` handleOpenError
+ let handlePostOpenError e = do
+ liftIO $ hClose h
+ throwCGI e
+ (`catchCGI` handlePostOpenError) $ do
status <- liftIO $ hGetStatus h
let mTime = modificationTime status
size = fileSize status
checkModified mTime
- checkRange mTime size >>= maybe
- (do
- setHeader "Content-Length" $ show size
- outputFPS =<< (liftIO $ B.hGetContents h))
- (\(a, b) -> do
- let len = b - a + 1
-
- setStatus 206 "Partial Content"
- setHeader "Content-Range" $
- "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
- setHeader "Content-Length" $ show len
- liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
- outputFPS =<< (liftIO $ B.hGet h (fromIntegral len)))
+ range <- checkRange mTime size
+ outputRange h size range
main :: IO ()
main = runCGI $ handleErrors $ serveFile =<< pathTranslated