[1590] | 1 | {-# LANGUAGE DeriveDataTypeable, ViewPatterns #-} |
---|
| 2 | {-# OPTIONS_GHC -O2 -Wall #-} |
---|
| 3 | |
---|
| 4 | import Prelude hiding (catch) |
---|
| 5 | import Control.Applicative |
---|
| 6 | import Control.Monad |
---|
| 7 | import Control.Monad.CatchIO |
---|
| 8 | import qualified Data.ByteString.Lazy as B |
---|
| 9 | import Data.Char |
---|
| 10 | import Data.Dynamic |
---|
| 11 | import Data.Int |
---|
| 12 | import qualified Data.Map as M |
---|
| 13 | import Data.Time.Clock.POSIX |
---|
| 14 | import Data.Time.Format |
---|
| 15 | import Network.CGI |
---|
| 16 | import Numeric |
---|
| 17 | import System.FilePath |
---|
| 18 | import System.IO |
---|
| 19 | import System.IO.Error (isDoesNotExistError, isPermissionError) |
---|
| 20 | import System.IO.Unsafe |
---|
| 21 | import System.Locale |
---|
| 22 | import System.Posix |
---|
| 23 | import System.Posix.Handle |
---|
| 24 | |
---|
| 25 | encodings :: M.Map String String |
---|
| 26 | encodings = M.fromList [ |
---|
| 27 | (".bz2", "bzip2"), |
---|
| 28 | (".gz", "gzip"), |
---|
| 29 | (".z", "compress") |
---|
| 30 | ] |
---|
| 31 | |
---|
| 32 | types :: M.Map String String |
---|
| 33 | types = M.fromList [ |
---|
| 34 | (".avi", "video/x-msvideo"), |
---|
| 35 | (".css", "text/css"), |
---|
| 36 | (".doc", "application/msword"), |
---|
[1878] | 37 | (".docm", "application/vnd.ms-word.document.macroEnabled.12"), |
---|
| 38 | (".docx", "application/vnd.openxmlformats-officedocument.wordprocessingml.document"), |
---|
| 39 | (".dot", "application/msword"), |
---|
| 40 | (".dotm", "application/vnd.ms-word.template.macroEnabled.12"), |
---|
| 41 | (".dotx", "application/vnd.openxmlformats-officedocument.wordprocessingml.template"), |
---|
[1590] | 42 | (".gif", "image/gif"), |
---|
| 43 | (".htm", "text/html"), |
---|
| 44 | (".html", "text/html"), |
---|
| 45 | (".ico", "image/vnd.microsoft.icon"), |
---|
| 46 | (".il", "application/octet-stream"), |
---|
| 47 | (".jar", "application/java-archive"), |
---|
| 48 | (".jpeg", "image/jpeg"), |
---|
| 49 | (".jpg", "image/jpeg"), |
---|
| 50 | (".js", "application/x-javascript"), |
---|
| 51 | (".mid", "audio/midi"), |
---|
| 52 | (".midi", "audio/midi"), |
---|
| 53 | (".mov", "video/quicktime"), |
---|
| 54 | (".mp3", "audio/mpeg"), |
---|
| 55 | (".mpeg", "video/mpeg"), |
---|
| 56 | (".mpg", "video/mpeg"), |
---|
[1878] | 57 | (".odb", "application/vnd.oasis.opendocument.database"), |
---|
| 58 | (".odc", "application/vnd.oasis.opendocument.chart"), |
---|
| 59 | (".odf", "application/vnd.oasis.opendocument.formula"), |
---|
| 60 | (".odg", "application/vnd.oasis.opendocument.graphics"), |
---|
| 61 | (".odi", "application/vnd.oasis.opendocument.image"), |
---|
| 62 | (".odm", "application/vnd.oasis.opendocument.text-master"), |
---|
| 63 | (".odp", "application/vnd.oasis.opendocument.presentation"), |
---|
| 64 | (".ods", "application/vnd.oasis.opendocument.spreadsheet"), |
---|
| 65 | (".odt", "application/vnd.oasis.opendocument.text"), |
---|
[1784] | 66 | (".otf", "application/octet-stream"), |
---|
[1878] | 67 | (".otg", "application/vnd.oasis.opendocument.graphics-template"), |
---|
| 68 | (".oth", "application/vnd.oasis.opendocument.text-web"), |
---|
| 69 | (".otp", "application/vnd.oasis.opendocument.presentation-template"), |
---|
| 70 | (".ots", "application/vnd.oasis.opendocument.spreadsheet-template"), |
---|
| 71 | (".ott", "application/vnd.oasis.opendocument.text-template"), |
---|
[1590] | 72 | (".pdf", "application/pdf"), |
---|
| 73 | (".png", "image/png"), |
---|
[1878] | 74 | (".pot", "application/vnd.ms-powerpoint"), |
---|
| 75 | (".potm", "application/vnd.ms-powerpoint.template.macroEnabled.12"), |
---|
| 76 | (".potx", "application/vnd.openxmlformats-officedocument.presentationml.template"), |
---|
| 77 | (".ppa", "application/vnd.ms-powerpoint"), |
---|
| 78 | (".ppam", "application/vnd.ms-powerpoint.addin.macroEnabled.12"), |
---|
| 79 | (".pps", "application/vnd.ms-powerpoint"), |
---|
| 80 | (".ppsm", "application/vnd.ms-powerpoint.slideshow.macroEnabled.12"), |
---|
| 81 | (".ppsx", "application/vnd.openxmlformats-officedocument.presentationml.slideshow"), |
---|
[1590] | 82 | (".ppt", "application/vnd.ms-powerpoint"), |
---|
[1878] | 83 | (".pptm", "application/vnd.ms-powerpoint.presentation.macroEnabled.12"), |
---|
| 84 | (".pptx", "application/vnd.openxmlformats-officedocument.presentationml.presentation"), |
---|
[1590] | 85 | (".ps", "application/postscript"), |
---|
| 86 | (".svg", "image/svg+xml"), |
---|
| 87 | (".swf", "application/x-shockwave-flash"), |
---|
| 88 | (".tar", "application/x-tar"), |
---|
| 89 | (".tgz", "application/x-gzip"), |
---|
| 90 | (".tif", "image/tiff"), |
---|
| 91 | (".tiff", "image/tiff"), |
---|
[1784] | 92 | (".ttf", "application/octet-stream"), |
---|
[1590] | 93 | (".wav", "audio/x-wav"), |
---|
| 94 | (".wmv", "video/x-ms-wmv"), |
---|
| 95 | (".xaml", "application/xaml+xml"), |
---|
| 96 | (".xap", "application/x-silverlight-app"), |
---|
| 97 | (".xhtml", "application/xhtml+xml"), |
---|
[1878] | 98 | (".xla", "application/vnd.ms-excel"), |
---|
| 99 | (".xlam", "application/vnd.ms-excel.addin.macroEnabled.12"), |
---|
[1590] | 100 | (".xls", "application/vnd.ms-excel"), |
---|
[1878] | 101 | (".xlsb", "application/vnd.ms-excel.sheet.binary.macroEnabled.12"), |
---|
| 102 | (".xlsm", "application/vnd.ms-excel.sheet.macroEnabled.12"), |
---|
| 103 | (".xlsx", "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"), |
---|
| 104 | (".xlt", "application/vnd.ms-excel"), |
---|
| 105 | (".xltm", "application/vnd.ms-excel.template.macroEnabled.12"), |
---|
| 106 | (".xltx", "application/vnd.openxmlformats-officedocument.spreadsheetml.template"), |
---|
[1590] | 107 | (".xml", "text/xml"), |
---|
| 108 | (".xsl", "text/xml"), |
---|
| 109 | (".zip", "application/zip") |
---|
| 110 | ] |
---|
| 111 | |
---|
| 112 | data MyError = NotModified | Forbidden | NotFound | BadMethod | BadRange |
---|
| 113 | deriving (Show, Typeable) |
---|
| 114 | |
---|
| 115 | instance Exception MyError |
---|
| 116 | |
---|
| 117 | outputMyError :: MyError -> CGI CGIResult |
---|
| 118 | outputMyError NotModified = setStatus 304 "Not Modified" >> outputNothing |
---|
| 119 | outputMyError Forbidden = outputError 403 "Forbidden" [] |
---|
| 120 | outputMyError NotFound = outputError 404 "Not Found" [] |
---|
| 121 | outputMyError BadMethod = outputError 405 "Method Not Allowed" [] |
---|
| 122 | outputMyError BadRange = outputError 416 "Requested Range Not Satisfiable" [] |
---|
| 123 | |
---|
| 124 | checkExtension :: FilePath -> CGI () |
---|
| 125 | checkExtension file = do |
---|
| 126 | 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 | |
---|
| 137 | checkMethod :: CGI CGIResult -> CGI CGIResult |
---|
| 138 | checkMethod rOutput = do |
---|
| 139 | m <- requestMethod |
---|
| 140 | case m of |
---|
| 141 | "HEAD" -> rOutput >> outputNothing |
---|
| 142 | "GET" -> rOutput |
---|
| 143 | "POST" -> rOutput |
---|
| 144 | _ -> throw BadMethod |
---|
| 145 | |
---|
| 146 | httpDate :: String |
---|
| 147 | httpDate = "%a, %d %b %Y %H:%M:%S %Z" |
---|
| 148 | formatHTTPDate :: EpochTime -> String |
---|
| 149 | formatHTTPDate = formatTime defaultTimeLocale httpDate . |
---|
| 150 | posixSecondsToUTCTime . realToFrac |
---|
| 151 | parseHTTPDate :: String -> Maybe EpochTime |
---|
| 152 | parseHTTPDate = (fromInteger . floor . utcTimeToPOSIXSeconds <$>) . |
---|
| 153 | parseTime defaultTimeLocale httpDate |
---|
| 154 | |
---|
| 155 | checkModified :: EpochTime -> CGI () |
---|
| 156 | checkModified mTime = do |
---|
| 157 | setHeader "Last-Modified" $ formatHTTPDate mTime |
---|
| 158 | (requestHeader "If-Modified-Since" >>=) $ maybe (return ()) $ \ims -> |
---|
| 159 | when (parseHTTPDate ims >= Just mTime) $ throw NotModified |
---|
| 160 | |
---|
| 161 | checkIfRange :: EpochTime -> CGI (Maybe ()) |
---|
| 162 | checkIfRange mTime = do |
---|
| 163 | (requestHeader "If-Range" >>=) $ maybe (return $ Just ()) $ \ir -> |
---|
| 164 | return $ if parseHTTPDate ir == Just mTime then Just () else Nothing |
---|
| 165 | |
---|
| 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 |
---|
| 177 | setHeader "Accept-Ranges" "bytes" |
---|
| 178 | (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do |
---|
| 179 | (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do |
---|
| 180 | case parseRange range size of |
---|
| 181 | Just (a, b) | a <= b -> return $ Just (a, b) |
---|
[1592] | 182 | Just _ -> throw BadRange |
---|
| 183 | Nothing -> return Nothing |
---|
[1590] | 184 | |
---|
| 185 | outputAll :: Handle -> FileOffset -> CGI CGIResult |
---|
| 186 | outputAll h size = do |
---|
| 187 | setHeader "Content-Length" $ show size |
---|
| 188 | outputFPS =<< liftIO (B.hGetContents h) |
---|
| 189 | |
---|
| 190 | -- | Lazily read a given number of bytes from the handle into a |
---|
| 191 | -- 'ByteString', then close the handle. |
---|
| 192 | hGetClose :: Handle -> Int64 -> IO B.ByteString |
---|
| 193 | hGetClose h len = do |
---|
| 194 | contents <- B.hGetContents h |
---|
| 195 | end <- unsafeInterleaveIO (hClose h >> return B.empty) |
---|
| 196 | return (B.append (B.take len contents) end) |
---|
| 197 | |
---|
| 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 |
---|
| 201 | let len = b - a + 1 |
---|
| 202 | |
---|
| 203 | setStatus 206 "Partial Content" |
---|
| 204 | setHeader "Content-Range" $ |
---|
| 205 | "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size |
---|
| 206 | setHeader "Content-Length" $ show len |
---|
| 207 | liftIO $ hSeek h AbsoluteSeek (fromIntegral a) |
---|
| 208 | outputFPS =<< liftIO (hGetClose h (fromIntegral len)) |
---|
| 209 | |
---|
| 210 | serveFile :: FilePath -> CGI CGIResult |
---|
| 211 | serveFile file = (`catch` outputMyError) $ do |
---|
| 212 | checkExtension file |
---|
| 213 | |
---|
| 214 | checkMethod $ do |
---|
| 215 | |
---|
| 216 | let handleOpenError e = |
---|
| 217 | if isDoesNotExistError e then throw NotFound |
---|
| 218 | else if isPermissionError e then throw Forbidden |
---|
| 219 | else throw e |
---|
| 220 | h <- liftIO (openBinaryFile file ReadMode) `catch` handleOpenError |
---|
| 221 | (`onException` liftIO (hClose h)) $ do |
---|
| 222 | |
---|
| 223 | status <- liftIO $ hGetStatus h |
---|
| 224 | let mTime = modificationTime status |
---|
| 225 | size = fileSize status |
---|
| 226 | checkModified mTime |
---|
| 227 | |
---|
| 228 | range <- checkRange mTime size |
---|
| 229 | outputRange h size range |
---|
| 230 | |
---|
| 231 | main :: IO () |
---|
| 232 | main = runCGI $ handleErrors $ serveFile =<< pathTranslated |
---|