Initial commit of scripts-static-cat.

diff --git a/Setup.hs b/Setup.hs
new file mode 100644 (file)
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 (file)
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 (file)
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 <andersk@mit.edu>
+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