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

Question

我正在尝试将 Servant 身份验证(servant-auth-server 包)与 RIO 作为我的处理程序 monad 结合使用，以避免出现 exceptT 反模式。但是，我无法正确排列类型以处理被拒绝的身份验证。
我的(简化的)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行动。但是当一个servant服务器有多个端点时，每个不同的处理程序必须由 :<|> 组成。组合器。
如果您的 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)