module Network.CGI.Monad (
MonadCGI(..),
CGIT(..), CGI,
runCGIT,
CGIRequest(..),
throwCGI, catchCGI, tryCGI, handleExceptionCGI,
) where
import Control.Exception.Extensible as Exception (SomeException, try, throwIO)
import Control.Monad (liftM)
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)
import Network.CGI.Protocol
type CGI a = CGIT IO a
newtype CGIT m a = CGIT { unCGIT :: ReaderT CGIRequest (WriterT Headers m) a }
instance (Typeable1 m, Typeable a) => Typeable (CGIT m a) where
typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Monad.CGIT")
[typeOf1 (undefined :: m a), typeOf (undefined :: a)]
instance (Functor m, Monad m) => Functor (CGIT m) where
fmap f c = CGIT (fmap f (unCGIT c))
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
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) = liftM (uncurry (flip (,))) . runWriterT . runReaderT c
instance MonadError SomeException (CGIT IO) where
throwError = throwCGI
catchError = catchCGI
throwCGI :: (MonadCGI m, MonadIO m) => SomeException -> m a
throwCGI = liftIO . throwIO
catchCGI :: CGI a -> (SomeException -> CGI a) -> CGI a
catchCGI c h = tryCGI c >>= either h return
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
handleExceptionCGI :: CGI a -> (SomeException -> CGI a) -> CGI a
handleExceptionCGI = catchCGI