StaticCat.hs

   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"),
  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"),
  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"),
  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"),
  66          (".otf", "application/octet-stream"),
  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"),
  72          (".pdf", "application/pdf"),
  73          (".png", "image/png"),
  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"),
  82          (".ppt", "application/vnd.ms-powerpoint"),
  83          (".pptm", "application/vnd.ms-powerpoint.presentation.macroEnabled.12"),
  84          (".pptx", "application/vnd.openxmlformats-officedocument.presentationml.presentation"),
  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"),
  92          (".ttf", "application/octet-stream"),
  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"),
  98          (".xla", "application/vnd.ms-excel"),
  99          (".xlam", "application/vnd.ms-excel.addin.macroEnabled.12"),
 100          (".xls", "application/vnd.ms-excel"),
 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"),
 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)
 182       Just _ -> throw BadRange
 183       Nothing -> return Nothing
 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