Question

正如通常使用Happstack时一样，我一直在创建自己的服务器monad用于处理程序，覆盖我的数据库和会话，以及一些错误处理。我最近发现了happstack-clientsession - 这是一个很大的帮助，阻止我编写自己的解决方案。

虽然在ClientSessionT monad中连接到我自己有点麻烦。事实证明，它没有MonadReader或MonadError个实例，所以我不能在我的包装器monad中实例化它们。

以下是该模块的完整代码：

{-# 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
        }

我得到的错误很明显：来自MonadError和MonadReader的错误不起作用。但我需要那些，否则整个表演都没用。

由于我从来没有弄清楚这些是如何完成的（并且依赖于deriving），我想要一个涵盖这个特定问题的答案，并告诉我它是如何完成的。

Answer 1

理论上，你会写这样的东西，除非你不能，因为ClientSessionT构造函数和'unClientSessionT`函数不会被导出：

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

手工编写这些类型的实例非常机械 - 你会看到一些又一次出现的模式。（这就是为什么编译器可以在大多数情况下自动计算出来的原因。）

在这种情况下，最好的解决方法是向作者抱怨缺少的实例。

darcs版本现在包含MonadError，MonadReader以及更多内容。还有一些其他的改变可以让事情变得微不足道，但让事情变得更好。

现在还有一个演示目录：

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

我可能会在一两天内发布一些小的更改和更多的评论。

Answer 2

newtype派生机制期望ClientSessionT具有所需类型类的实例。我在haddock文档中没有看到您链接到ClientSessionT包含MonadError或MonadReader实例的位置。追逐类型类约束（例如，对于Happstack）也不会显示MonadError或“MonadReader”的实例。

section 7.5 of the GHC User's Guide中记录了一般机制。我们的想法是，对于类型类CanBark和数据类型Dog的实例（即instance CanBark Dog where ...），DomesticDog周围的新类型包装器Dog可以自动访问使用CanBark Dog搜索并替换Dog到DomesticDog。

将MonadReader / MonadError实例添加到Transformer类型

2 个答案: