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       _ -> throw BadRange
 144
 145 outputAll :: Handle -> FileOffset -> CGI CGIResult
 146 outputAll h size = do
 147   setHeader "Content-Length" $ show size
 148   outputFPS =<< liftIO (B.hGetContents h)
 149
 150 -- | Lazily read a given number of bytes from the handle into a
 151 -- 'ByteString', then close the handle.
 152 hGetClose :: Handle -> Int64 -> IO B.ByteString
 153 hGetClose h len = do
 154   contents <- B.hGetContents h
 155   end <- unsafeInterleaveIO (hClose h >> return B.empty)
 156   return (B.append (B.take len contents) end)
 157
 158 outputRange :: Handle -> FileOffset -> Maybe (FileOffset, FileOffset) -> CGI CGIResult
 159 outputRange h size Nothing = outputAll h size
 160 outputRange h size (Just (a, b)) = do
 161   let len = b - a + 1
 162
 163   setStatus 206 "Partial Content"
 164   setHeader "Content-Range" $
 165    "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
 166   setHeader "Content-Length" $ show len
 167   liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
 168   outputFPS =<< liftIO (hGetClose h (fromIntegral len))
 169
 170 serveFile :: FilePath -> CGI CGIResult
 171 serveFile file = (`catch` outputMyError) $ do
 172   checkExtension file
 173
 174   checkMethod $ do
 175
 176   let handleOpenError e =
 177           if isDoesNotExistError e then throw NotFound
 178           else if isPermissionError e then throw Forbidden
 179           else throw e
 180   h <- liftIO (openBinaryFile file ReadMode) `catch` handleOpenError
 181   (`onException` liftIO (hClose h)) $ do
 182
 183   status <- liftIO $ hGetStatus h
 184   let mTime = modificationTime status
 185       size = fileSize status
 186   checkModified mTime
 187
 188   range <- checkRange mTime size
 189   outputRange h size range
 190
 191 main :: IO ()
 192 main = runCGI $ handleErrors $ serveFile =<< pathTranslated