Initial commit of scripts-static-cat.

[scripts-static-cat.git] / StaticCat.hs

{-# LANGUAGE DeriveDataTypeable, ViewPatterns #-}
{-# OPTIONS_GHC -O2 -Wall #-}

import Control.Applicative
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Lazy as B
import Data.Dynamic
import qualified Data.Map as M
import Data.Time.Clock.POSIX
import Data.Time.Format
import Network.CGI
import Numeric
import System.FilePath
import System.IO
import System.IO.Error
import System.Locale
import System.Posix
import System.Posix.Handle

encodings :: M.Map String String
encodings = M.fromList [
             (".gz", "gzip"),
             (".bz2", "bzip2")
            ]

types :: M.Map String String
types = M.fromList [
         (".html", "text/html")
        ]

throwExceptionCGI :: Exception e => e -> CGI a
throwExceptionCGI = throwCGI . toException

catchExceptionCGI :: Exception e => CGI a -> (e -> CGI a) -> CGI a
a `catchExceptionCGI` handler =
    a `catchCGI` \e -> case fromException e of
                           Nothing -> throwCGI e
                           Just e_ -> handler e_

data MyError = NotModified | Forbidden | NotFound | BadMethod | BadRange
    deriving (Show, Typeable)

instance Exception MyError

outputMyError :: MyError -> CGI CGIResult
outputMyError NotModified = setStatus 304 "Not Modified" >> outputNothing
outputMyError Forbidden = outputError 403 "Forbidden" []
outputMyError NotFound = outputError 404 "Not Found" []
outputMyError BadMethod = outputError 405 "Method Not Allowed" []
outputMyError BadRange = outputError 416 "Requested Range Not Satisfiable" []

checkExtension :: FilePath -> CGI ()
checkExtension file = do
  let (base, ext) = splitExtension file
  ext' <- case M.lookup ext encodings of
            Nothing -> return ext
            Just e -> do
              setHeader "Content-Encoding" e
              return $ takeExtension base

  case M.lookup ext' types of
    Nothing -> throwExceptionCGI Forbidden
    Just t -> setHeader "Content-Type" t

checkMethod :: CGI CGIResult -> CGI CGIResult
checkMethod rOutput = do
  m <- requestMethod
  case m of
    "HEAD" -> rOutput >> outputNothing
    "GET" -> rOutput
    "POST" -> rOutput
    _ -> throwExceptionCGI BadMethod

httpDate :: String
httpDate = "%a, %d %b %Y %H:%M:%S %Z"
formatHTTPDate :: EpochTime -> String
formatHTTPDate = formatTime defaultTimeLocale httpDate .
                 posixSecondsToUTCTime . realToFrac
parseHTTPDate :: String -> Maybe EpochTime
parseHTTPDate = (fromInteger . floor . utcTimeToPOSIXSeconds <$>) .
                parseTime defaultTimeLocale httpDate

checkModified :: EpochTime -> CGI ()
checkModified mTime = do
  setHeader "Last-Modified" $ formatHTTPDate mTime
  (requestHeader "If-Modified-Since" >>=) $ maybe (return ()) $ \ims ->
      when (parseHTTPDate ims >= Just mTime) $ throwExceptionCGI NotModified

checkIfRange :: EpochTime -> CGI (Maybe ())
checkIfRange mTime = do
  (requestHeader "If-Range" >>=) $ maybe (return $ Just ()) $ \ir ->
      return $ if parseHTTPDate ir == Just mTime then Just () else Nothing

parseRange :: String -> FileOffset -> Maybe (FileOffset, FileOffset)
parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, "-")])) size =
    Just (a, size - 1)
parseRange (splitAt 6 -> ("bytes=", readDec -> [(a, '-':(readDec -> [(b, "")]))])) _ =
    Just (a, b)
parseRange _ _ = Nothing

checkRange :: EpochTime -> FileOffset -> CGI (Maybe (FileOffset, FileOffset))
checkRange mTime size = do
  setHeader "Accept-Ranges" "bytes"
  (requestHeader "Range" >>=) $ maybe (return Nothing) $ \range -> do
  (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
    case parseRange range size of
      Just (a, b) | a <= b -> return $ Just (a, b)
      _ -> throwExceptionCGI BadRange

serveFile :: FilePath -> CGI CGIResult
serveFile file = (`catchExceptionCGI` outputMyError) $ do
  checkExtension file

  checkMethod $ do

  h <- (`catchExceptionCGI` \e ->
            if isDoesNotExistError e then throwExceptionCGI NotFound
            else if isPermissionError e then throwExceptionCGI Forbidden
            else throwExceptionCGI e) $
        liftIO $ openBinaryFile file ReadMode
  (`catchCGI` \e ->
       (liftIO $ hClose h) >> throwCGI e) $ do

  status <- liftIO $ hGetStatus h
  let mTime = modificationTime status
      size = fileSize status
  checkModified mTime

  checkRange mTime size >>= maybe
    (do
       setHeader "Content-Length" $ show size
       outputFPS =<< (liftIO $ B.hGetContents h))
    (\(a, b) -> do
       let len = b - a + 1

       setStatus 206 "Partial Content"
       setHeader "Content-Range" $
        "bytes " ++ show a ++ "-" ++ show b ++ "/" ++ show size
       setHeader "Content-Length" $ show len
       liftIO $ hSeek h AbsoluteSeek (fromIntegral a)
       outputFPS =<< (liftIO $ B.hGet h (fromIntegral len)))

main :: IO ()
main = runCGI $ handleErrors $ serveFile =<< pathTranslated