为yesod拓展service功能

发表于 分类于 ，

在搭建业务系统的时候有些通用的逻辑经常反复使用，如下

  • 获取一个统一的当前时间
  • 获取用户信息
  • 若实体存在再执行某个方法
  • 若实体是唯一的再执行某个方法

为此，对Yesod框架的Handler进行拓展

提供ServiceContext

1
2
3
4
data ServiceContext site = ServiceContext
        { serviceCtxUserId :: RawUserId site
        , serviceCtxTime :: LocalTime
    }

如何将ServiceContext传递给Service呢，这时候有两种方式可以解决

方式1：定义一个获取Context的方法

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
getContext :: ServiceContext site
getContext = ....

doSomething1 :: Handler a
doSomething1 = do
    sc <- getContext
    ....

doSomething2 :: Handler a
doSomething2 = do
    sc <- getContext
    ....

myhandler :: Handler a
myhandler = do
    doSomething1
    doSomething2

这种方式存在一个问题，就是每次调用的时候都会执行函数，多次执行获取的时间并不相同。

方式2：使用ReaderT

定义一个ReaderT将计算好的数据传递给HandlerFor

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

runServeFor :: ServeFor site a -> (HandlerFor site) a
runServeFor service = do
    let sc = ServiceContext ...
    runReaderT service sc

serveFor1 :: ServeFor site a
serveFor1 = do
    sc <- ask
    ....

serveFor2 :: ServeFor site a
serveFor1 = do
    sc <- ask
    ....

myhandler :: Handler a
myhandler = do
    runServeFor serveFor1
    runServeFor serveFor2

提供参数

每个Service都有独立的参数类型，提供的方式又有很多种

方式1：放在ServiceContext

为ServiceContext添加一个参数类型

1
2
3
4
5
data ServiceContext site a = ServiceContext
        { serviceCtxUserId :: RawUserId site
        , serviceCtxTime   :: LocalTime
        , serviceData      :: a -- 新增参数
    }

runServeFor需要添加一个参数

1
2
3
4
5
6
7
8
runServeFor :: form -> ServeFor site a -> (HandlerFor site) a
runServeFor form service = do
    -- 需要提供表单给ServiceContext
    let sc = ServiceContext {
        ...
        serviceData = form
    }
    runReaderT service sc

该方式处理起来更加简洁，不同嵌套太多，否者还得单独处理参数

方式2：新增函数

因为ServeFor缺少参数，可以定义一个有参数的函数

1
param -> ServeFor site result

这时候有两种选择

使用class

参数和返回值由具体的实现提供。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
class Service param site where
    type Output param
    action :: param -> ServeFor site (Output param)

newtype AddUserService = AddUserService UserForm
newtype AddUserService = AddGroupService GroupForm

instance Service AddUserService App where
    action :: AddUserService -> ServeFor site ()

instance Service AddGroupService App where
    action :: AddGroupService -> ServeFor site ()

class ServiceRunner site where

    runService :: (ServiceRunner site) => Service site -> HandlerFor site result

instance ServiceRunner App where
    runService service =
        ServiceContext <$> getRawUserId <*> nowDateTime >>=
        runReaderT (action service)

使用newtype

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
newtype Service site param result = Service {
    action :: param -> ServeFor site result
}

addUserService :: Service App UserForm ()

addGroupService :: Service App GroupForm ()

class ServiceRunner site where

    runService :: (Service param result site) => param -> HandlerFor site result

instance ServiceRunner App where
    runService service =
        ServiceContext <$> getRawUserId <*> nowDateTime >>=
        runReaderT (action service)

newtype和class都能实现，这取决于runService是接收一个数据还是接收一个函数，简单的例子如下

1
2
3
4
5
-- 通过class多态实现，参数需要实现ToJson，
responseJsonStr :: ToJson a => a -> String

-- 直接传递生成json的函数
responseJsonStr :: (a -> JsonValue) -> String

传递函数这种风格看起来更加符合函数式编程且更简洁。

提升Monad

下方是我的Service定义，使用newtype封装ReaderT

1
2
newtype ServeFor site param a = ServeFor (ReaderT (ServiceContext site param) (HandlerFor site) a)
    deriving (Functor, Applicative, Monad, MonadIO, MonadResource, MonadLogger)

因为使用的是newtype，所以在这个新类型下无法调用其他Monad，所以需要定义提升操作，这样才能和其他Monad交互。

提升包含两部分，

  • 其他类型提升为当前类型，m a -> ServeFor site parma a
  • 提升当前类型为其他类型，ServeFor site parma a -> m a

HandlerFor 与 ServeFor的关系

根据ServeFor的签名可以知道，ServeFor是包含了ServiceContext的HandleFor。所以ServeFor可以解包成HandleFor，HandleFor可以提升为ServeFor。

在HandlerFor中使用Service需要通过runServeFor并传递ServiceContext将ServeFor解包。

1
2
runServeFor :: ServeFor site param a -> ServiceContext site param -> HandlerFor site a
runServeFor (ServeFor service) context = runReaderT service context

在ServeFor中使用HandlerFor需要对HandlerFor提升

1
2
3
instance MonadHandler (ServeFor site param) where
    type HandlerSite (ServeFor site param) = site
    liftHandler handler = ServeFor $ lift handler