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