如何使用Haskell Warp-TLS实现强制客户端证书认证

你遇到的核心问题有两个：

1. 没有强制要求客户端提供证书：虽然设置了tlsWantClientCert = True，但这个参数只是告诉服务器"请求客户端发送证书"，而非"要求客户端必须提供证书"——客户端可以选择不发送证书，服务器依然会接受连接。
2. 没有验证客户端证书的有效性：你的onClientCertificate钩子直接返回CertificateUsageAccept，不管客户端证书是否由信任的CA签发，甚至客户端不发证书时也会被放行。

另外你提到的TLSSettings使用TLS.ClientParams的疑惑，这是旧版本warp-tls的设计，它内部会将ClientParams适配为服务器端所需的配置，不影响我们正确设置客户端证书验证逻辑。

我们需要修改配置，实现两个核心目标：

• 强制客户端必须提供证书，否则直接拒绝连接
• 验证客户端证书是否由信任的CA（即你的ca.crt）签发

步骤1：加载CA证书作为信任锚 #

首先编写工具函数，将CA证书加载到证书存储中，用于后续验证客户端证书的签名合法性：

import qualified Data.X509 as X509
import qualified Data.X509.CertificateStore as X509
import qualified Data.ByteString.Lazy as LBS

-- 加载CA证书到证书存储，作为验证客户端证书的信任锚
loadCACertStore :: FilePath -> IO X509.CertificateStore
loadCACertStore caPath = do
  caBytes <- LBS.readFile caPath
  case X509.decodeSignedCertificate caBytes of
    Left err -> error $ "Failed to load CA certificate: " ++ show err
    Right signedCert -> return $ X509.makeCertificateStore [X509.getSignedCertificate signedCert]

步骤2：修改TLSSettings配置 #

调整mkSettings函数，添加强制证书要求和完整的证书验证逻辑：

mkSettings :: FilePath -> FilePath -> FilePath -> IO TLSSettings
mkSettings crtFile caFile keyFile = do
  caStore <- loadCACertStore caFile
  let
    -- 验证客户端证书链的回调函数
    verifyClientCert :: [X509.SignedCertificate] -> IO CertificateUsage
    verifyClientCert certChain =
      if null certChain
        then return $ CertificateUsageReject "No client certificate provided"
        else do
          let certs = map X509.getSignedCertificate certChain
              -- 使用CA存储验证证书链的合法性
              verificationResult = X509.verifyCertificate caStore [] certs []
          return $ case verificationResult of
            [] -> CertificateUsageAccept  -- 验证通过，接受证书
            errs -> CertificateUsageReject $ "Client certificate invalid: " ++ show errs

    -- 配置TLS钩子，替换默认的证书处理逻辑
    tlsHooks = def
      { onClientCertificate = verifyClientCert
      }

    -- 创建基础TLS配置并修改关键参数
    baseTlsSettings = tlsSettingsChain crtFile [caFile] keyFile
    finalTlsSettings = baseTlsSettings
      { tlsServerHooks = tlsHooks
      , tlsWantClientCert = True
      , tlsClientCertificateRequired = True  -- 强制要求客户端必须提供证书
      }
  return finalTlsSettings

步骤3：调整main函数适配异步配置 #

因为mkSettings现在返回IO TLSSettings，需要用>>=绑定结果后再启动服务器：

main :: IO ()
main = do
  stngs <- mkSettings "localhost.crt" "ca.crt" "localhost.key"
  let warpOpts = setPort 3443 defaultSettings
  runTLS stngs warpOpts app

• tlsClientCertificateRequired = True：这个参数是实现"无证书拒绝访问"的核心，它会让服务器直接拒绝任何不提供客户端证书的连接请求。
• 证书验证逻辑：verifyClientCert函数先检查是否收到证书链，再用CA存储验证证书的签名有效性——只有由你的ca.crt签发的客户端证书才会被接受。
• 钩子的作用：onClientCertificate钩子在服务器收到客户端证书后触发，我们在这里加入验证逻辑，确保只有合法证书能通过校验。

现在重新测试：

• 无证书请求：curl --verbose --cacert ca.crt https://localhost:3443 会被服务器拒绝
• 带合法客户端证书的请求：curl --verbose --cert client.crt --key client.key --cacert ca.crt https://localhost:3443 可以正常访问

内容的提问来源于stack exchange，提问作者Adrian May