Generalizing Network.CGI exceptions to MonadCatchIO

[Anders Kaseorg]

A few things have frustrated me about Network.CGI’s exception handling.

• I can’t use the new-style Exception class directly; I have to convert to
  and from SomeException first.
• There’s no analogue of nice utilities like bracket and onException for
  CGI.
• I can only use throwCGI and catchCGI in CGIT IO, not an arbitrary
  MonadCGI.

One way to solve all three of these problems is using MonadCatchIO.  As an 
added bonus, we get a much simpler definition of try/catch.

Who is maintaining the CGI library these days?  What do you think of this 
patch?

(It would be possible to generalize the types even further, from 
SomeException to Exception e => e, but I’m worried about introducing 
ambiguous type variables into existing code.  After this patch, new code 
can just use the Control.Monad.CatchIO functions directly to deal with 
Exception e => e.)

Anders

-- 8< --
From 5f9b9ca5e9faf34b36887737d820c3ca9ea76e09 Mon Sep 17 00:00:00 2001
From: Anders Kaseorg <andersk at mit.edu>
Date: Tue, 9 Mar 2010 05:18:57 -0500
Subject: [PATCH] Generalize exception handling to an arbitrary MonadCatchIO.

Signed-off-by: Anders Kaseorg <andersk at mit.edu>
---
 Network/CGI.hs       |    3 ++-
 Network/CGI/Monad.hs |   24 ++++++++++++++----------
 cgi.cabal            |    2 +-
 3 files changed, 17 insertions(+), 12 deletions(-)

diff --git a/Network/CGI.hs b/Network/CGI.hs
index 3acd0db..8ebc057 100644
--- a/Network/CGI.hs
+++ b/Network/CGI.hs
@@ -96,6 +96,7 @@ module Network.CGI (
 
 import Control.Exception (Exception(..), SomeException, ErrorCall(..))
 import Control.Monad (liftM)
+import Control.Monad.CatchIO (MonadCatchIO)
 import Control.Monad.Trans (MonadIO, liftIO)
 import Data.Char (toUpper)
 import Data.List (intersperse, sort, group)
@@ -175,7 +176,7 @@ redirect url = do setHeader "Location" url
 -- >
 -- > main :: IO ()
 -- > main = runCGI (handleErrors cgiMain)
-handleErrors :: CGI CGIResult -> CGI CGIResult
+handleErrors :: (MonadCGI m, MonadCatchIO m) => m CGIResult -> m CGIResult
 handleErrors = flip catchCGI outputException
 
 --
diff --git a/Network/CGI/Monad.hs b/Network/CGI/Monad.hs
index 69d7840..f3d55cf 100644
--- a/Network/CGI/Monad.hs
+++ b/Network/CGI/Monad.hs
@@ -27,13 +27,14 @@ module Network.CGI.Monad (
   throwCGI, catchCGI, tryCGI, handleExceptionCGI,
  ) where
 
-import Control.Exception as Exception (SomeException, try, throwIO)
+import Prelude hiding (catch)
+import Control.Exception as Exception (SomeException, throwIO)
 import Control.Monad (liftM)
+import Control.Monad.CatchIO (MonadCatchIO, block, catch, try, unblock)
 import Control.Monad.Error (MonadError(..))
 import Control.Monad.Reader (ReaderT(..), asks)
 import Control.Monad.Writer (WriterT(..), tell)
 import Control.Monad.Trans (MonadTrans, MonadIO, liftIO, lift)
-import Data.Monoid (mempty)
 import Data.Typeable (Typeable(..), Typeable1(..), 
                       mkTyConApp, mkTyCon)
 
@@ -66,6 +67,11 @@ instance Monad m => Monad (CGIT m) where
 instance MonadIO m => MonadIO (CGIT m) where
     liftIO = lift . liftIO
 
+instance MonadCatchIO m => MonadCatchIO (CGIT m) where
+    CGIT m `catch` h = CGIT (try m) >>= either h return
+    block (CGIT m) = CGIT (block m)
+    unblock (CGIT m) = CGIT (unblock m)
+
 -- | The class of CGI monads. Most CGI actions can be run in
 --   any monad which is an instance of this class, which means that
 --   you can use your own monad transformers to add extra functionality.
@@ -92,7 +98,7 @@ runCGIT (CGIT c) = liftM (uncurry (flip (,))) . runWriterT . runReaderT c
 -- * Error handling
 --
 
-instance MonadError SomeException (CGIT IO) where
+instance MonadCatchIO m => MonadError SomeException (CGIT m) where
     throwError = throwCGI
     catchError = catchCGI
 
@@ -103,17 +109,15 @@ throwCGI = liftIO . throwIO
 
 -- | Catches any expection thrown by a CGI action, and uses the given 
 --   exception handler if an exception is thrown.
-catchCGI :: CGI a -> (SomeException -> CGI a) -> CGI a
-catchCGI c h = tryCGI c >>= either h return
+catchCGI :: (MonadCGI m, MonadCatchIO m) => m a -> (SomeException -> m a) -> m a
+catchCGI = catch
 
 -- | Catches any exception thrown by an CGI action, and returns either
 --   the exception, or if no exception was raised, the result of the action.
-tryCGI :: CGI a -> CGI (Either SomeException a)
-tryCGI (CGIT c) = CGIT (ReaderT (\r -> WriterT (f (runWriterT (runReaderT c r)))))
-    where
-      f = liftM (either (\ex -> (Left ex,mempty)) (\(a,w) -> (Right a,w))) . try
+tryCGI :: (MonadCGI m, MonadCatchIO m) => m a -> m (Either SomeException a)
+tryCGI = try
 
 {-# DEPRECATED handleExceptionCGI "Use catchCGI instead." #-}
 -- | Deprecated version of 'catchCGI'. Use 'catchCGI' instead.
-handleExceptionCGI :: CGI a -> (SomeException -> CGI a) -> CGI a
+handleExceptionCGI :: (MonadCGI m, MonadCatchIO m) => m a -> (SomeException -> m a) -> m a
 handleExceptionCGI = catchCGI
diff --git a/cgi.cabal b/cgi.cabal
index fba15ff..b2ba0c1 100644
--- a/cgi.cabal
+++ b/cgi.cabal
@@ -30,7 +30,7 @@ Library
   Extensions: MultiParamTypeClasses
   ghc-options: -Wall
 
-  Build-depends: network>=2.0, parsec >= 2.0, mtl >= 1.0, xhtml >= 3000.0.0
+  Build-depends: network>=2.0, parsec >= 2.0, mtl >= 1.0, MonadCatchIO-mtl, xhtml >= 3000.0.0
   If flag(split-base)
     Build-depends: base >= 3 && < 5, old-time, old-locale, containers
   Else
-- 
1.7.0.2