X-Git-Url: http://andersk.mit.edu/gitweb/scripts-static-cat.git/blobdiff_plain/1cb5cdb0bfd14a87fbf96171f25279aeede77c99..374d09ff4081ea5bbbf70f412ea7c0b037b779e9:/StaticCat.hs

diff --git a/StaticCat.hs b/StaticCat.hs
index 25be388..b5d03fc 100644
--- a/StaticCat.hs
+++ b/StaticCat.hs
@@ -1,10 +1,12 @@
 {-# LANGUAGE DeriveDataTypeable, ViewPatterns #-}
 {-# OPTIONS_GHC -O2 -Wall #-}
 
+import Prelude hiding (catch)
 import Control.Applicative
-import Control.Exception
 import Control.Monad
+import Control.Monad.CatchIO
 import qualified Data.ByteString.Lazy as B
+import Data.Char
 import Data.Dynamic
 import qualified Data.Map as M
 import Data.Time.Clock.POSIX
@@ -13,31 +15,59 @@ import Network.CGI
 import Numeric
 import System.FilePath
 import System.IO
-import System.IO.Error
+import System.IO.Error (isDoesNotExistError, isPermissionError)
 import System.Locale
 import System.Posix
 import System.Posix.Handle
 
 encodings :: M.Map String String
 encodings = M.fromList [
+             (".bz2", "bzip2"),
              (".gz", "gzip"),
-             (".bz2", "bzip2")
+             (".z", "compress")
             ]
 
 types :: M.Map String String
 types = M.fromList [
-         (".html", "text/html")
+         (".avi", "video/x-msvideo"),
+         (".css", "text/css"),
+         (".doc", "application/msword"),
+         (".gif", "image/gif"),
+         (".htm", "text/html"),
+         (".html", "text/html"),
+         (".ico", "image/vnd.microsoft.icon"),
+         (".il", "application/octet-stream"),
+         (".jar", "application/java-archive"),
+         (".jpeg", "image/jpeg"),
+         (".jpg", "image/jpeg"),
+         (".js", "application/x-javascript"),
+         (".mid", "audio/midi"),
+         (".midi", "audio/midi"),
+         (".mov", "video/quicktime"),
+         (".mp3", "audio/mpeg"),
+         (".mpeg", "video/mpeg"),
+         (".mpg", "video/mpeg"),
+         (".pdf", "application/pdf"),
+         (".png", "image/png"),
+         (".ppt", "application/vnd.ms-powerpoint"),
+         (".ps", "application/postscript"),
+         (".svg", "image/svg+xml"),
+         (".swf", "application/x-shockwave-flash"),
+         (".tar", "application/x-tar"),
+         (".tgz", "application/x-gzip"),
+         (".tif", "image/tiff"),
+         (".tiff", "image/tiff"),
+         (".wav", "audio/x-wav"),
+         (".wmv", "video/x-ms-wmv"),
+         (".xaml", "application/xaml+xml"),
+         (".xap", "application/x-silverlight-app"),
+         (".xhtml", "application/xhtml+xml"),
+         (".xls", "application/vnd.ms-excel"),
+         (".xml", "text/xml"),
+         (".xsl", "text/xml"),
+         (".zip", "application/zip")
         ]
 
-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)
 
@@ -53,14 +83,14 @@ 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
+  ext' <- case M.lookup (map toLower 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
+  case M.lookup (map toLower ext') types of
+    Nothing -> throw Forbidden
     Just t -> setHeader "Content-Type" t
 
 checkMethod :: CGI CGIResult -> CGI CGIResult
@@ -70,7 +100,7 @@ checkMethod rOutput = do
     "HEAD" -> rOutput >> outputNothing
     "GET" -> rOutput
     "POST" -> rOutput
-    _ -> throwExceptionCGI BadMethod
+    _ -> throw BadMethod
 
 httpDate :: String
 httpDate = "%a, %d %b %Y %H:%M:%S %Z"
@@ -85,7 +115,7 @@ 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
+      when (parseHTTPDate ims >= Just mTime) $ throw NotModified
 
 checkIfRange :: EpochTime -> CGI (Maybe ())
 checkIfRange mTime = do
@@ -95,8 +125,8 @@ checkIfRange mTime = do
 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 (splitAt 6 -> ("bytes=", readDec -> [(a, '-':(readDec -> [(b, "")]))])) size =
+    Just (a, min (size - 1) b)
 parseRange _ _ = Nothing
 
 checkRange :: EpochTime -> FileOffset -> CGI (Maybe (FileOffset, FileOffset))
@@ -106,7 +136,7 @@ checkRange mTime size = do
   (checkIfRange mTime >>=) $ maybe (return Nothing) $ \() -> do
     case parseRange range size of
       Just (a, b) | a <= b -> return $ Just (a, b)
-      _ -> throwExceptionCGI BadRange
+      _ -> throw BadRange
 
 outputAll :: Handle -> FileOffset -> CGI CGIResult
 outputAll h size = do
@@ -126,18 +156,17 @@ outputRange h size (Just (a, b)) = do
   outputFPS =<< liftIO (B.hGet h (fromIntegral len))
 
 serveFile :: FilePath -> CGI CGIResult
-serveFile file = (`catchExceptionCGI` outputMyError) $ do
+serveFile file = (`catch` 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
+  let handleOpenError e =
+          if isDoesNotExistError e then throw NotFound
+          else if isPermissionError e then throw Forbidden
+          else throw e
+  h <- liftIO (openBinaryFile file ReadMode) `catch` handleOpenError
+  (`onException` liftIO (hClose h)) $ do
 
   status <- liftIO $ hGetStatus h
   let mTime = modificationTime status