Simplify exception handling using MonadCatchIO.

Signed-off-by: Anders Kaseorg <andersk@mit.edu>

diff --git a/StaticCat.hs b/StaticCat.hs
index baa509419ef70543f055a141dcc696f61444bb5a..9f8881c0e28f1c786a85890c1be6c35860a3734b 100644 (file)
--- a/StaticCat.hs
+++ b/StaticCat.hs
@@ -1,9 +1,10 @@
 {-# 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
@@ -14,7 +15,7 @@ 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
@@ -67,15 +68,6 @@ types = M.fromList [
          (".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)
 
@@ -98,7 +90,7 @@ checkExtension file = do
               return $ takeExtension base
 
   case M.lookup (map toLower ext') types of
-    Nothing -> throwExceptionCGI Forbidden
+    Nothing -> throw Forbidden
     Just t -> setHeader "Content-Type" t
 
 checkMethod :: CGI CGIResult -> CGI CGIResult
@@ -108,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"
@@ -123,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
@@ -144,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
@@ -164,20 +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
 
   let handleOpenError e =
-          if isDoesNotExistError e then throwExceptionCGI NotFound
-          else if isPermissionError e then throwExceptionCGI Forbidden
-          else throwExceptionCGI e
-  h <- liftIO (openBinaryFile file ReadMode) `catchExceptionCGI` handleOpenError
-  let handlePostOpenError e = do
-        liftIO $ hClose h
-        throwCGI e
-  (`catchCGI` handlePostOpenError) $ do
+          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

diff --git a/scripts-static-cat.cabal b/scripts-static-cat.cabal
index 5c02fe31abd4555601e8f13b49ae88f9a0298fe9..734acb25dec3d24212dfbb6889216e1481fb6fe0 100644 (file)
--- a/scripts-static-cat.cabal
+++ b/scripts-static-cat.cabal
@@ -13,9 +13,10 @@ Executable           static-cat
   Build-Depends:
     base >= 4,
     bytestring,
-    cgi >= 3001.1.7.2,
+    cgi >= 3001.1.8,
     containers,
     filepath,
+    MonadCatchIO-mtl,
     old-locale,
     time,
     unix,