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