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 -> [(len, "")]))) size =
 127     Just (max 0 (size - len), size - 1)
 128 parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, "-")])) size =
 129     Just (a, size - 1)
 130 parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, '-':(readDec -> [(b, "")]))])) size =
 131     Just (a, min (size - 1) b)
 132 parseRange _ _ = Nothing
 133
 134 checkRange :: EpochTime -> FileOffset -> CGI (Maybe (FileOffset, FileOffset))
 135 checkRange mTime size = do
 136   setHeader "Accept-Ranges" "bytes"
 137   (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do
 138   (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
 139     case parseRange range size of
 140       Just (a, b) | a <= b -> return $ Just (a, b)
 141       _ -> throw BadRange
 142
 143 outputAll :: Handle -> FileOffset -> CGI CGIResult
 144 outputAll h size = do
 145   setHeader "Content-Length" $ show size
 146   outputFPS =<< liftIO (B.hGetContents h)
 147
 148 outputRange :: Handle -> FileOffset -> Maybe (FileOffset, FileOffset) -> CGI CGIResult
 149 outputRange h size Nothing = outputAll h size
 150 outputRange h size (Just (a, b)) = do
 151   let len = b - a + 1
 152
 153   setStatus 206 "Partial Content"
 154   setHeader "Content-Range" $
 155    "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
 156   setHeader "Content-Length" $ show len
 157   liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
 158   outputFPS =<< liftIO (B.hGet h (fromIntegral len))
 159
 160 serveFile :: FilePath -> CGI CGIResult
 161 serveFile file = (`catch` outputMyError) $ do
 162   checkExtension file
 163
 164   checkMethod $ do
 165
 166   let handleOpenError e =
 167           if isDoesNotExistError e then throw NotFound
 168           else if isPermissionError e then throw Forbidden
 169           else throw e
 170   h <- liftIO (openBinaryFile file ReadMode) `catch` handleOpenError
 171   (`onException` liftIO (hClose h)) $ do
 172
 173   status <- liftIO $ hGetStatus h
 174   let mTime = modificationTime status
 175       size = fileSize status
 176   checkModified mTime
 177
 178   range <- checkRange mTime size
 179   outputRange h size range
 180
 181 main :: IO ()
 182 main = runCGI $ handleErrors $ serveFile =<< pathTranslated