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 outputAll :: Handle -> FileOffset -> CGI CGIResult
 112 outputAll h size = do
 113   setHeader "Content-Length" $ show size
 114   outputFPS =<< liftIO (B.hGetContents h)
 115
 116 outputRange :: Handle -> FileOffset -> Maybe (FileOffset, FileOffset) -> CGI CGIResult
 117 outputRange h size Nothing = outputAll h size
 118 outputRange h size (Just (a, b)) = do
 119   let len = b - a + 1
 120
 121   setStatus 206 "Partial Content"
 122   setHeader "Content-Range" $
 123    "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
 124   setHeader "Content-Length" $ show len
 125   liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
 126   outputFPS =<< liftIO (B.hGet h (fromIntegral len))
 127
 128 serveFile :: FilePath -> CGI CGIResult
 129 serveFile file = (`catchExceptionCGI` outputMyError) $ do
 130   checkExtension file
 131
 132   checkMethod $ do
 133
 134   let handleOpenError e =
 135           if isDoesNotExistError e then throwExceptionCGI NotFound
 136           else if isPermissionError e then throwExceptionCGI Forbidden
 137           else throwExceptionCGI e
 138   h <- liftIO (openBinaryFile file ReadMode) `catchExceptionCGI` handleOpenError
 139   let handlePostOpenError e = do
 140         liftIO $ hClose h
 141         throwCGI e
 142   (`catchCGI` handlePostOpenError) $ do
 143
 144   status <- liftIO $ hGetStatus h
 145   let mTime = modificationTime status
 146       size = fileSize status
 147   checkModified mTime
 148
 149   range <- checkRange mTime size
 150   outputRange h size range
 151
 152 main :: IO ()
 153 main = runCGI $ handleErrors $ serveFile =<< pathTranslated