3

与使用 Happstack 时通常一样，我一直在制作自己的服务器 monad 用于处理程序，以涵盖我的数据库和会话，以及一些错误处理。我最近发现happstack-clientsession-Package 有很大帮助，它阻止我编写自己的解决方案。

ClientSessionT虽然在我自己的单子中接线有点麻烦。事实证明，它没有MonadReaderorMonadError实例，所以我不能在我的包装器 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），我想要一个涵盖这个特定问题的答案，并告诉我它是如何完成的。

4

2 回答 2

3

理论上，你会写这样的东西，除了你不能因为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和更多。加上一些其他的改变，它们会稍微破坏一些东西，但总体上会让事情变得更好。

现在还有一个demo目录：

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

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

于 2012-04-23T07:19:39.440 回答
0

newtype派生机制期望ClientSessionT具有所需类型类的实例。我没有在您链接到 where ClientSessionThas instances for MonadErroror的黑线鳕文档中看到MonadReader。追逐类型类约束（例如 for Happstack）也不会显示 forMonadError或 MonadReader 的实例。

GHC 用户指南的第 7.5 节记录了一般机制。这个想法是，对于类型类和数据类型的CanBark实例Dog（即instance CanBark Dog where ...），新类型包装器可以自动访问通过搜索和替换。DomesticDogDogCanBark DogDogDomesticDog

于 2012-04-22T10:57:04.230 回答