Monad堆叠注意点

发表于 分类于 ，

下方代码定义了一个ServiceContext，在多个Service中可以共享该ServiceContext的内容

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
type Service site = ReaderT ServiceContext (HandlerFor site)

someService1 :: Service App ()
someService1 = do
    ServiceContext now <- ask
    print now

someService2 :: Service App ()
someService2 = do
    ServiceContext now <- ask
    print now

someService :: Service App ()
someService = someService1 >> someService2

runService :: Service App a -> HandlerFor App a
runService service = do
    now <- localTime
    ctx <- ServiceContext now
    runReaderT service ctx

handlerUser :: HandlerFor App ()
handlerUser = do
    user <- runService someService

注意这里runService引入了副作用，每次调用runService的时间会重新生成。
在上面的例子中，runService只使用了一次，所以不会有问题。

什么时候会调用多次呢？
当在Service内使用了其他Monad，而其他Monad又要调用Service的情况

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
type Db site = ReaderT Connection (HandlerFor site)
runDB :: Db site a -> HandlerFor App a

insertDB :: Db App ()
insertDB = do
    user <- lift $ runService createUserService
    insert_ user

addUserService :: Service App ()
addUserService = 
    lift $ runDB insertDB

handlerUser :: HandlerFor App ()
handlerUser = do
    user <- runService addUserService

这时候HandlerFor和Db都调用了runService，两次生成的时间是不同的。
要避免这种情况有好几种方式

方式1：避免相互调用

Service处理完Db处理，不在Db中引入Service的逻辑

1
2
3
4
addUserService :: Service App ()
addUserService = 
    user <- createUserService
    lift $ runDB $ insert_ user

也可以传递ServiceContext到其他Monad内手动解包而不是通过runService解包

1
2
3
4
5
6
addUserService :: Service App ()
addUserService = 
    context <- ask
    lift $ runDB do
        user <- runReaderT createUserService context
        insert_ user

方式2：堆叠Monad

何不构建一个既可以执行Service又能执行Db的Monad呢

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
type Db site = ReaderT Connection (HandlerFor site)
type Service site = ReaderT ServiceContext (HandlerFor site)
-- 嵌套
type DbService site = ReaderT Connection (Service site)

runDB :: Db site a -> HandlerFor App a
runDB = ...

runDBService :: DbService site a -> Service site a
runDBService dbService = do
    -- 解包最外层，得到Service
    lift $ runDB $ runInnerService dbService
    where
        -- 转换ReaderT的Monad参数，等同下方
    -- runInnerService :: ReaderT Connection (Service site) a -> ReaderT Connection (HandlerFor site) a
        runInnerService :: DbService site a -> Db site a
        runInnerService dbService = hoistReaderT runService dbService

-- 因为 ReaderT r m a = ReaderT { runReaderT :: r -> m a }
-- 所以 f :: r -> ma
hoistReaderT :: (m a -> n a) -> ReaderT r m a -> ReaderT r n a
hoistReaderT nat (ReaderT f) = ReaderT (nat . f)

一开始错误的使用runService <$> dbService进行转换。

其本质依旧是一个函数

1
2
3
Handler: HandlerData -> IO a
Service: ServiceContext -> (HandlerData -> IO a)
DbService: Connection -> (ServiceContext -> (HandlerData -> IO a))