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