使用servant-auth与servant-checked-exceptions时的类型匹配错误排查

我在使用Haskell的servant-auth、servant-auth-server和servant-checked-exceptions开发API时遇到类型匹配错误。未受保护的reg2接口运行正常，但受保护的test接口无法通过类型检查，推测是受保护区域中servant-checked-exceptions的Throws或Envelope导致的问题。

API类型定义 #

type Unprotected = "reg2" :> QueryParam "name" String
                 :> QueryParam "email" String
                 :> QueryParam "pwd" String
                 :> Throws HRegFieldErrors
                 :> Throws UserRegError

type Protected =  "test" 
                 :> Throws SomeError
                 :> Get '[PlainText] String
                 :<|> ...

类型匹配错误 #

app/Main.hs:185:20: error:
    • Couldn't match type: Envelope
                             '[SomeError]
                             (Headers
                                '[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie]
                                [Char])
                     with: Headers
                             '[Header "Set-Cookie" SetCookie]
                             (Headers
                                '[Header "Set-Cookie" SetCookie] (Envelope '[SomeError] [Char]))
        arising from a use of ‘serveWithContext’
    • In the second argument of ‘($)’, namely
        ‘serveWithContext api cfg (server env jwtCfg)’
      In a stmt of a 'do' block:
        run 8080 $ serveWithContext api cfg (server env jwtCfg)
      In the expression:
        do print "wait for mysql"
           print "try to connect..."
           pool_ <- myResourcePool
           let i_config = ...
           ....
    |
185 |         run 8080 $ serveWithContext api cfg (server env jwtCfg)

受保护接口处理函数 #

protected :: Env -> Servant.Auth.Server.AuthResult AuthData -> Server Protected
protected env (Servant.Auth.Server.Authenticated authdata) = test
      where
        test :: Handler (Envelope '[SomeError] String)
        test = do
                            liftIO $ print "test"
                            pureErrEnvelope SomeError
protected _ _ = throwAll err401

服务器启动代码 #

type API auths = (Servant.Auth.Server.Auth auths AuthData :> Protected) :<|> Unprotected
server :: Env -> JWTSettings -> Server (API auths)
server env jwts = protected env :<|> unprotected env jwts

let i_config = Config { appName = "MyApp", version = 1 }
let env = Env {cfg = i_config, pool = pool_}
-- pool <- myResourcePool
print "start servant server http://localhost:8080"
--run 8080 (serve appAPI $ server env)
myKey <- generateKey
let jwtCfg = defaultJWTSettings myKey--jwt_secret
    cfg = defaultCookieSettings :. jwtCfg :. EmptyContext
    api = Proxy :: Proxy (API '[JWT])
run 8080 $ serveWithContext api cfg (server env jwtCfg)

解决方案 #

问题根源在于servant-auth的Auth中间件会为响应添加Set-Cookie头，而servant-checked-exceptions的Throws要求返回Envelope类型，两者的嵌套顺序不匹配：Auth期望返回Headers包裹的结果，但当前代码返回的是Envelope包裹Headers，而类型检查期望的是Headers嵌套包裹Envelope。

调整返回类型嵌套顺序 #

修改处理函数的返回类型，让Headers包裹Envelope，而非反过来：

protected :: Env -> Servant.Auth.Server.AuthResult AuthData -> Server Protected
protected env (Servant.Auth.Server.Authenticated authdata) = test
      where
        test :: Handler (Headers '[Header "Set-Cookie" SetCookie, Header "Set-Cookie" SetCookie] (Envelope '[SomeError] String))
        test = do
            liftIO $ print "test"
            -- 先构造Envelope，再用addHeader添加Cookie头（如果需要）
            let envResp = pureErrEnvelope SomeError
            addHeader (SetCookie { ... }) envResp
protected _ _ = throwAll err401

简化API类型定义 #

如果不需要显式声明Throws，可以直接在Get中指定返回Envelope类型，让servant-checked-exceptions自动处理错误：

type Protected =  "test" 
                 :> Get '[PlainText] (Envelope '[SomeError] String)
                 :<|> ...

这样处理函数只需返回Handler (Envelope '[SomeError] String)，servant-auth会自动将Headers包裹在外层，类型检查就能通过。

使用辅助函数转换类型 #

如果需要保留Throws声明，可以用servant-checked-exceptions提供的handlerToEnvelope或envelopeToHandler调整类型嵌套：

import Servant.Checked.Exceptions (handlerToEnvelope)

test :: Handler (Headers '[Header "Set-Cookie" SetCookie] (Envelope '[SomeError] String))
test = do
    resp <- handlerToEnvelope $ do
        liftIO $ print "test"
        throwError SomeError -- 用普通Handler错误转换为Envelope
    addHeader (SetCookie { ... }) resp

关键是要确保Headers和Envelope的嵌套顺序与API类型的要求一致：当Auth在Throws外层时，Server类型期望的结构是Headers包裹Envelope，而非Envelope包裹Headers。

内容的提问来源于stack exchange，提问作者Dmitry M