Monad.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Network.HxWeb.Monad
-- Copyright   :  (c) David Himmelstrup 2006
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-----------------------------------------------------------------------------
module Network.HxWeb.Monad where

import Control.Monad.State
import Network.CGI
import Network.CGI.Monad

newtype WebPage st a
    = WebPage { unWebPage :: StateT st (CGIT IO) (WebResult a) }

data WebResult ret
    = WebResult ret
    | Redirect String
    | Fail String
      deriving Show

instance Monad (WebPage st) where
    WebPage g >>= f
        = WebPage $
          do g' <- g
             case g' of
               Redirect url -> return (Redirect url)
               Fail msg -> return (Fail msg)
               WebResult ret -> unWebPage (f ret)
    fail = WebPage . return . Fail
    return = WebPage . return . WebResult

instance MonadPlus (WebPage st) where
    mzero = WebPage $ return (Fail "mzero")
    mplus a b = WebPage $
                do a' <- unWebPage a
                   case a' of
                     Fail _ -> unWebPage b
                     _ -> return a'

instance MonadIO (WebPage st) where
    liftIO io = WebPage (do a <- liftIO io
                            return (WebResult a))


instance MonadState st (WebPage st) where
    get = WebPage (liftM WebResult get)
    put s = WebPage (liftM WebResult $ put s)

instance Functor (WebPage st) where
    fmap fn a = do a' <- a
                   return (fn a')

instance MonadCGI (WebPage st) where
    cgiAddHeader h v = WebPage (liftM WebResult $ lift (cgiAddHeader h v))
    cgiGet fn = WebPage (liftM WebResult $ lift (cgiGet fn))