使用 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 的签名），return 类型应该是 ServerT UserEndpoint (RIO m)，它应该有一个 MonadIO 的实例，以便根据exceptions tutorial 应该使用 throwIO 而不是 Servant.Auth.Server 中的 throwAll。看来我还没有完全理解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 provides a 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)

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

Deny Authentication in Servant.Auth with RIO

authentication

haskell

servant

rio