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.Dynamic
   9 import qualified Data.Map as M
  10 import Data.Time.Clock.POSIX
  11 import Data.Time.Format
  12 import Network.CGI
  13 import Numeric
  14 import System.FilePath
  15 import System.IO
  16 import System.IO.Error
  17 import System.Locale
  18 import System.Posix
  19 import System.Posix.Handle
  20
  21 encodings :: M.Map String String
  22 encodings = M.fromList [
  23              (".gz", "gzip"),
  24              (".bz2", "bzip2")
  25             ]
  26
  27 types :: M.Map String String
  28 types = M.fromList [
  29          (".html", "text/html")
  30         ]
  31
  32 throwExceptionCGI :: Exception e => e -> CGI a
  33 throwExceptionCGI = throwCGI . toException
  34
  35 catchExceptionCGI :: Exception e => CGI a -> (e -> CGI a) -> CGI a
  36 a `catchExceptionCGI` handler =
  37     a `catchCGI` \e -> case fromException e of
  38                            Nothing -> throwCGI e
  39                            Just e_ -> handler e_
  40
  41 data MyError = NotModified | Forbidden | NotFound | BadMethod | BadRange
  42     deriving (Show, Typeable)
  43
  44 instance Exception MyError
  45
  46 outputMyError :: MyError -> CGI CGIResult
  47 outputMyError NotModified = setStatus 304 "Not Modified" >> outputNothing
  48 outputMyError Forbidden = outputError 403 "Forbidden" []
  49 outputMyError NotFound = outputError 404 "Not Found" []
  50 outputMyError BadMethod = outputError 405 "Method Not Allowed" []
  51 outputMyError BadRange = outputError 416 "Requested Range Not Satisfiable" []
  52
  53 checkExtension :: FilePath -> CGI ()
  54 checkExtension file = do
  55   let (base, ext) = splitExtension file
  56   ext' <- case M.lookup ext encodings of
  57             Nothing -> return ext
  58             Just e -> do
  59               setHeader "Content-Encoding" e
  60               return $ takeExtension base
  61
  62   case M.lookup ext' types of
  63     Nothing -> throwExceptionCGI Forbidden
  64     Just t -> setHeader "Content-Type" t
  65
  66 checkMethod :: CGI CGIResult -> CGI CGIResult
  67 checkMethod rOutput = do
  68   m <- requestMethod
  69   case m of
  70     "HEAD" -> rOutput >> outputNothing
  71     "GET" -> rOutput
  72     "POST" -> rOutput
  73     _ -> throwExceptionCGI BadMethod
  74
  75 httpDate :: String
  76 httpDate = "%a, %d %b %Y %H:%M:%S %Z"
  77 formatHTTPDate :: EpochTime -> String
  78 formatHTTPDate = formatTime defaultTimeLocale httpDate .
  79                  posixSecondsToUTCTime . realToFrac
  80 parseHTTPDate :: String -> Maybe EpochTime
  81 parseHTTPDate = (fromInteger . floor . utcTimeToPOSIXSeconds <$>) .
  82                 parseTime defaultTimeLocale httpDate
  83
  84 checkModified :: EpochTime -> CGI ()
  85 checkModified mTime = do
  86   setHeader "Last-Modified" $ formatHTTPDate mTime
  87   (requestHeader "If-Modified-Since" >>=) $ maybe (return ()) $ \ims ->
  88       when (parseHTTPDate ims >= Just mTime) $ throwExceptionCGI NotModified
  89
  90 checkIfRange :: EpochTime -> CGI (Maybe ())
  91 checkIfRange mTime = do
  92   (requestHeader "If-Range" >>=) $ maybe (return $ Just ()) $ \ir ->
  93       return $ if parseHTTPDate ir == Just mTime then Just () else Nothing
  94
  95 parseRange :: String -> FileOffset -> Maybe (FileOffset, FileOffset)
  96 parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, "-")])) size =
  97     Just (a, size - 1)
  98 parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, '-':(readDec -> [(b, "")]))])) _ =
  99     Just (a, b)
 100 parseRange _ _ = Nothing
 101
 102 checkRange :: EpochTime -> FileOffset -> CGI (Maybe (FileOffset, FileOffset))
 103 checkRange mTime size = do
 104   setHeader "Accept-Ranges" "bytes"
 105   (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do
 106   (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
 107     case parseRange range size of
 108       Just (a, b) | a <= b -> return $ Just (a, b)
 109       _ -> throwExceptionCGI BadRange
 110
 111 serveFile :: FilePath -> CGI CGIResult
 112 serveFile file = (`catchExceptionCGI` outputMyError) $ do
 113   checkExtension file
 114
 115   checkMethod $ do
 116
 117   h <- (`catchExceptionCGI` \e ->
 118             if isDoesNotExistError e then throwExceptionCGI NotFound
 119             else if isPermissionError e then throwExceptionCGI Forbidden
 120             else throwExceptionCGI e) $
 121         liftIO $ openBinaryFile file ReadMode
 122   (`catchCGI` \e ->
 123        (liftIO $ hClose h) >> throwCGI e) $ do
 124
 125   status <- liftIO $ hGetStatus h
 126   let mTime = modificationTime status
 127       size = fileSize status
 128   checkModified mTime
 129
 130   checkRange mTime size >>= maybe
 131     (do
 132        setHeader "Content-Length" $ show size
 133        outputFPS =<< (liftIO $ B.hGetContents h))
 134     (\(a, b) -> do
 135        let len = b - a + 1
 136
 137        setStatus 206 "Partial Content"
 138        setHeader "Content-Range" $
 139         "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
 140        setHeader "Content-Length" $ show len
 141        liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
 142        outputFPS =<< (liftIO $ B.hGet h (fromIntegral len)))
 143
 144 main :: IO ()
 145 main = runCGI $ handleErrors $ serveFile =<< pathTranslated