使用 RIO 在 Servant.Auth 中拒绝身份验证

Question

我正在尝试将 Servant 身份验证（servant-auth-server 包）与 RIO 结合为我的处理程序 monad，以避免出现异常反模式。但是，我无法正确排列类型以处理被拒绝的身份验证。

我的（简化的）API 端点是

type UserEndpoint = "user" :> (
              Get '[JSON] User                                       
        :<|>  ReqBody '[JSON] UpdatedUser :> Put '[JSON] User        
    )

以及对应的服务器

protectedServer
  :: HasLogFunc m
  => AuthResult AuthUserId
  -> ServerT UserEndpoint (RIO m)
protectedServer (Authenticated authUser) =
  getUser authUser :<|> updateUser authUser
-- Otherwise, we return a 401.
protectedServer _ = throwIO err401

拒绝身份验证的分支中出现类型错误：

    Could not deduce (MonadIO ((:<|>) (RIO m User)))
      arising from a use of ‘throwIO’
    [..]

我不理解这种类型的错误。据我了解（并给出protectedServer 的签名），返回类型应该是ServerT UserEndpoint (RIO m)，它应该有一个MonadIO 的实例，因此根据exceptions tutorial 的异常处理应该使用throwIO 而不是throwAll 来自 Servant.Auth.Server。看来我还没有完全理解Servant的类机，我的错在哪里？

两个处理函数定义为

updateUser :: HasLogFunc m => AuthUserId -> UpdatedUser -> RIO m User
updateUser authUser updateUser = ...

getUser :: HasLogFunc m => AuthUserId -> RIO m User
getUser authUser = ...

Answer 1

问题在于throwIO err401 是一个单个 RIO 操作。但是当一个服务服务器有多个端点时，每个不同的处理程序都必须由:<|> 组合子组成。

如果您的 API 有许多端点，为每个端点编写返回 401 的处理程序很快就会变得很烦人。幸运的是，servant-auth-server 似乎提供了一个 throwAll 辅助函数，它可以自动为整个 API 构建返回错误的处理程序。

编辑：正如 Ulrich 所指出的，throwAll 的问题在于它仅适用于 MonadError monad，而 RIO 不是 MonadError 的实例。但是应该可以修改类型类，使其支持RIO。

首先，一些导入和辅助数据类型：

{-# LANGUAGE UndecidableInstances, TypeOperators, FlexibleInstances,
             TypeFamilies, DataKinds, ImportQualifiedPost
             #-}
module Main where

import RIO (RIO) -- rio
import RIO qualified
import Data.Tagged               (Tagged (..)) -- package tagged
import Servant                   ((:<|>) (..), ServerError(..))
import Network.HTTP.Types -- package http-types
import Network.Wai -- package wai
import Data.ByteString.Char8 qualified as BS

这是主要的RIOThrowAll 类型类：

class RIOThrowAll a where
    rioThrowAll :: ServerError -> a

-- for a composition of endpoints
instance (RIOThrowAll a, RIOThrowAll b) => RIOThrowAll (a :<|> b) where
    rioThrowAll e = rioThrowAll e :<|> rioThrowAll e

-- if we have a function, we ignore the argument and delegate on the result
instance (RIOThrowAll b) => RIOThrowAll (a -> b) where
    rioThrowAll e = \_ -> rioThrowAll e

-- if we reach a RIO action at the tip of a function
instance RIOThrowAll (RIO.RIO env x) where
    rioThrowAll e = RIO.throwIO e

-- this is only for Raw endpoints which embed a WAI app directly
instance RIOThrowAll (Tagged (RIO.RIO env x) Application) where
  rioThrowAll e = Tagged $ \_req respond ->
      respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))
                            (errHeaders e)
                            (errBody e)