StaticCat.hs

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