diff --git a/Network/CGI.hs b/Network/CGI.hs --- a/Network/CGI.hs +++ b/Network/CGI.hs @@ -94,7 +94,7 @@ , module Network.CGI.Compat ) where -import Control.Exception (Exception(..)) +import Control.Exception (Exception(..), SomeException, ErrorCall(..)) import Control.Monad (liftM) import Control.Monad.Trans (MonadIO, liftIO) import Data.Char (toUpper) @@ -184,13 +184,10 @@ -- | Output a 500 Internal Server Error with information from -- an 'Exception'. -outputException :: (MonadCGI m,MonadIO m) => Exception -> m CGIResult +outputException :: (MonadCGI m,MonadIO m) => SomeException -> m CGIResult outputException e = outputInternalServerError es - where es = case e of - ErrorCall msg -> [msg] - IOException ie -> ioe ie - _ -> [show e] - ioe ie = if isUserError ie then [ioeGetErrorString ie] else [show ie] + where es | Just (ErrorCall msg) <- fromException e = [msg] + | otherwise = [show e] -- | Output an error page to the user, with the given -- HTTP status code in the response. Also logs the error information diff --git a/Network/CGI/Compat.hs b/Network/CGI/Compat.hs --- a/Network/CGI/Compat.hs +++ b/Network/CGI/Compat.hs @@ -20,7 +20,7 @@ ) where import Control.Concurrent (forkIO) -import Control.Exception as Exception (Exception,throw,catch,finally) +import Control.Exception as Exception (SomeException,throw,catch,finally) import Control.Monad (unless) import Control.Monad.Trans (MonadIO, liftIO) import qualified Data.Map as Map @@ -101,7 +101,7 @@ Just "POST" -> takeInput env req _ -> maybe BS.empty BS.pack (lookup "QUERY_STRING" env) -abort :: String -> Exception -> IO a +abort :: String -> SomeException -> IO a abort msg e = do putStrLn ("Content-type: text/html\n\n" ++ "" ++ msg ++ "") diff --git a/Network/CGI/Monad.hs b/Network/CGI/Monad.hs --- a/Network/CGI/Monad.hs +++ b/Network/CGI/Monad.hs @@ -27,7 +27,7 @@ throwCGI, catchCGI, tryCGI, handleExceptionCGI, ) where -import Control.Exception as Exception (Exception, try, throwIO) +import Control.Exception as Exception (SomeException, try, throwIO) import Control.Monad (liftM) import Control.Monad.Error (MonadError(..)) import Control.Monad.Reader (ReaderT(..), asks) @@ -92,28 +92,28 @@ -- * Error handling -- -instance MonadError Exception (CGIT IO) where +instance MonadError SomeException (CGIT IO) where throwError = throwCGI catchError = catchCGI -- | Throw an exception in a CGI monad. The monad is required to be -- a 'MonadIO', so that we can use 'throwIO' to guarantee ordering. -throwCGI :: (MonadCGI m, MonadIO m) => Exception -> m a +throwCGI :: (MonadCGI m, MonadIO m) => SomeException -> m a 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 -> (Exception -> CGI a) -> CGI a +catchCGI :: CGI a -> (SomeException -> CGI a) -> CGI a catchCGI c h = tryCGI c >>= either h return -- | 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 Exception a) +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 {-# DEPRECATED handleExceptionCGI "Use catchCGI instead." #-} -- | Deprecated version of 'catchCGI'. Use 'catchCGI' instead. -handleExceptionCGI :: CGI a -> (Exception -> CGI a) -> CGI a +handleExceptionCGI :: CGI a -> (SomeException -> CGI a) -> CGI a handleExceptionCGI = catchCGI diff --git a/cgi.cabal b/cgi.cabal --- a/cgi.cabal +++ b/cgi.cabal @@ -1,7 +1,8 @@ Name: cgi -Version: 3001.1.7.1 +Version: 3001.1.7.2 Copyright: Bjorn Bringert, Andy Gill, Ian Lynagh, Erik Meijer, Sven Panne, Jeremy Shaw +Category: Network Maintainer: bjorn@bringert.net Author: Bjorn Bringert License: BSD3 @@ -31,13 +32,13 @@ Build-depends: network>=2.0, parsec >= 2.0, mtl >= 1.0, xhtml >= 3000.0.0 If flag(split-base) - Build-depends: base == 3.*, old-time, old-locale, containers + Build-depends: base >= 3 && < 5, old-time, old-locale, containers Else Build-depends: base < 3 If flag(bytestring-in-base) Build-depends: base >= 2 && < 3 Else - Build-depends: base < 2 || == 3.*, bytestring + Build-depends: base < 2 || < 5, bytestring --Executable: printinput --Main-Is: printinput.hs