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 qualified Data.Map as M
  12 import Data.Time.Clock.POSIX
  13 import Data.Time.Format
  14 import Network.CGI
  15 import Numeric
  16 import System.FilePath
  17 import System.IO
  18 import System.IO.Error (isDoesNotExistError, isPermissionError)
  19 import System.Locale
  20 import System.Posix
  21 import System.Posix.Handle
  22
  23 encodings :: M.Map String String
  24 encodings = M.fromList [
  25              (".bz2", "bzip2"),
  26              (".gz", "gzip"),
  27              (".z", "compress")
  28             ]
  29
  30 types :: M.Map String String
  31 types = M.fromList [
  32          (".avi", "video/x-msvideo"),
  33          (".css", "text/css"),
  34          (".doc", "application/msword"),
  35          (".gif", "image/gif"),
  36          (".htm", "text/html"),
  37          (".html", "text/html"),
  38          (".ico", "image/vnd.microsoft.icon"),
  39          (".il", "application/octet-stream"),
  40          (".jar", "application/java-archive"),
  41          (".jpeg", "image/jpeg"),
  42          (".jpg", "image/jpeg"),
  43          (".js", "application/x-javascript"),
  44          (".mid", "audio/midi"),
  45          (".midi", "audio/midi"),
  46          (".mov", "video/quicktime"),
  47          (".mp3", "audio/mpeg"),
  48          (".mpeg", "video/mpeg"),
  49          (".mpg", "video/mpeg"),
  50          (".pdf", "application/pdf"),
  51          (".png", "image/png"),
  52          (".ppt", "application/vnd.ms-powerpoint"),
  53          (".ps", "application/postscript"),
  54          (".svg", "image/svg+xml"),
  55          (".swf", "application/x-shockwave-flash"),
  56          (".tar", "application/x-tar"),
  57          (".tgz", "application/x-gzip"),
  58          (".tif", "image/tiff"),
  59          (".tiff", "image/tiff"),
  60          (".wav", "audio/x-wav"),
  61          (".wmv", "video/x-ms-wmv"),
  62          (".xaml", "application/xaml+xml"),
  63          (".xap", "application/x-silverlight-app"),
  64          (".xhtml", "application/xhtml+xml"),
  65          (".xls", "application/vnd.ms-excel"),
  66          (".xml", "text/xml"),
  67          (".xsl", "text/xml"),
  68          (".zip", "application/zip")
  69         ]
  70
  71 data MyError = NotModified | Forbidden | NotFound | BadMethod | BadRange
  72     deriving (Show, Typeable)
  73
  74 instance Exception MyError
  75
  76 outputMyError :: MyError -> CGI CGIResult
  77 outputMyError NotModified = setStatus 304 "Not Modified" >> outputNothing
  78 outputMyError Forbidden = outputError 403 "Forbidden" []
  79 outputMyError NotFound = outputError 404 "Not Found" []
  80 outputMyError BadMethod = outputError 405 "Method Not Allowed" []
  81 outputMyError BadRange = outputError 416 "Requested Range Not Satisfiable" []
  82
  83 checkExtension :: FilePath -> CGI ()
  84 checkExtension file = do
  85   let (base, ext) = splitExtension file
  86   ext' <- case M.lookup (map toLower ext) encodings of
  87             Nothing -> return ext
  88             Just e -> do
  89               setHeader "Content-Encoding" e
  90               return $ takeExtension base
  91
  92   case M.lookup (map toLower ext') types of
  93     Nothing -> throw Forbidden
  94     Just t -> setHeader "Content-Type" t
  95
  96 checkMethod :: CGI CGIResult -> CGI CGIResult
  97 checkMethod rOutput = do
  98   m <- requestMethod
  99   case m of
 100     "HEAD" -> rOutput >> outputNothing
 101     "GET" -> rOutput
 102     "POST" -> rOutput
 103     _ -> throw BadMethod
 104
 105 httpDate :: String
 106 httpDate = "%a, %d %b %Y %H:%M:%S %Z"
 107 formatHTTPDate :: EpochTime -> String
 108 formatHTTPDate = formatTime defaultTimeLocale httpDate .
 109                  posixSecondsToUTCTime . realToFrac
 110 parseHTTPDate :: String -> Maybe EpochTime
 111 parseHTTPDate = (fromInteger . floor . utcTimeToPOSIXSeconds <$>) .
 112                 parseTime defaultTimeLocale httpDate
 113
 114 checkModified :: EpochTime -> CGI ()
 115 checkModified mTime = do
 116   setHeader "Last-Modified" $ formatHTTPDate mTime
 117   (requestHeader "If-Modified-Since" >>=) $ maybe (return ()) $ \ims ->
 118       when (parseHTTPDate ims >= Just mTime) $ throw NotModified
 119
 120 checkIfRange :: EpochTime -> CGI (Maybe ())
 121 checkIfRange mTime = do
 122   (requestHeader "If-Range" >>=) $ maybe (return $ Just ()) $ \ir ->
 123       return $ if parseHTTPDate ir == Just mTime then Just () else Nothing
 124
 125 parseRange :: String -> FileOffset -> Maybe (FileOffset, FileOffset)
 126 parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, "-")])) size =
 127     Just (a, size - 1)
 128 parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, '-':(readDec -> [(b, "")]))])) _ =
 129     Just (a, b)
 130 parseRange _ _ = Nothing
 131
 132 checkRange :: EpochTime -> FileOffset -> CGI (Maybe (FileOffset, FileOffset))
 133 checkRange mTime size = do
 134   setHeader "Accept-Ranges" "bytes"
 135   (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do
 136   (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
 137     case parseRange range size of
 138       Just (a, b) | a <= b -> return $ Just (a, b)
 139       _ -> throw BadRange
 140
 141 outputAll :: Handle -> FileOffset -> CGI CGIResult
 142 outputAll h size = do
 143   setHeader "Content-Length" $ show size
 144   outputFPS =<< liftIO (B.hGetContents h)
 145
 146 outputRange :: Handle -> FileOffset -> Maybe (FileOffset, FileOffset) -> CGI CGIResult
 147 outputRange h size Nothing = outputAll h size
 148 outputRange h size (Just (a, b)) = do
 149   let len = b - a + 1
 150
 151   setStatus 206 "Partial Content"
 152   setHeader "Content-Range" $
 153    "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
 154   setHeader "Content-Length" $ show len
 155   liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
 156   outputFPS =<< liftIO (B.hGet h (fromIntegral len))
 157
 158 serveFile :: FilePath -> CGI CGIResult
 159 serveFile file = (`catch` outputMyError) $ do
 160   checkExtension file
 161
 162   checkMethod $ do
 163
 164   let handleOpenError e =
 165           if isDoesNotExistError e then throw NotFound
 166           else if isPermissionError e then throw Forbidden
 167           else throw e
 168   h <- liftIO (openBinaryFile file ReadMode) `catch` handleOpenError
 169   (`onException` liftIO (hClose h)) $ do
 170
 171   status <- liftIO $ hGetStatus h
 172   let mTime = modificationTime status
 173       size = fileSize status
 174   checkModified mTime
 175
 176   range <- checkRange mTime size
 177   outputRange h size range
 178
 179 main :: IO ()
 180 main = runCGI $ handleErrors $ serveFile =<< pathTranslated