Question

As it’s usual when working with Happstack, I have been making my own server monad to use for the handlers, to cover my DB and Sessions, plus some error handling. I have recently discovered the happstack-clientsession-Package that is a big help and prevents me from writing my own solution.

Though there’s a little trouble wiring in the ClientSessionT monad to my own. As it turns out, there are no MonadReader or MonadError instances for it, so I cannot instance them in my wrapper monad.

Here is the full code of the module:

{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, DeriveDataTypeable, EmptyDataDecls, TemplateHaskell #-}
module Server where

import Control.Monad
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.Trans
import Data.Data (Data, Typeable)
import Data.SafeCopy (base, deriveSafeCopy)
import Database.MongoDB as M
import Happstack.Server
import Happstack.Server.Error
import Happstack.Server.ClientSession
import System.IO.Pool
import System.IO.Error
import Web.ClientSession (getDefaultKey)

type MongoPool e = Pool e Pipe

data PonySession = PonySession -- TODO: Fill in User type when available
    deriving (Ord, Read,Show, Eq, Typeable, Data)
$(deriveSafeCopy 0 'base ''PonySession)

instance ClientSession PonySession where
    empty = PonySession

newtype PonyServerPartT e m a = PonyServerPart (ClientSessionT PonySession (ReaderT (MongoPool IOError) (ServerPartT (ErrorT e m))) a)
    deriving (Monad, MonadIO, MonadReader (MongoPool e), MonadError e, ServerMonad, MonadPlus)

type PonyServerPart = PonyServerPartT IOError IO

runServerT s = mapServerPartT' (spUnwrapErrorT errorHandler) $ do
    key <- liftIO getDefaultKey
    let sessConf = (mkSessionConf key) { sessionCookieLife = MaxAge $ 60 * 60 * 24 * 7 }
    pool <- liftIO mongoPool
    runReaderT (runClientSessionT s sessConf) pool
    where errorHandler = simpleErrorHandler . show

mongoPool :: IO (MongoPool IOError)
mongoPool = newPool fac 10
    where fac = Factory {
            newResource = connect $ M.host "127.0.0.1",
            killResource = close,
            isExpired = isClosed
        }

The error I am getting is obvious: The deriving from MonadError and MonadReader does not work. But I’d need those, otherwise the entire performance is kind of useless.

Since I have never been able to figure out how these are done (And relied on deriving), I’d like for an answer that covers this specific problem and kind of tells me how it is done generally.

Answer 1

In theory, you would write something like this, except you can’t because the ClientSessionT constructor and ‘unClientSessionT` function are not exported:

instance (Monad m, MonadError e m) => MonadError e (ClientSessionT st m) where
    throwError = ClientSessionT . throwError
    catchError (ClientSessionT m) f =
        ClientSessionT $ ReaderT $ \r -> StateT $ \s ->
          (runStateT (runReaderT m r) s) `catchError` (\e -> runStateT (runReaderT (unClientSessionT (f e)) r) s)

instance (Functor m, Monad m, MonadReader r m) => MonadReader r (ClientSessionT st m) where
    ask = ClientSessionT $ lift $ lift ask
    local f (ClientSessionT m) = ClientSessionT $ mapReaderT (mapStateT (local f)) m

Writing these types of instances by hand is pretty mechanical — there are patterns you will see arise again and again. (Which is why the compiler can figure out how to do it automatically most of the time).

In this case, the best fix is to complain to the authors about the missing instances.

The darcs version now includes MonadError, MonadReader, and a bunch more. Plus some other changes that break things a tiny bit, but make things better over all.

There is also a demo directory now:

http://patch-tag.com/r/mae/happstack/snapshot/current/content/pretty/happstack-clientsession

I will probably release it, with a few minor changes, and more comments in a day or two.