From 59962b4ac6b131aec2940ccfa1fa0735f7a0445d Mon Sep 17 00:00:00 2001 From: Anders Kaseorg Date: Tue, 23 Feb 2010 00:51:39 -0500 Subject: [PATCH] Initial commit of scripts-static-cat. --- Setup.hs | 2 + StaticCat.hs | 145 +++++++++++++++++++++++++++++++++++++++ scripts-static-cat.cabal | 22 ++++++ 3 files changed, 169 insertions(+) create mode 100644 Setup.hs create mode 100644 StaticCat.hs create mode 100644 scripts-static-cat.cabal diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/StaticCat.hs b/StaticCat.hs new file mode 100644 index 0000000..f7e4ad8 --- /dev/null +++ b/StaticCat.hs @@ -0,0 +1,145 @@ +{-# 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 diff --git a/scripts-static-cat.cabal b/scripts-static-cat.cabal new file mode 100644 index 0000000..91b3403 --- /dev/null +++ b/scripts-static-cat.cabal @@ -0,0 +1,22 @@ +Name: scripts-static-cat +Version: 0.0 +Cabal-Version: >= 1.2 +Build-Type: Simple +License: GPL +Copyright: © 2010, Anders Kaseorg +Author: Anders Kaseorg +Maintainer: scripts@mit.edu + +Executable static-cat + Main-Is: StaticCat.hs + GHC-Options: -Wall -O2 + Build-Depends: + base >= 4, + bytestring, + cgi, + containers, + filepath, + old-locale, + time, + unix, + unix-handle -- 2.45.0