{-# LANGUAGE MultiParamTypeClasses #-}
module Network.CGI.Monad (
MonadCGI(..),
CGIT(..), CGI,
runCGIT,
CGIRequest(..),
throwCGI, catchCGI, tryCGI, handleExceptionCGI,
) where
import Control.Exception as Exception (SomeException)
import Control.Applicative (Applicative(..))
import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask, throwM, catch, try, mask, uninterruptibleMask, generalBracket)
import Control.Monad.Except (MonadError(..))
import Control.Monad.Reader (ReaderT(..), asks)
import Control.Monad.Writer (WriterT(..), tell)
import Control.Monad.Trans (MonadTrans, MonadIO, liftIO, lift)
import Data.Typeable
import Network.CGI.Protocol
type CGI a = CGIT IO a
newtype CGIT m a = CGIT { unCGIT :: ReaderT CGIRequest (WriterT Headers m) a }
deriving (Typeable)
instance (Functor m) => Functor (CGIT m) where
fmap f c = CGIT (fmap f (unCGIT c))
instance (Applicative m) => Applicative (CGIT m) where
pure = CGIT . pure
f <*> x = CGIT (unCGIT f <*> unCGIT x)
instance Monad m => Monad (CGIT m) where
c >>= f = CGIT (unCGIT c >>= unCGIT . f)
return = CGIT . return
fail = CGIT . fail
instance MonadIO m => MonadIO (CGIT m) where
liftIO = lift . liftIO
instance MonadThrow m => MonadThrow (CGIT m) where
throwM = CGIT . throwM
instance MonadCatch m => MonadCatch (CGIT m) where
CGIT m `catch` h = CGIT $ m `catch` (unCGIT . h)
instance MonadMask m => MonadMask (CGIT m) where
mask a = CGIT $ mask $ \u -> unCGIT $ a $ CGIT . u . unCGIT
uninterruptibleMask a = CGIT $ uninterruptibleMask $ \u -> unCGIT $ a $ CGIT . u . unCGIT
generalBracket acquire release f = CGIT $
generalBracket (unCGIT acquire) (\a b -> unCGIT (release a b)) (unCGIT . f)
instance MonadCatch m => MonadError SomeException (CGIT m) where
throwError = throwM
catchError = catch
class Monad m => MonadCGI m where
cgiAddHeader :: HeaderName -> String -> m ()
cgiGet :: (CGIRequest -> a) -> m a
instance Monad m => MonadCGI (CGIT m) where
cgiAddHeader n v = CGIT $ lift $ tell [(n,v)]
cgiGet = CGIT . asks
instance MonadTrans CGIT where
lift = CGIT . lift . lift
runCGIT :: Monad m => CGIT m a -> CGIRequest -> m (Headers, a)
runCGIT (CGIT c) = fmap (uncurry (flip (,))) . runWriterT . runReaderT c
{-# DEPRECATED throwCGI "Use Control.Monad.Catch.throwM instead." #-}
throwCGI :: (MonadThrow m) => SomeException -> m a
throwCGI = throwM
{-# DEPRECATED catchCGI "Use Control.Monad.Catch.catch instead." #-}
catchCGI :: (MonadCatch m) => m a -> (SomeException -> m a) -> m a
catchCGI = catch
{-# DEPRECATED tryCGI "Use Control.Monad.Catch.try instead." #-}
tryCGI :: (MonadCatch m) => m a -> m (Either SomeException a)
tryCGI = try
{-# DEPRECATED handleExceptionCGI "Use Control.Monad.Catch.catch instead." #-}
handleExceptionCGI :: (MonadCatch m) => m a -> (SomeException -> m a) -> m a
handleExceptionCGI = catch