From 48b4e4ad4b9247ca0b4d6d74efb81bbc7c689f42 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Tue, 16 Jun 2026 01:20:59 -0300 Subject: [PATCH 01/36] feat: openssl context --- src/Std/Internal.lean | 1 + src/Std/Internal/SSL.lean | 12 + src/Std/Internal/SSL/Context.lean | 87 ++++++++ src/runtime/CMakeLists.txt | 1 + src/runtime/init_module.cpp | 5 + src/runtime/openssl.h | 7 +- src/runtime/openssl/context.cpp | 349 ++++++++++++++++++++++++++++++ src/runtime/openssl/context.h | 50 +++++ tests/elab/async_ssl_context.lean | 56 +++++ 9 files changed, 567 insertions(+), 1 deletion(-) create mode 100644 src/Std/Internal/SSL.lean create mode 100644 src/Std/Internal/SSL/Context.lean create mode 100644 src/runtime/openssl/context.cpp create mode 100644 src/runtime/openssl/context.h create mode 100644 tests/elab/async_ssl_context.lean diff --git a/src/Std/Internal.lean b/src/Std/Internal.lean index b463046c43ab..463d7dc3c2fb 100644 --- a/src/Std/Internal.lean +++ b/src/Std/Internal.lean @@ -11,6 +11,7 @@ public import Std.Http public import Std.Internal.Parsec public import Std.Internal.UV public import Std.Internal.Do +public import Std.Internal.SSL @[expose] public section diff --git a/src/Std/Internal/SSL.lean b/src/Std/Internal/SSL.lean new file mode 100644 index 000000000000..5d2813784209 --- /dev/null +++ b/src/Std/Internal/SSL.lean @@ -0,0 +1,12 @@ +/- +Copyright (c) 2026 Lean FRO, LLC. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sofia Rodrigues +-/ +module +prelude +public import Std.Internal.SSL.Context + +/-! +Re-exports `Std.Internal.SSL.Context`. +-/ diff --git a/src/Std/Internal/SSL/Context.lean b/src/Std/Internal/SSL/Context.lean new file mode 100644 index 000000000000..739f41c3d09d --- /dev/null +++ b/src/Std/Internal/SSL/Context.lean @@ -0,0 +1,87 @@ +/- +Copyright (c) 2026 Lean FRO, LLC. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sofia Rodrigues +-/ +module +prelude +public import Init.System.Promise + +/-! +OpenSSL context types for server and client TLS sessions. Contexts configure the TLS method, +certificate/key, peer-verification mode, and protocol options shared across all sessions created +from the same context. + +For clients session tickets and TLS compression are disabled globally; TLS 1.2 is the minimum version. +Session resumption and client certificate authentication (mutual TLS) are not supported. +-/ + +public section + +namespace Std.Internal.SSL + +private opaque ContextServerImpl : NonemptyType.{0} + +/-- +Server-side TLS context (`SSL_CTX` configured with `TLS_server_method`). +-/ +def Context.Server : Type := ContextServerImpl.type + +instance : Nonempty Context.Server := ContextServerImpl.property + +private opaque ContextClientImpl : NonemptyType.{0} + +/-- +Client-side TLS context (`SSL_CTX` configured with `TLS_client_method`). +-/ +def Context.Client : Type := ContextClientImpl.type + +instance : Nonempty Context.Client := ContextClientImpl.property + +namespace Context.Server + +/-- +Creates a new server-side TLS context. Only the server certificate is authenticated; Set +`defaultVerify := true` if you want the server context to start with peer verification enabled. +-/ +@[extern "lean_ssl_ctx_mk_server"] +opaque mk (defaultVerify : Bool := false) : IO Context.Server + +/-- +Loads a PEM certificate and private key into a server context. +-/ +@[extern "lean_ssl_ctx_configure_server"] +opaque configure (ctx : @& Context.Server) (certFile : @& String) (keyFile : @& String) : IO Unit + +end Server + +namespace Client + +/-- +Creates a new client-side TLS context. Connecting to a server with a self-signed or unknown CA +certificate will fail unless `configure` is called first with that CA file. +-/ +@[extern "lean_ssl_ctx_mk_client"] +opaque mk (defaultVerify : Bool := true) : IO Context.Client + +/-- +Configures CA trust anchors and peer verification for a client context. `caFile` may be empty to use +platform default trust anchors. +-/ +@[extern "lean_ssl_ctx_configure_client"] +opaque configure (ctx : @& Context.Client) (caFile : @& String) (verifyPeer : Bool) : IO Unit + +/-- +Configures CA trust anchors from an in-memory PEM string instead of a file path. Accepts one or more +PEM-encoded certificates (same format as a CA bundle file). `verifyPeer` works the same as in `configure`. + +Use this when the CA certificate is embedded in the binary rather than on disk. +-/ +@[extern "lean_ssl_ctx_configure_client_from_pem"] +opaque configureFromPEM (ctx : @& Context.Client) (caPEM : @& String) (verifyPeer : Bool) : IO Unit + +end Client +end Context +end Std.Internal.SSL + +end diff --git a/src/runtime/CMakeLists.txt b/src/runtime/CMakeLists.txt index ce171c17b293..06639f199227 100644 --- a/src/runtime/CMakeLists.txt +++ b/src/runtime/CMakeLists.txt @@ -34,6 +34,7 @@ set( uv/system.cpp uv/signal.cpp openssl.cpp + openssl/context.cpp ) if(USE_MIMALLOC) list(APPEND RUNTIME_OBJS ${LEAN_BINARY_DIR}/../mimalloc/src/mimalloc/src/static.c) diff --git a/src/runtime/init_module.cpp b/src/runtime/init_module.cpp index 9ae9afb76390..5a20eb347fdf 100644 --- a/src/runtime/init_module.cpp +++ b/src/runtime/init_module.cpp @@ -14,6 +14,8 @@ Author: Leonardo de Moura #include "runtime/mutex.h" #include "runtime/init_module.h" #include "runtime/libuv.h" +#include "runtime/openssl.h" +#include "runtime/openssl/context.h" namespace lean { extern "C" LEAN_EXPORT void lean_initialize_runtime_module() { @@ -25,6 +27,8 @@ extern "C" LEAN_EXPORT void lean_initialize_runtime_module() { initialize_mutex(); initialize_process(); initialize_stack_overflow(); + initialize_openssl(); + initialize_openssl_context(); initialize_libuv(); } void initialize_runtime_module() { @@ -32,6 +36,7 @@ void initialize_runtime_module() { } void finalize_runtime_module() { finalize_stack_overflow(); + finalize_openssl(); finalize_process(); finalize_mutex(); finalize_thread(); diff --git a/src/runtime/openssl.h b/src/runtime/openssl.h index b7d091941f35..a05b27cf241e 100644 --- a/src/runtime/openssl.h +++ b/src/runtime/openssl.h @@ -6,4 +6,9 @@ Author: Sofia Rodrigues #pragma once #include -extern "C" LEAN_EXPORT lean_obj_res lean_openssl_version(lean_obj_arg); \ No newline at end of file +namespace lean { +void initialize_openssl(); +void finalize_openssl(); +} + +extern "C" LEAN_EXPORT lean_obj_res lean_openssl_version(lean_obj_arg); diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp new file mode 100644 index 000000000000..79e335935d6f --- /dev/null +++ b/src/runtime/openssl/context.cpp @@ -0,0 +1,349 @@ +/* +Copyright (c) 2026 Lean FRO, LLC. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Sofia Rodrigues +*/ + +#include "runtime/openssl/context.h" +#include +#include +#include +#include + +namespace lean { + +lean_external_class * g_ssl_context_external_class = NULL; + +#ifndef LEAN_EMSCRIPTEN + +// This function drains at maximum 10 error messages from the Error queue. +lean_object * mk_openssl_error(char const * where, int ssl_err = 0) { + std::string msg(where); + + if (ssl_err != 0) msg += " (ssl_error=" + std::to_string(ssl_err) + ")"; + + // Drain the full OpenSSL error queue. + unsigned long err; + bool first = true; + int cap = 10; + + while (cap-- > 0 && (err = ERR_get_error()) != 0) { + char err_buf[256]; + ERR_error_string_n(err, err_buf, sizeof(err_buf)); + msg += first ? ": " : "; "; + msg += err_buf; + first = false; + } + + if (!first && ERR_peek_error() != 0) { + msg += "; ... (truncated)"; + ERR_clear_error(); + } + + return lean_mk_io_user_error(mk_string(msg.c_str())); +} + +static void lean_ssl_context_finalizer(void * ptr) { + lean_ssl_context_object * obj = (lean_ssl_context_object*)ptr; + SSL_CTX_free(obj->ctx); + free(obj); +} + +void initialize_openssl_context() { + g_ssl_context_external_class = lean_register_external_class(lean_ssl_context_finalizer, [](void * obj, lean_object * f) { + (void)obj; + (void)f; + }); +} + +static bool configure_ctx_options(SSL_CTX * ctx) { + SSL_CTX_set_options(ctx, + // Disables TLS 1.2 renegotiation (SSL_OP_NO_RENEGOTIATION has no effect on + // TLS 1.3, which replaced renegotiation with key updates). + SSL_OP_NO_RENEGOTIATION | + + // Disables TLS compression. Mitigates the CRIME attack (compression leaks + // secret bytes via ciphertext length). Already off by default in OpenSSL 1.1+ + // but set explicitly so the intent is clear. + SSL_OP_NO_COMPRESSION | + + // Disables session tickets (TLS 1.2 RFC 5077 and TLS 1.3 PSK resumption). + // This prevents 0-RTT session resumption but avoids stateful ticket + // management complexity and removes one tracking vector in server deployments. + // If session resumption performance matters, remove this flag and implement + // a ticket key rotation strategy. + SSL_OP_NO_TICKET + ); + + // Reject TLS 1.0 and 1.1. Both are deprecated (RFC 8996) and have known + // protocol-level weaknesses (BEAST, POODLE). TLS 1.2 is the minimum acceptable + // version; TLS 1.3 is preferred and used automatically when both peers support it. + if (SSL_CTX_set_min_proto_version(ctx, TLS1_2_VERSION) != 1) return false; + + // Allow SSL_write to be retried with a different pointer when the same + // payload is copied into pending_writes and replayed after WANT_READ/WANT_WRITE. + SSL_CTX_set_mode(ctx, SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER); + return true; +} + +static lean_obj_res mk_ssl_context(const SSL_METHOD * method, bool default_verify) { + SSL_CTX * ctx = SSL_CTX_new(method); + + if (ctx == nullptr) { + return mk_openssl_io_error("SSL_CTX_new failed"); + } + + if (!configure_ctx_options(ctx)) { + SSL_CTX_free(ctx); + return mk_openssl_io_error("SSL_CTX_set_min_proto_version failed"); + } + + if (default_verify) { + + // Secure default: verify the peer certificate against system trust anchors. + // Callers that need to skip verification must call configure() with verifyPeer=false, + // which calls SSL_CTX_set_verify(SSL_VERIFY_NONE) and overrides this setting. + if (SSL_CTX_set_default_verify_paths(ctx) != 1) { + SSL_CTX_free(ctx); + return mk_openssl_io_error("SSL_CTX_set_default_verify_paths failed"); + } + + SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER, nullptr); + } + + lean_ssl_context_object * obj = (lean_ssl_context_object*)malloc(sizeof(lean_ssl_context_object)); + + if (obj == nullptr) { + SSL_CTX_free(ctx); + return mk_openssl_io_error("failed to allocate SSL context object"); + } + + obj->ctx = ctx; + lean_object * lean_obj = lean_ssl_context_object_new(obj); + lean_mark_mt(lean_obj); + + return lean_io_result_mk_ok(lean_obj); +} + +/* Std.Internal.SSL.Context.mkServer : IO Context */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(uint8_t default_verify) { + return mk_ssl_context(TLS_server_method(), default_verify != 0); +} + +/* Std.Internal.SSL.Context.mkClient : IO Context */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(uint8_t default_verify) { + // Client contexts default to SSL_VERIFY_PEER with system trust anchors. + return mk_ssl_context(TLS_client_method(), default_verify != 0); +} + +/* Std.Internal.SSL.Context.configureServer (ctx : @& Context) (certFile keyFile : @& String) : IO Unit */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_server(b_obj_arg ctx_obj, b_obj_arg cert_file, b_obj_arg key_file) { + ERR_clear_error(); + + lean_ssl_context_object * obj = lean_to_ssl_context_object(ctx_obj); + const char * cert = lean_string_cstr(cert_file); + const char * key = lean_string_cstr(key_file); + + + // use_certificate_chain_file loads the leaf + any intermediates from the PEM file, + // so clients receive the full chain and can build OCSP cert IDs without a separate CA fetch. + if (SSL_CTX_use_certificate_chain_file(obj->ctx, cert) <= 0) { + return mk_openssl_io_error("SSL_CTX_use_certificate_chain_file failed"); + } + + if (SSL_CTX_use_PrivateKey_file(obj->ctx, key, SSL_FILETYPE_PEM) <= 0) { + return mk_openssl_io_error("SSL_CTX_use_PrivateKey_file failed"); + } + + if (SSL_CTX_check_private_key(obj->ctx) != 1) { + return mk_openssl_io_error("SSL_CTX_check_private_key failed"); + } + + return lean_io_result_mk_ok(lean_box(0)); +} + +/* Std.Internal.SSL.Context.configureClient (ctx : @& Context) (caFile : @& String) (verifyPeer : Bool) : IO Unit */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client(b_obj_arg ctx_obj, b_obj_arg ca_file, uint8_t verify_peer) { + ERR_clear_error(); + + lean_ssl_context_object * obj = lean_to_ssl_context_object(ctx_obj); + const char * ca = lean_string_cstr(ca_file); + + if (ca != nullptr && ca[0] != '\0') { + if (SSL_CTX_load_verify_locations(obj->ctx, ca, nullptr) != 1) { + return mk_openssl_io_error("SSL_CTX_load_verify_locations failed"); + } + } else if (verify_peer) { + if (SSL_CTX_set_default_verify_paths(obj->ctx) != 1) { + return mk_openssl_io_error("SSL_CTX_set_default_verify_paths failed"); + } + } + + SSL_CTX_set_verify(obj->ctx, verify_peer ? SSL_VERIFY_PEER : SSL_VERIFY_NONE, nullptr); + return lean_io_result_mk_ok(lean_box(0)); +} + +/* Std.Internal.SSL.Context.configureClientFromPEM (ctx : @& Context) (caPEM : @& String) (verifyPeer : Bool) : IO Unit */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj_arg ctx_obj, b_obj_arg ca_pem, uint8_t verify_peer) { + ERR_clear_error(); + + lean_ssl_context_object * obj = lean_to_ssl_context_object(ctx_obj); + const char * pem = lean_string_cstr(ca_pem); + size_t pem_size = lean_string_size(ca_pem) - 1; + + if (pem_size == 0) { + if (!verify_peer) { + SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_NONE, nullptr); + return lean_io_result_mk_ok(lean_box(0)); + } + + X509_STORE * store = X509_STORE_new(); + if (store == nullptr) { + return mk_openssl_io_error("X509_STORE_new failed"); + } + + if (X509_STORE_set_default_paths(store) != 1) { + X509_STORE_free(store); + return mk_openssl_io_error("X509_STORE_set_default_paths failed"); + } + + SSL_CTX_set_cert_store(obj->ctx, store); + SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_PEER, nullptr); + return lean_io_result_mk_ok(lean_box(0)); + } + + if (pem_size > INT_MAX) { + return mk_openssl_io_error("CA PEM string is too large"); + } + + BIO * bio = BIO_new_mem_buf(pem, (int)pem_size); + + if (bio == nullptr) { + return mk_openssl_io_error("BIO_new_mem_buf failed"); + } + + STACK_OF(X509_INFO) * infos = PEM_X509_INFO_read_bio(bio, nullptr, nullptr, nullptr); + + BIO_free(bio); + + if (infos == nullptr) { + return mk_openssl_io_error("PEM_X509_INFO_read_bio failed"); + } + + // Store so we can rollback in case something fails! + X509_STORE * store = X509_STORE_new(); + + if (store == nullptr) { + sk_X509_INFO_pop_free(infos, X509_INFO_free); + return mk_openssl_io_error("X509_STORE_new failed"); + } + + if (verify_peer && X509_STORE_set_default_paths(store) != 1) { + sk_X509_INFO_pop_free(infos, X509_INFO_free); + X509_STORE_free(store); + return mk_openssl_io_error("X509_STORE_set_default_paths failed"); + } + + int cert_count = 0; + + for (int i = 0; i < sk_X509_INFO_num(infos); i++) { + X509_INFO * info = sk_X509_INFO_value(infos, i); + if (info->x509 == nullptr) continue; + cert_count++; + + if (X509_STORE_add_cert(store, info->x509) != 1) { + unsigned long err = ERR_peek_last_error(); + if (ERR_GET_LIB(err) == ERR_LIB_X509 && ERR_GET_REASON(err) == X509_R_CERT_ALREADY_IN_HASH_TABLE) { + ERR_clear_error(); + continue; + } + + sk_X509_INFO_pop_free(infos, X509_INFO_free); + X509_STORE_free(store); + return mk_openssl_io_error("X509_STORE_add_cert failed"); + } + } + + sk_X509_INFO_pop_free(infos, X509_INFO_free); + + if (cert_count == 0) { + X509_STORE_free(store); + return mk_openssl_io_error("no certificates found in CA PEM"); + } + + SSL_CTX_set_cert_store(obj->ctx, store); + + SSL_CTX_set_verify(obj->ctx, verify_peer ? SSL_VERIFY_PEER : SSL_VERIFY_NONE, nullptr); + return lean_io_result_mk_ok(lean_box(0)); +} + +/* Std.Internal.SSL.Context.Client.configureCRL (ctx : @& Context.Client) (crlPEM : @& String) : IO Unit */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_crl(b_obj_arg ctx_obj, b_obj_arg crl_pem) { + ERR_clear_error(); + + lean_ssl_context_object * obj = lean_to_ssl_context_object(ctx_obj); + const char * pem = lean_string_cstr(crl_pem); + size_t pem_size = lean_string_size(crl_pem) - 1; + + if (pem_size > INT_MAX) { + return mk_openssl_io_error("CRL PEM string is too large"); + } + + BIO * bio = BIO_new_mem_buf(pem, (int)pem_size); + if (bio == nullptr) { + return mk_openssl_io_error("BIO_new_mem_buf (CRL) failed"); + } + + X509_CRL * crl = PEM_read_bio_X509_CRL(bio, nullptr, nullptr, nullptr); + BIO_free(bio); + + if (crl == nullptr) { + return mk_openssl_io_error("PEM_read_bio_X509_CRL failed"); + } + + X509_STORE * store = SSL_CTX_get_cert_store(obj->ctx); + + if (X509_STORE_add_crl(store, crl) != 1) { + X509_CRL_free(crl); + return mk_openssl_io_error("X509_STORE_add_crl failed"); + } + + X509_CRL_free(crl); + + // Check the CRL for the leaf certificate and every CA in the chain. + X509_STORE_set_flags(store, X509_V_FLAG_CRL_CHECK | X509_V_FLAG_CRL_CHECK_ALL); + + return lean_io_result_mk_ok(lean_box(0)); +} + +#else + +void initialize_openssl_context() {} + +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(uint8_t /*default_verify*/) { + lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); +} + +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(uint8_t /*default_verify*/) { + lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); +} + +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_server(b_obj_arg /*ctx_obj*/, b_obj_arg /*cert_file*/, b_obj_arg /*key_file*/) { + lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); +} + +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client(b_obj_arg /*ctx_obj*/, b_obj_arg /*ca_file*/, uint8_t /*verify_peer*/) { + lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); +} + +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj_arg /*ctx_obj*/, b_obj_arg /*ca_pem*/, uint8_t /*verify_peer*/) { + lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); +} + +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_crl(b_obj_arg /*ctx_obj*/, b_obj_arg /*crl_file*/) { + lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); +} + +#endif + +} diff --git a/src/runtime/openssl/context.h b/src/runtime/openssl/context.h new file mode 100644 index 000000000000..9538476d20a7 --- /dev/null +++ b/src/runtime/openssl/context.h @@ -0,0 +1,50 @@ +/* +Copyright (c) 2026 Lean FRO, LLC. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Sofia Rodrigues +*/ +#pragma once + +#include +#include "runtime/io.h" +#include "runtime/object.h" +#include "runtime/openssl.h" + +#ifndef LEAN_EMSCRIPTEN +#include +#include +#include +#endif + +namespace lean { + +extern lean_external_class * g_ssl_context_external_class; +void initialize_openssl_context(); + +#ifndef LEAN_EMSCRIPTEN + +// Structure for mananing a single Context object. +typedef struct { + SSL_CTX * ctx; +} lean_ssl_context_object; + +// This function drains the openssl error queue and return a single error message with a bunch of +// them. + +lean_object * mk_openssl_error(char const * where, int ssl_err); +static inline lean_obj_res mk_openssl_io_error(char const * where, int ssl_err = 0) { return lean_io_result_mk_error(mk_openssl_error(where, ssl_err)); } +static inline lean_object * lean_ssl_context_object_new(lean_ssl_context_object * c) { return lean_alloc_external(g_ssl_context_external_class, c); } +static inline lean_ssl_context_object * lean_to_ssl_context_object(lean_object * o) { return (lean_ssl_context_object*)(lean_get_external_data(o)); } +#endif + +// ======================================= +// Context Operations + +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(uint8_t default_verify); +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(uint8_t default_verify); +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_server(b_obj_arg ctx, b_obj_arg cert_file, b_obj_arg key_file); +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client(b_obj_arg ctx, b_obj_arg ca_file, uint8_t verify_peer); +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj_arg ctx, b_obj_arg ca_pem, uint8_t verify_peer); +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_crl(b_obj_arg ctx, b_obj_arg crl_file); + +} diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean new file mode 100644 index 000000000000..4a86d4a72031 --- /dev/null +++ b/tests/elab/async_ssl_context.lean @@ -0,0 +1,56 @@ +import Std.Internal.SSL + +/-! +Tests for `Std.Internal.SSL.Context`: TLS context creation and configuration. + +This is the Context-only layer split out of #13112 (`TCP.SSL`); session and socket +behaviour are exercised in separate test files. +-/ + +open Std.Internal.SSL + +-- Generate a self-signed certificate for testing (cached: skips generation if files exist). +def setupTestCerts : IO (String × String) := do + IO.FS.createDirAll "/tmp/lean_ssl_test" + let keyFile := "/tmp/lean_ssl_test/key.pem" + let certFile := "/tmp/lean_ssl_test/cert.pem" + + let keyExists ← System.FilePath.pathExists keyFile + let certExists ← System.FilePath.pathExists certFile + unless keyExists && certExists do + discard <| IO.Process.output { + cmd := "openssl" + args := #["genrsa", "-out", keyFile, "2048"] + } + discard <| IO.Process.output { + cmd := "openssl" + args := #["req", "-new", "-x509", "-key", keyFile, "-out", certFile, "-days", "1", "-subj", "/CN=localhost"] + } + + return (certFile, keyFile) + +-- Context creation and configuration (smoke test). +def testContextCreation (certFile keyFile : String) : IO Unit := do + let serverCtx ← Context.Server.mk + serverCtx.configure certFile keyFile + + let clientCtx ← Context.Client.mk + clientCtx.configure "" false + + -- Configuring with a CA file path (non-empty) exercises the other branch. + let clientCtx2 ← Context.Client.mk + clientCtx2.configure certFile false + +-- Configuring a client from an in-memory PEM string. +def testConfigureClientFromPEM (certFile : String) : IO Unit := do + let caPEM ← IO.FS.readFile certFile + let clientCtx ← Context.Client.mk + clientCtx.configureFromPEM caPEM true + +#eval do + let (certFile, keyFile) ← setupTestCerts + testContextCreation certFile keyFile + +#eval do + let (certFile, _) ← setupTestCerts + testConfigureClientFromPEM certFile From bd5ac4702acbd2ebf88740489160477e449a2a33 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Tue, 16 Jun 2026 01:22:23 -0300 Subject: [PATCH 02/36] style: remove useless comment --- src/Std/Internal/SSL.lean | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Std/Internal/SSL.lean b/src/Std/Internal/SSL.lean index 5d2813784209..d7a66cec1273 100644 --- a/src/Std/Internal/SSL.lean +++ b/src/Std/Internal/SSL.lean @@ -6,7 +6,3 @@ Authors: Sofia Rodrigues module prelude public import Std.Internal.SSL.Context - -/-! -Re-exports `Std.Internal.SSL.Context`. --/ From 03ce4e325c74ad850a8b158e531c3abeb327ae84 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Tue, 16 Jun 2026 07:03:45 -0300 Subject: [PATCH 03/36] refactor: remove CRL related functions --- src/Std/Internal/SSL/Context.lean | 2 +- src/runtime/openssl/context.cpp | 44 ------------------------------- src/runtime/openssl/context.h | 3 +-- 3 files changed, 2 insertions(+), 47 deletions(-) diff --git a/src/Std/Internal/SSL/Context.lean b/src/Std/Internal/SSL/Context.lean index 739f41c3d09d..5df8dd17e59b 100644 --- a/src/Std/Internal/SSL/Context.lean +++ b/src/Std/Internal/SSL/Context.lean @@ -41,7 +41,7 @@ instance : Nonempty Context.Client := ContextClientImpl.property namespace Context.Server /-- -Creates a new server-side TLS context. Only the server certificate is authenticated; Set +Creates a new server-side TLS context. Only the server certificate is authenticated; set `defaultVerify := true` if you want the server context to start with peer verification enabled. -/ @[extern "lean_ssl_ctx_mk_server"] diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 79e335935d6f..10218a7c56cb 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -144,7 +144,6 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_server(b_obj_arg ctx_ const char * cert = lean_string_cstr(cert_file); const char * key = lean_string_cstr(key_file); - // use_certificate_chain_file loads the leaf + any intermediates from the PEM file, // so clients receive the full chain and can build OCSP cert IDs without a separate CA fetch. if (SSL_CTX_use_certificate_chain_file(obj->ctx, cert) <= 0) { @@ -277,45 +276,6 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj return lean_io_result_mk_ok(lean_box(0)); } -/* Std.Internal.SSL.Context.Client.configureCRL (ctx : @& Context.Client) (crlPEM : @& String) : IO Unit */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_crl(b_obj_arg ctx_obj, b_obj_arg crl_pem) { - ERR_clear_error(); - - lean_ssl_context_object * obj = lean_to_ssl_context_object(ctx_obj); - const char * pem = lean_string_cstr(crl_pem); - size_t pem_size = lean_string_size(crl_pem) - 1; - - if (pem_size > INT_MAX) { - return mk_openssl_io_error("CRL PEM string is too large"); - } - - BIO * bio = BIO_new_mem_buf(pem, (int)pem_size); - if (bio == nullptr) { - return mk_openssl_io_error("BIO_new_mem_buf (CRL) failed"); - } - - X509_CRL * crl = PEM_read_bio_X509_CRL(bio, nullptr, nullptr, nullptr); - BIO_free(bio); - - if (crl == nullptr) { - return mk_openssl_io_error("PEM_read_bio_X509_CRL failed"); - } - - X509_STORE * store = SSL_CTX_get_cert_store(obj->ctx); - - if (X509_STORE_add_crl(store, crl) != 1) { - X509_CRL_free(crl); - return mk_openssl_io_error("X509_STORE_add_crl failed"); - } - - X509_CRL_free(crl); - - // Check the CRL for the leaf certificate and every CA in the chain. - X509_STORE_set_flags(store, X509_V_FLAG_CRL_CHECK | X509_V_FLAG_CRL_CHECK_ALL); - - return lean_io_result_mk_ok(lean_box(0)); -} - #else void initialize_openssl_context() {} @@ -340,10 +300,6 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); } -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_crl(b_obj_arg /*ctx_obj*/, b_obj_arg /*crl_file*/) { - lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); -} - #endif } diff --git a/src/runtime/openssl/context.h b/src/runtime/openssl/context.h index 9538476d20a7..d6495ee28ac1 100644 --- a/src/runtime/openssl/context.h +++ b/src/runtime/openssl/context.h @@ -23,7 +23,7 @@ void initialize_openssl_context(); #ifndef LEAN_EMSCRIPTEN -// Structure for mananing a single Context object. +// Structure for managing a single Context object. typedef struct { SSL_CTX * ctx; } lean_ssl_context_object; @@ -45,6 +45,5 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(uint8_t default_verif extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_server(b_obj_arg ctx, b_obj_arg cert_file, b_obj_arg key_file); extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client(b_obj_arg ctx, b_obj_arg ca_file, uint8_t verify_peer); extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj_arg ctx, b_obj_arg ca_pem, uint8_t verify_peer); -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_crl(b_obj_arg ctx, b_obj_arg crl_file); } From 63285969d1a5158b592a1c59b6ea23efe6e5c44f Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Tue, 16 Jun 2026 09:29:46 -0300 Subject: [PATCH 04/36] feat: enable verifyPeer, it doesnt add system rots when it's not empty --- src/Std/Internal/SSL/Context.lean | 17 +++++++++++--- src/runtime/openssl/context.cpp | 18 ++++++++------- tests/elab/async_ssl_context.lean | 38 +++++++++++++++++++++++++++++++ 3 files changed, 62 insertions(+), 11 deletions(-) diff --git a/src/Std/Internal/SSL/Context.lean b/src/Std/Internal/SSL/Context.lean index 5df8dd17e59b..38850bb93fb8 100644 --- a/src/Std/Internal/SSL/Context.lean +++ b/src/Std/Internal/SSL/Context.lean @@ -65,15 +65,26 @@ certificate will fail unless `configure` is called first with that CA file. opaque mk (defaultVerify : Bool := true) : IO Context.Client /-- -Configures CA trust anchors and peer verification for a client context. `caFile` may be empty to use -platform default trust anchors. +Configures CA trust anchors and peer verification for a client context. + +Trust-anchor semantics: +- A non-empty `caFile` pins trust to exactly those CA certificates; the platform default trust + anchors are **not** added. +- An empty `caFile` with `verifyPeer := true` uses the platform default trust anchors. +- `verifyPeer := false` disables peer verification entirely. -/ @[extern "lean_ssl_ctx_configure_client"] opaque configure (ctx : @& Context.Client) (caFile : @& String) (verifyPeer : Bool) : IO Unit /-- Configures CA trust anchors from an in-memory PEM string instead of a file path. Accepts one or more -PEM-encoded certificates (same format as a CA bundle file). `verifyPeer` works the same as in `configure`. +PEM-encoded certificates (same format as a CA bundle file). + +Trust-anchor semantics match `configure`: +- A non-empty `caPEM` pins trust to exactly those CA certificates; the platform default trust + anchors are **not** added. +- An empty `caPEM` with `verifyPeer := true` uses the platform default trust anchors. +- `verifyPeer := false` disables peer verification entirely (the PEM is not parsed). Use this when the CA certificate is embedded in the binary rather than on disk. -/ diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 10218a7c56cb..674bf7cc4b1c 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -215,6 +215,13 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj return mk_openssl_io_error("CA PEM string is too large"); } + // Without peer verification the supplied CA certificates would never be consulted, so skip + // parsing them and just disable verification (mirrors the empty-PEM and file-based paths). + if (!verify_peer) { + SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_NONE, nullptr); + return lean_io_result_mk_ok(lean_box(0)); + } + BIO * bio = BIO_new_mem_buf(pem, (int)pem_size); if (bio == nullptr) { @@ -237,12 +244,8 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj return mk_openssl_io_error("X509_STORE_new failed"); } - if (verify_peer && X509_STORE_set_default_paths(store) != 1) { - sk_X509_INFO_pop_free(infos, X509_INFO_free); - X509_STORE_free(store); - return mk_openssl_io_error("X509_STORE_set_default_paths failed"); - } - + // A non-empty CA bundle pins trust to exactly these certificates; system trust anchors are + // intentionally not added, matching the file-based `configure` ("only this CA") behavior. int cert_count = 0; for (int i = 0; i < sk_X509_INFO_num(infos); i++) { @@ -271,8 +274,7 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj } SSL_CTX_set_cert_store(obj->ctx, store); - - SSL_CTX_set_verify(obj->ctx, verify_peer ? SSL_VERIFY_PEER : SSL_VERIFY_NONE, nullptr); + SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_PEER, nullptr); return lean_io_result_mk_ok(lean_box(0)); } diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index 4a86d4a72031..c2f3edaf1a8f 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -47,6 +47,34 @@ def testConfigureClientFromPEM (certFile : String) : IO Unit := do let clientCtx ← Context.Client.mk clientCtx.configureFromPEM caPEM true +-- Asserts that an IO action fails, used to exercise the rejection/error paths. +def assertThrows (label : String) (act : IO Unit) : IO Unit := do + match ← act.toBaseIO with + | .ok _ => throw <| IO.userError s!"{label}: expected failure, but it succeeded" + | .error _ => pure () + +-- An empty CA bundle with `verifyPeer := true` falls back to the platform trust anchors and succeeds. +def testConfigureFromPEMEmptyFallsBack : IO Unit := do + let clientCtx ← Context.Client.mk + clientCtx.configureFromPEM "" true + +-- `verifyPeer := false` succeeds without parsing the CA material, even for a real bundle. +def testConfigureFromPEMNoVerify (certFile : String) : IO Unit := do + let caPEM ← IO.FS.readFile certFile + let clientCtx ← Context.Client.mk + clientCtx.configureFromPEM caPEM false + +-- Malformed PEM input is rejected rather than silently ignored. +def testConfigureFromPEMRejectsGarbage : IO Unit := do + let clientCtx ← Context.Client.mk + assertThrows "garbage PEM" (clientCtx.configureFromPEM "not a certificate at all" true) + +-- A well-formed PEM block that contains no certificate is rejected. +def testConfigureFromPEMRejectsEmptyBlock : IO Unit := do + let clientCtx ← Context.Client.mk + assertThrows "PEM without certificates" + (clientCtx.configureFromPEM "-----BEGIN CERTIFICATE-----\n-----END CERTIFICATE-----\n" true) + #eval do let (certFile, keyFile) ← setupTestCerts testContextCreation certFile keyFile @@ -54,3 +82,13 @@ def testConfigureClientFromPEM (certFile : String) : IO Unit := do #eval do let (certFile, _) ← setupTestCerts testConfigureClientFromPEM certFile + +#eval testConfigureFromPEMEmptyFallsBack + +#eval do + let (certFile, _) ← setupTestCerts + testConfigureFromPEMNoVerify certFile + +#eval testConfigureFromPEMRejectsGarbage + +#eval testConfigureFromPEMRejectsEmptyBlock From 7ca2c143297dfa3c3421a1eab1cd117d52c3c803 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Thu, 18 Jun 2026 06:46:46 -0300 Subject: [PATCH 05/36] test: fix path of tests --- tests/elab/async_ssl_context.lean | 34 +++++++++++++++++-------------- 1 file changed, 19 insertions(+), 15 deletions(-) diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index c2f3edaf1a8f..2e8e0a9df2d2 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -11,21 +11,25 @@ open Std.Internal.SSL -- Generate a self-signed certificate for testing (cached: skips generation if files exist). def setupTestCerts : IO (String × String) := do - IO.FS.createDirAll "/tmp/lean_ssl_test" - let keyFile := "/tmp/lean_ssl_test/key.pem" - let certFile := "/tmp/lean_ssl_test/cert.pem" - - let keyExists ← System.FilePath.pathExists keyFile - let certExists ← System.FilePath.pathExists certFile - unless keyExists && certExists do - discard <| IO.Process.output { - cmd := "openssl" - args := #["genrsa", "-out", keyFile, "2048"] - } - discard <| IO.Process.output { - cmd := "openssl" - args := #["req", "-new", "-x509", "-key", keyFile, "-out", certFile, "-days", "1", "-subj", "/CN=localhost"] - } + let pid ← IO.Process.getPID + let dir := s!"/tmp/lean_ssl_test_{pid}" + IO.FS.createDirAll dir + let keyFile := s!"{dir}/key.pem" + let certFile := s!"{dir}/cert.pem" + + let keyOut ← IO.Process.output { + cmd := "openssl" + args := #["genrsa", "-out", keyFile, "2048"] + } + unless keyOut.exitCode == 0 do + throw <| IO.userError s!"openssl genrsa failed: {keyOut.stderr}" + + let certOut ← IO.Process.output { + cmd := "openssl" + args := #["req", "-new", "-x509", "-key", keyFile, "-out", certFile, "-days", "1", "-subj", "/CN=localhost"] + } + unless certOut.exitCode == 0 do + throw <| IO.userError s!"openssl req failed: {certOut.stderr}" return (certFile, keyFile) From 7827493fbcc5e053454f37f79949a957bb85fbdc Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Thu, 18 Jun 2026 06:54:27 -0300 Subject: [PATCH 06/36] test: tempdir for tests --- tests/elab/async_ssl_context.lean | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index 2e8e0a9df2d2..43cb6f723520 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -11,11 +11,9 @@ open Std.Internal.SSL -- Generate a self-signed certificate for testing (cached: skips generation if files exist). def setupTestCerts : IO (String × String) := do - let pid ← IO.Process.getPID - let dir := s!"/tmp/lean_ssl_test_{pid}" - IO.FS.createDirAll dir - let keyFile := s!"{dir}/key.pem" - let certFile := s!"{dir}/cert.pem" + let dir ← IO.FS.createTempDir + let keyFile := toString (dir / "key.pem") + let certFile := toString (dir / "cert.pem") let keyOut ← IO.Process.output { cmd := "openssl" From 68ebe802617b99532bfd39a5cad3f8583ff9a63a Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Fri, 26 Jun 2026 07:53:33 -0300 Subject: [PATCH 07/36] fix: suggesitions and more clear error queue --- src/Std/Internal/SSL/Context.lean | 4 ++-- src/runtime/openssl/context.cpp | 16 +++++++++------- src/runtime/openssl/context.h | 4 +--- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Std/Internal/SSL/Context.lean b/src/Std/Internal/SSL/Context.lean index 38850bb93fb8..6e50e70a3e5f 100644 --- a/src/Std/Internal/SSL/Context.lean +++ b/src/Std/Internal/SSL/Context.lean @@ -12,8 +12,8 @@ OpenSSL context types for server and client TLS sessions. Contexts configure the certificate/key, peer-verification mode, and protocol options shared across all sessions created from the same context. -For clients session tickets and TLS compression are disabled globally; TLS 1.2 is the minimum version. -Session resumption and client certificate authentication (mutual TLS) are not supported. +For every context session tickets and TLS compression are disabled and TLS 1.2 is the minimum +version. Session resumption is therefore not supported. -/ public section diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 674bf7cc4b1c..f08df898fcec 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -22,7 +22,7 @@ lean_object * mk_openssl_error(char const * where, int ssl_err = 0) { if (ssl_err != 0) msg += " (ssl_error=" + std::to_string(ssl_err) + ")"; - // Drain the full OpenSSL error queue. + // Drain up to 10 entries from the OpenSSL error queue; mark with "(truncated)" if more remain. unsigned long err; bool first = true; int cap = 10; @@ -87,6 +87,8 @@ static bool configure_ctx_options(SSL_CTX * ctx) { } static lean_obj_res mk_ssl_context(const SSL_METHOD * method, bool default_verify) { + ERR_clear_error(); + SSL_CTX * ctx = SSL_CTX_new(method); if (ctx == nullptr) { @@ -125,18 +127,18 @@ static lean_obj_res mk_ssl_context(const SSL_METHOD * method, bool default_verif return lean_io_result_mk_ok(lean_obj); } -/* Std.Internal.SSL.Context.mkServer : IO Context */ +/* Std.Internal.SSL.Context.Server.mk (defaultVerify : Bool) : IO Context.Server */ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(uint8_t default_verify) { return mk_ssl_context(TLS_server_method(), default_verify != 0); } -/* Std.Internal.SSL.Context.mkClient : IO Context */ +/* Std.Internal.SSL.Context.Client.mk (defaultVerify : Bool) : IO Context.Client */ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(uint8_t default_verify) { - // Client contexts default to SSL_VERIFY_PEER with system trust anchors. + // With default_verify set, the client verifies the peer against system trust anchors. return mk_ssl_context(TLS_client_method(), default_verify != 0); } -/* Std.Internal.SSL.Context.configureServer (ctx : @& Context) (certFile keyFile : @& String) : IO Unit */ +/* Std.Internal.SSL.Context.Server.configure (ctx : @& Context.Server) (certFile keyFile : @& String) : IO Unit */ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_server(b_obj_arg ctx_obj, b_obj_arg cert_file, b_obj_arg key_file) { ERR_clear_error(); @@ -161,7 +163,7 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_server(b_obj_arg ctx_ return lean_io_result_mk_ok(lean_box(0)); } -/* Std.Internal.SSL.Context.configureClient (ctx : @& Context) (caFile : @& String) (verifyPeer : Bool) : IO Unit */ +/* Std.Internal.SSL.Context.Client.configure (ctx : @& Context.Client) (caFile : @& String) (verifyPeer : Bool) : IO Unit */ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client(b_obj_arg ctx_obj, b_obj_arg ca_file, uint8_t verify_peer) { ERR_clear_error(); @@ -182,7 +184,7 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client(b_obj_arg ctx_ return lean_io_result_mk_ok(lean_box(0)); } -/* Std.Internal.SSL.Context.configureClientFromPEM (ctx : @& Context) (caPEM : @& String) (verifyPeer : Bool) : IO Unit */ +/* Std.Internal.SSL.Context.Client.configureFromPEM (ctx : @& Context.Client) (caPEM : @& String) (verifyPeer : Bool) : IO Unit */ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj_arg ctx_obj, b_obj_arg ca_pem, uint8_t verify_peer) { ERR_clear_error(); diff --git a/src/runtime/openssl/context.h b/src/runtime/openssl/context.h index d6495ee28ac1..ec4797685106 100644 --- a/src/runtime/openssl/context.h +++ b/src/runtime/openssl/context.h @@ -28,9 +28,7 @@ typedef struct { SSL_CTX * ctx; } lean_ssl_context_object; -// This function drains the openssl error queue and return a single error message with a bunch of -// them. - +// Drains the OpenSSL error queue and returns a single error message combining up to 10 entries. lean_object * mk_openssl_error(char const * where, int ssl_err); static inline lean_obj_res mk_openssl_io_error(char const * where, int ssl_err = 0) { return lean_io_result_mk_error(mk_openssl_error(where, ssl_err)); } static inline lean_object * lean_ssl_context_object_new(lean_ssl_context_object * c) { return lean_alloc_external(g_ssl_context_external_class, c); } From 76dea5711d1b290b4a0109e3dd4f09ece590f502 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Fri, 26 Jun 2026 15:02:07 -0300 Subject: [PATCH 08/36] fix: read system certificate instead of OpenSSL bundle --- src/Std/Internal/SSL/Context.lean | 34 ++++-- src/runtime/openssl/context.cpp | 190 +++++++++++++++++++++--------- src/runtime/openssl/context.h | 4 +- tests/elab/async_ssl_context.lean | 20 +++- 4 files changed, 175 insertions(+), 73 deletions(-) diff --git a/src/Std/Internal/SSL/Context.lean b/src/Std/Internal/SSL/Context.lean index 6e50e70a3e5f..21d2b66a0da3 100644 --- a/src/Std/Internal/SSL/Context.lean +++ b/src/Std/Internal/SSL/Context.lean @@ -5,14 +5,14 @@ Authors: Sofia Rodrigues -/ module prelude -public import Init.System.Promise +public import Init.System.IO /-! OpenSSL context types for server and client TLS sessions. Contexts configure the TLS method, certificate/key, peer-verification mode, and protocol options shared across all sessions created from the same context. -For every context session tickets and TLS compression are disabled and TLS 1.2 is the minimum +For every context, session tickets and TLS compression are disabled and TLS 1.2 is the minimum version. Session resumption is therefore not supported. -/ @@ -41,11 +41,11 @@ instance : Nonempty Context.Client := ContextClientImpl.property namespace Context.Server /-- -Creates a new server-side TLS context. Only the server certificate is authenticated; set -`defaultVerify := true` if you want the server context to start with peer verification enabled. +Creates a new server-side TLS context. The server presents its certificate but does not +authenticate the client (no mutual TLS). -/ @[extern "lean_ssl_ctx_mk_server"] -opaque mk (defaultVerify : Bool := false) : IO Context.Server +opaque mk : IO Context.Server /-- Loads a PEM certificate and private key into a server context. @@ -58,8 +58,15 @@ end Server namespace Client /-- -Creates a new client-side TLS context. Connecting to a server with a self-signed or unknown CA -certificate will fail unless `configure` is called first with that CA file. +Creates a new client-side TLS context. + +With `defaultVerify := true` (the default) the context trusts the platform's system root store and +verifies the peer certificate, so connections to public HTTPS servers work without further +configuration. A server whose certificate chains only to a private or unknown CA then fails to verify +unless that CA is added with `configure` or `configureFromPEM`. + +With `defaultVerify := false` the context performs no peer verification until a later `configure` +call enables it. -/ @[extern "lean_ssl_ctx_mk_client"] opaque mk (defaultVerify : Bool := true) : IO Context.Client @@ -68,9 +75,10 @@ opaque mk (defaultVerify : Bool := true) : IO Context.Client Configures CA trust anchors and peer verification for a client context. Trust-anchor semantics: -- A non-empty `caFile` pins trust to exactly those CA certificates; the platform default trust - anchors are **not** added. -- An empty `caFile` with `verifyPeer := true` uses the platform default trust anchors. +- With `verifyPeer := true` the client always trusts the platform default trust anchors (the system + root store). A non-empty `caFile` is trusted *in addition* to those system anchors, so public + servers keep working while a private or self-signed CA also becomes trusted. +- An empty `caFile` with `verifyPeer := true` uses just the platform default trust anchors. - `verifyPeer := false` disables peer verification entirely. -/ @[extern "lean_ssl_ctx_configure_client"] @@ -81,9 +89,9 @@ Configures CA trust anchors from an in-memory PEM string instead of a file path. PEM-encoded certificates (same format as a CA bundle file). Trust-anchor semantics match `configure`: -- A non-empty `caPEM` pins trust to exactly those CA certificates; the platform default trust - anchors are **not** added. -- An empty `caPEM` with `verifyPeer := true` uses the platform default trust anchors. +- With `verifyPeer := true` the client always trusts the platform default trust anchors; a non-empty + `caPEM` is trusted *in addition* to them. +- An empty `caPEM` with `verifyPeer := true` uses just the platform default trust anchors. - `verifyPeer := false` disables peer verification entirely (the PEM is not parsed). Use this when the CA certificate is embedded in the binary rather than on disk. diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index f08df898fcec..9f0edcc37422 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -8,16 +8,21 @@ Author: Sofia Rodrigues #include #include #include +#include #include +#if defined(__APPLE__) +#include +#include +#endif + namespace lean { lean_external_class * g_ssl_context_external_class = NULL; #ifndef LEAN_EMSCRIPTEN -// This function drains at maximum 10 error messages from the Error queue. -lean_object * mk_openssl_error(char const * where, int ssl_err = 0) { +lean_object * mk_openssl_error(char const * where, int ssl_err) { std::string msg(where); if (ssl_err != 0) msg += " (ssl_error=" + std::to_string(ssl_err) + ")"; @@ -80,10 +85,95 @@ static bool configure_ctx_options(SSL_CTX * ctx) { // version; TLS 1.3 is preferred and used automatically when both peers support it. if (SSL_CTX_set_min_proto_version(ctx, TLS1_2_VERSION) != 1) return false; - // Allow SSL_write to be retried with a different pointer when the same - // payload is copied into pending_writes and replayed after WANT_READ/WANT_WRITE. + // Permit retrying SSL_write() after WANT_READ/WANT_WRITE with the payload at a moved buffer + // address (its contents must stay identical). This lets a session layer relocate a buffered + // write between retries without tripping OpenSSL's buffer-stability check. SSL_CTX_set_mode(ctx, SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER); + + // Secure hostname-matching default, inherited by every session (SSL) created from this context. + // It is inert until a peer hostname is bound per-connection via SSL_set1_host in the session + // layer; recording it here ensures that check, once wired, rejects partial wildcards such as + // `f*.example.com` (disallowed by RFC 6125 §6.4.3). + X509_VERIFY_PARAM_set_hostflags(SSL_CTX_get0_param(ctx), X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS); + return true; +} + +// Loads the platform's system root certificates into the context's trust store so clients verify +// public servers out of the box (like a browser), independent of where OpenSSL was built to look +// for its default certificate bundle. +static bool load_system_trust_store(SSL_CTX * ctx) { +#if defined(_WIN32) + if (ctx == nullptr) return false; + + X509_STORE * store = SSL_CTX_get_cert_store(ctx); + if (store == nullptr) return false; + + HCERTSTORE win_store = CertOpenSystemStoreA(0, "ROOT"); + if (win_store == nullptr) { + return false; + } + + PCCERT_CONTEXT cert = nullptr; + while ((cert = CertEnumCertificatesInStore(win_store, cert)) != nullptr) { + const unsigned char * data = cert->pbCertEncoded; + + X509 * x509 = d2i_X509( + nullptr, + &data, + static_cast(cert->cbCertEncoded) + ); + + if (x509 == nullptr) { + continue; + } + + X509_STORE_add_cert(store, x509); + X509_free(x509); + } + + CertCloseStore(win_store, 0); + + // Ignore duplicate-cert errors left in OpenSSL's error queue. + ERR_clear_error(); return true; +#elif defined(__APPLE__) + // On macOS OpenSSL's compiled-in default paths usually don't point at the Keychain, so pull the + // trusted anchor certificates directly from the Security framework instead. + X509_STORE * store = SSL_CTX_get_cert_store(ctx); + + CFArrayRef anchors = nullptr; + if (SecTrustCopyAnchorCertificates(&anchors) != errSecSuccess || anchors == nullptr) { + return false; + } + + for (CFIndex i = 0, n = CFArrayGetCount(anchors); i < n; i++) { + SecCertificateRef cert = (SecCertificateRef)CFArrayGetValueAtIndex(anchors, i); + if (cert == nullptr) continue; + + CFDataRef der = SecCertificateCopyData(cert); + if (der == nullptr) continue; + + const unsigned char * data = CFDataGetBytePtr(der); + X509 * x509 = d2i_X509(nullptr, &data, CFDataGetLength(der)); + CFRelease(der); + if (x509 == nullptr) continue; + + // X509_STORE_add_cert bumps the certificate's refcount, so drop our own reference after. + // Duplicate anchors are harmless and ignored. + X509_STORE_add_cert(store, x509); + X509_free(x509); + } + + CFRelease(anchors); + // Drop any "already in hash table" errors left by duplicate anchors so they don't leak into a + // later error message. + ERR_clear_error(); + return true; +#else + // Linux/BSD (and any other platform): OpenSSL's default verify paths already resolve to the + // system certificate bundle. + return SSL_CTX_set_default_verify_paths(ctx) == 1; +#endif } static lean_obj_res mk_ssl_context(const SSL_METHOD * method, bool default_verify) { @@ -102,12 +192,12 @@ static lean_obj_res mk_ssl_context(const SSL_METHOD * method, bool default_verif if (default_verify) { - // Secure default: verify the peer certificate against system trust anchors. - // Callers that need to skip verification must call configure() with verifyPeer=false, - // which calls SSL_CTX_set_verify(SSL_VERIFY_NONE) and overrides this setting. - if (SSL_CTX_set_default_verify_paths(ctx) != 1) { + // Secure default: verify the peer certificate against the system trust store. A later + // configure call can override this (e.g. the client's verifyPeer=false re-runs + // SSL_CTX_set_verify with SSL_VERIFY_NONE). + if (!load_system_trust_store(ctx)) { SSL_CTX_free(ctx); - return mk_openssl_io_error("SSL_CTX_set_default_verify_paths failed"); + return mk_openssl_io_error("failed to load system trust store"); } SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER, nullptr); @@ -127,9 +217,10 @@ static lean_obj_res mk_ssl_context(const SSL_METHOD * method, bool default_verif return lean_io_result_mk_ok(lean_obj); } -/* Std.Internal.SSL.Context.Server.mk (defaultVerify : Bool) : IO Context.Server */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(uint8_t default_verify) { - return mk_ssl_context(TLS_server_method(), default_verify != 0); +/* Std.Internal.SSL.Context.Server.mk : IO Context.Server */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server() { + // The server presents its certificate but never authenticates the client (no mutual TLS). + return mk_ssl_context(TLS_server_method(), false); } /* Std.Internal.SSL.Context.Client.mk (defaultVerify : Bool) : IO Context.Client */ @@ -146,8 +237,9 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_server(b_obj_arg ctx_ const char * cert = lean_string_cstr(cert_file); const char * key = lean_string_cstr(key_file); - // use_certificate_chain_file loads the leaf + any intermediates from the PEM file, - // so clients receive the full chain and can build OCSP cert IDs without a separate CA fetch. + // Load the leaf certificate plus any intermediates from the PEM file (unlike + // SSL_CTX_use_certificate_file, which loads only the leaf), so the server presents the full + // chain and clients can build a path to a trusted root. if (SSL_CTX_use_certificate_chain_file(obj->ctx, cert) <= 0) { return mk_openssl_io_error("SSL_CTX_use_certificate_chain_file failed"); } @@ -170,17 +262,25 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client(b_obj_arg ctx_ lean_ssl_context_object * obj = lean_to_ssl_context_object(ctx_obj); const char * ca = lean_string_cstr(ca_file); + if (!verify_peer) { + SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_NONE, nullptr); + return lean_io_result_mk_ok(lean_box(0)); + } + + // Trust the platform's system roots (so public servers verify out of the box, like a browser), + // then add the caller's CA file on top if one was supplied. The supplied CA is additive: it + // never replaces the system trust anchors. + if (!load_system_trust_store(obj->ctx)) { + return mk_openssl_io_error("failed to load system trust store"); + } + if (ca != nullptr && ca[0] != '\0') { if (SSL_CTX_load_verify_locations(obj->ctx, ca, nullptr) != 1) { return mk_openssl_io_error("SSL_CTX_load_verify_locations failed"); } - } else if (verify_peer) { - if (SSL_CTX_set_default_verify_paths(obj->ctx) != 1) { - return mk_openssl_io_error("SSL_CTX_set_default_verify_paths failed"); - } } - SSL_CTX_set_verify(obj->ctx, verify_peer ? SSL_VERIFY_PEER : SSL_VERIFY_NONE, nullptr); + SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_PEER, nullptr); return lean_io_result_mk_ok(lean_box(0)); } @@ -192,23 +292,20 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj const char * pem = lean_string_cstr(ca_pem); size_t pem_size = lean_string_size(ca_pem) - 1; - if (pem_size == 0) { - if (!verify_peer) { - SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_NONE, nullptr); - return lean_io_result_mk_ok(lean_box(0)); - } - - X509_STORE * store = X509_STORE_new(); - if (store == nullptr) { - return mk_openssl_io_error("X509_STORE_new failed"); - } + // Without peer verification the supplied CA certificates would never be consulted, so skip + // parsing them and just disable verification (mirrors the file-based `configure`). + if (!verify_peer) { + SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_NONE, nullptr); + return lean_io_result_mk_ok(lean_box(0)); + } - if (X509_STORE_set_default_paths(store) != 1) { - X509_STORE_free(store); - return mk_openssl_io_error("X509_STORE_set_default_paths failed"); - } + // Trust the platform's system roots; any PEM certificates below are added on top of them. + if (!load_system_trust_store(obj->ctx)) { + return mk_openssl_io_error("failed to load system trust store"); + } - SSL_CTX_set_cert_store(obj->ctx, store); + // An empty PEM leaves the client with just the system trust anchors. + if (pem_size == 0) { SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_PEER, nullptr); return lean_io_result_mk_ok(lean_box(0)); } @@ -217,13 +314,6 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj return mk_openssl_io_error("CA PEM string is too large"); } - // Without peer verification the supplied CA certificates would never be consulted, so skip - // parsing them and just disable verification (mirrors the empty-PEM and file-based paths). - if (!verify_peer) { - SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_NONE, nullptr); - return lean_io_result_mk_ok(lean_box(0)); - } - BIO * bio = BIO_new_mem_buf(pem, (int)pem_size); if (bio == nullptr) { @@ -238,16 +328,9 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj return mk_openssl_io_error("PEM_X509_INFO_read_bio failed"); } - // Store so we can rollback in case something fails! - X509_STORE * store = X509_STORE_new(); - - if (store == nullptr) { - sk_X509_INFO_pop_free(infos, X509_INFO_free); - return mk_openssl_io_error("X509_STORE_new failed"); - } - - // A non-empty CA bundle pins trust to exactly these certificates; system trust anchors are - // intentionally not added, matching the file-based `configure` ("only this CA") behavior. + // Add the parsed certificates to the context's existing verification store, which already holds + // the system roots; the store is owned by the context, so it must not be freed here. + X509_STORE * store = SSL_CTX_get_cert_store(obj->ctx); int cert_count = 0; for (int i = 0; i < sk_X509_INFO_num(infos); i++) { @@ -263,7 +346,6 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj } sk_X509_INFO_pop_free(infos, X509_INFO_free); - X509_STORE_free(store); return mk_openssl_io_error("X509_STORE_add_cert failed"); } } @@ -271,11 +353,9 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj sk_X509_INFO_pop_free(infos, X509_INFO_free); if (cert_count == 0) { - X509_STORE_free(store); return mk_openssl_io_error("no certificates found in CA PEM"); } - SSL_CTX_set_cert_store(obj->ctx, store); SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_PEER, nullptr); return lean_io_result_mk_ok(lean_box(0)); } @@ -284,7 +364,7 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj void initialize_openssl_context() {} -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(uint8_t /*default_verify*/) { +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server() { lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); } diff --git a/src/runtime/openssl/context.h b/src/runtime/openssl/context.h index ec4797685106..c635a566f71d 100644 --- a/src/runtime/openssl/context.h +++ b/src/runtime/openssl/context.h @@ -29,7 +29,7 @@ typedef struct { } lean_ssl_context_object; // Drains the OpenSSL error queue and returns a single error message combining up to 10 entries. -lean_object * mk_openssl_error(char const * where, int ssl_err); +lean_object * mk_openssl_error(char const * where, int ssl_err = 0); static inline lean_obj_res mk_openssl_io_error(char const * where, int ssl_err = 0) { return lean_io_result_mk_error(mk_openssl_error(where, ssl_err)); } static inline lean_object * lean_ssl_context_object_new(lean_ssl_context_object * c) { return lean_alloc_external(g_ssl_context_external_class, c); } static inline lean_ssl_context_object * lean_to_ssl_context_object(lean_object * o) { return (lean_ssl_context_object*)(lean_get_external_data(o)); } @@ -38,7 +38,7 @@ static inline lean_ssl_context_object * lean_to_ssl_context_object(lean_object * // ======================================= // Context Operations -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(uint8_t default_verify); +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(); extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(uint8_t default_verify); extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_server(b_obj_arg ctx, b_obj_arg cert_file, b_obj_arg key_file); extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client(b_obj_arg ctx, b_obj_arg ca_file, uint8_t verify_peer); diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index 43cb6f723520..71548a17d1e7 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -9,7 +9,7 @@ behaviour are exercised in separate test files. open Std.Internal.SSL --- Generate a self-signed certificate for testing (cached: skips generation if files exist). +-- Generates a fresh self-signed certificate in a temporary directory for testing. def setupTestCerts : IO (String × String) := do let dir ← IO.FS.createTempDir let keyFile := toString (dir / "key.pem") @@ -36,12 +36,18 @@ def testContextCreation (certFile keyFile : String) : IO Unit := do let serverCtx ← Context.Server.mk serverCtx.configure certFile keyFile + -- Empty CA with `verifyPeer := false` disables verification without parsing any CA material. let clientCtx ← Context.Client.mk clientCtx.configure "" false - -- Configuring with a CA file path (non-empty) exercises the other branch. + -- Non-empty CA file with `verifyPeer := true` exercises the additive trust path: the system + -- roots plus the supplied CA (via `SSL_CTX_load_verify_locations`). let clientCtx2 ← Context.Client.mk - clientCtx2.configure certFile false + clientCtx2.configure certFile true + + -- A non-empty CA path with `verifyPeer := false` is accepted, but the CA file is not parsed. + let clientCtx3 ← Context.Client.mk + clientCtx3.configure certFile false -- Configuring a client from an in-memory PEM string. def testConfigureClientFromPEM (certFile : String) : IO Unit := do @@ -77,6 +83,12 @@ def testConfigureFromPEMRejectsEmptyBlock : IO Unit := do assertThrows "PEM without certificates" (clientCtx.configureFromPEM "-----BEGIN CERTIFICATE-----\n-----END CERTIFICATE-----\n" true) +-- A non-existent CA file with `verifyPeer := true` is rejected (the file-based additive path fails). +def testConfigureRejectsMissingCAFile : IO Unit := do + let clientCtx ← Context.Client.mk + assertThrows "missing CA file" + (clientCtx.configure "/nonexistent/path/to/ca.pem" true) + #eval do let (certFile, keyFile) ← setupTestCerts testContextCreation certFile keyFile @@ -94,3 +106,5 @@ def testConfigureFromPEMRejectsEmptyBlock : IO Unit := do #eval testConfigureFromPEMRejectsGarbage #eval testConfigureFromPEMRejectsEmptyBlock + +#eval testConfigureRejectsMissingCAFile From 861455fe4171121140b7de6760867bf3b39f3919 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Fri, 26 Jun 2026 18:39:04 -0300 Subject: [PATCH 09/36] fix: cmake for windows and macos security --- src/CMakeLists.txt | 10 ++++++++++ src/runtime/openssl/context.cpp | 13 +++++++++++++ 2 files changed, 23 insertions(+) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 7f61076e0ff2..6b792b4d4575 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -376,6 +376,16 @@ if(NOT "${CMAKE_SYSTEM_NAME}" MATCHES "Emscripten") string(JOIN " " OPENSSL_LIBRARIES_STR ${OPENSSL_LIBRARIES}) if(NOT LEAN_STANDALONE) string(APPEND LEAN_EXTRA_LINKER_FLAGS " ${OPENSSL_LIBRARIES_STR}") + # macOS reads its trust store from the Keychain via the Security framework rather than from + # OpenSSL's default certificate paths, so link it (and its CoreFoundation dependency). + if(CMAKE_SYSTEM_NAME MATCHES "Darwin") + string(APPEND LEAN_EXTRA_LINKER_FLAGS " -framework CoreFoundation -framework Security") + endif() + + # Windows reads its trust store via the CryptoAPI (CertOpenSystemStore et al.) in crypt32. + if(CMAKE_SYSTEM_NAME MATCHES "Windows") + string(APPEND LEAN_EXTRA_LINKER_FLAGS " -lcrypt32") + endif() endif() endif() diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 9f0edcc37422..89d79a85b276 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -14,6 +14,19 @@ Author: Sofia Rodrigues #if defined(__APPLE__) #include #include +#elif defined(_WIN32) +#include +#include +// wincrypt.h defines these as object-like macros that collide with OpenSSL's identically named +// types (e.g. X509_NAME). We only need the certificate-store API from it, so drop the macros; the +// OpenSSL types were already declared by the headers above and remain intact. +#undef X509_NAME +#undef X509_EXTENSIONS +#undef X509_CERT_PAIR +#undef PKCS7_ISSUER_AND_SERIAL +#undef PKCS7_SIGNER_INFO +#undef OCSP_REQUEST +#undef OCSP_RESPONSE #endif namespace lean { From 52e05aa49d8d2233b1fc6624229357929298eb5d Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Sat, 27 Jun 2026 12:11:06 -0300 Subject: [PATCH 10/36] feat: add extra macos security flags --- script/prepare-llvm-macos.sh | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/script/prepare-llvm-macos.sh b/script/prepare-llvm-macos.sh index 8720eb5e3b05..cc32a92e8f1e 100755 --- a/script/prepare-llvm-macos.sh +++ b/script/prepare-llvm-macos.sh @@ -50,7 +50,10 @@ if [[ -L llvm-host ]]; then gcp $GMP/lib/libgmp.a stage1/lib/ gcp $LIBUV/lib/libuv.a stage1/lib/ gcp $OPENSSL/lib/libssl.a $OPENSSL/lib/libcrypto.a stage1/lib/ - echo -n " -DLEAN_EXTRA_LINKER_FLAGS='-lgmp -luv -lssl -lcrypto'" + # macOS reads its trust store from the Keychain via the Security framework (and its + # CoreFoundation dependency); standalone builds skip the `NOT LEAN_STANDALONE` block in + # `src/CMakeLists.txt`, so the frameworks must be linked here. + echo -n " -DLEAN_EXTRA_LINKER_FLAGS='-lgmp -luv -lssl -lcrypto -framework CoreFoundation -framework Security'" else echo -n " -DCMAKE_C_COMPILER=$PWD/llvm-host/bin/clang -DLEANC_OPTS='--sysroot $PWD/stage1 -resource-dir $PWD/stage1/lib/clang/15.0.1 ${EXTRA_FLAGS:-}'" fi From af0c5181178a99c753aa7b2c74090dc08a8018be Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Sat, 27 Jun 2026 12:40:51 -0300 Subject: [PATCH 11/36] feat: copy MacOS frameworks --- script/prepare-llvm-macos.sh | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/script/prepare-llvm-macos.sh b/script/prepare-llvm-macos.sh index cc32a92e8f1e..5afdffcdaf6c 100755 --- a/script/prepare-llvm-macos.sh +++ b/script/prepare-llvm-macos.sh @@ -19,7 +19,7 @@ else ln -s llvm llvm-host fi SDK=$(xcrun --show-sdk-path) -mkdir -p stage1/{bin,lib/libc,include/clang} +mkdir -p stage1/{bin,lib/libc,lib/frameworks,include/clang} CP="gcp -d" # preserve symlinks # a C compiler! gcp -L llvm/bin/clang stage1/bin/ @@ -51,13 +51,21 @@ if [[ -L llvm-host ]]; then gcp $LIBUV/lib/libuv.a stage1/lib/ gcp $OPENSSL/lib/libssl.a $OPENSSL/lib/libcrypto.a stage1/lib/ # macOS reads its trust store from the Keychain via the Security framework (and its - # CoreFoundation dependency); standalone builds skip the `NOT LEAN_STANDALONE` block in - # `src/CMakeLists.txt`, so the frameworks must be linked here. + # CoreFoundation dependency). The standalone toolchain links with `--sysroot ROOT`, which does + # not search the host SDK, so bundle the framework stubs here just like libSystem above. We also + # bundle `libobjc.A.tbd` (under `usr/lib`, where the re-export's install name resolves) because + # CoreFoundation re-exports it. + for fw in CoreFoundation Security; do + mkdir -p stage1/lib/frameworks/$fw.framework + gcp -L $SDK/System/Library/Frameworks/$fw.framework/$fw.tbd stage1/lib/frameworks/$fw.framework/ + done + mkdir -p stage1/usr/lib + gcp -L $SDK/usr/lib/libobjc.A.tbd stage1/usr/lib/ echo -n " -DLEAN_EXTRA_LINKER_FLAGS='-lgmp -luv -lssl -lcrypto -framework CoreFoundation -framework Security'" else echo -n " -DCMAKE_C_COMPILER=$PWD/llvm-host/bin/clang -DLEANC_OPTS='--sysroot $PWD/stage1 -resource-dir $PWD/stage1/lib/clang/15.0.1 ${EXTRA_FLAGS:-}'" fi echo -n " -DLEANC_INTERNAL_FLAGS='--sysroot ROOT -nostdinc -isystem ROOT/include/clang' -DLEANC_CC=ROOT/bin/clang" -echo -n " -DLEANC_INTERNAL_LINKER_FLAGS='--sysroot ROOT -L ROOT/lib -L ROOT/lib/libc -fuse-ld=lld'" +echo -n " -DLEANC_INTERNAL_LINKER_FLAGS='--sysroot ROOT -L ROOT/lib -L ROOT/lib/libc -F ROOT/lib/frameworks -fuse-ld=lld'" # do not set `LEAN_CC` for tests echo -n " -DLEAN_TEST_VARS=''" From 68dbe1ea6bf3e3e50d224d29bf862a76f0dd0365 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Sat, 27 Jun 2026 13:13:02 -0300 Subject: [PATCH 12/36] fix: disable cache on server and client contexts --- src/Std/Internal/SSL/Context.lean | 2 +- src/runtime/openssl/context.cpp | 7 +++++++ tests/elab/async_ssl_context.lean | 19 +++++++++++++++++++ 3 files changed, 27 insertions(+), 1 deletion(-) diff --git a/src/Std/Internal/SSL/Context.lean b/src/Std/Internal/SSL/Context.lean index 21d2b66a0da3..39e6f9fa13b6 100644 --- a/src/Std/Internal/SSL/Context.lean +++ b/src/Std/Internal/SSL/Context.lean @@ -79,7 +79,7 @@ Trust-anchor semantics: root store). A non-empty `caFile` is trusted *in addition* to those system anchors, so public servers keep working while a private or self-signed CA also becomes trusted. - An empty `caFile` with `verifyPeer := true` uses just the platform default trust anchors. -- `verifyPeer := false` disables peer verification entirely. +- `verifyPeer := false` disables peer verification entirely (the CA file is not parsed). -/ @[extern "lean_ssl_ctx_configure_client"] opaque configure (ctx : @& Context.Client) (caFile : @& String) (verifyPeer : Bool) : IO Unit diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 89d79a85b276..205516f32c30 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -93,6 +93,12 @@ static bool configure_ctx_options(SSL_CTX * ctx) { SSL_OP_NO_TICKET ); + // Disable the internal session cache as well. SSL_OP_NO_TICKET only suppresses ticket-based + // resumption (RFC 5077 and TLS 1.3 PSK); a TLS 1.2 server still offers session-ID resumption + // through the cache, which defaults to SSL_SESS_CACHE_SERVER. Turning the cache off makes the + // "no session resumption" guarantee hold for both client and server contexts. + SSL_CTX_set_session_cache_mode(ctx, SSL_SESS_CACHE_OFF); + // Reject TLS 1.0 and 1.1. Both are deprecated (RFC 8996) and have known // protocol-level weaknesses (BEAST, POODLE). TLS 1.2 is the minimum acceptable // version; TLS 1.3 is preferred and used automatically when both peers support it. @@ -153,6 +159,7 @@ static bool load_system_trust_store(SSL_CTX * ctx) { // On macOS OpenSSL's compiled-in default paths usually don't point at the Keychain, so pull the // trusted anchor certificates directly from the Security framework instead. X509_STORE * store = SSL_CTX_get_cert_store(ctx); + if (store == nullptr) return false; CFArrayRef anchors = nullptr; if (SecTrustCopyAnchorCertificates(&anchors) != errSecSuccess || anchors == nullptr) { diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index 71548a17d1e7..b50f9caeae88 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -89,6 +89,19 @@ def testConfigureRejectsMissingCAFile : IO Unit := do assertThrows "missing CA file" (clientCtx.configure "/nonexistent/path/to/ca.pem" true) +-- A server context with non-existent certificate/key files is rejected. +def testConfigureServerRejectsMissingFiles : IO Unit := do + let serverCtx ← Context.Server.mk + assertThrows "missing server cert" + (serverCtx.configure "/nonexistent/cert.pem" "/nonexistent/key.pem") + +-- A server context whose certificate and key do not match is rejected (here by swapping the file +-- arguments so neither parses as the expected PEM object). +def testConfigureServerRejectsSwappedFiles (certFile keyFile : String) : IO Unit := do + let serverCtx ← Context.Server.mk + assertThrows "swapped server cert/key" + (serverCtx.configure keyFile certFile) + #eval do let (certFile, keyFile) ← setupTestCerts testContextCreation certFile keyFile @@ -108,3 +121,9 @@ def testConfigureRejectsMissingCAFile : IO Unit := do #eval testConfigureFromPEMRejectsEmptyBlock #eval testConfigureRejectsMissingCAFile + +#eval testConfigureServerRejectsMissingFiles + +#eval do + let (certFile, keyFile) ← setupTestCerts + testConfigureServerRejectsSwappedFiles certFile keyFile From 2d035fc65b0b8e63f067aba08a68ac62a0f8e80b Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Sat, 4 Jul 2026 09:10:04 -0300 Subject: [PATCH 13/36] feat: join mk and configure --- src/Std/Internal/SSL/Context.lean | 47 +++------- src/runtime/openssl/context.cpp | 147 ++++++++++++++---------------- src/runtime/openssl/context.h | 8 +- tests/elab/async_ssl_context.lean | 74 +++++++-------- 4 files changed, 119 insertions(+), 157 deletions(-) diff --git a/src/Std/Internal/SSL/Context.lean b/src/Std/Internal/SSL/Context.lean index 39e6f9fa13b6..66c636016b70 100644 --- a/src/Std/Internal/SSL/Context.lean +++ b/src/Std/Internal/SSL/Context.lean @@ -41,54 +41,35 @@ instance : Nonempty Context.Client := ContextClientImpl.property namespace Context.Server /-- -Creates a new server-side TLS context. The server presents its certificate but does not -authenticate the client (no mutual TLS). +Creates a server-side TLS context, loading the PEM certificate chain and private key from the given +files. The server presents its certificate but does not authenticate the client (no mutual TLS). -/ @[extern "lean_ssl_ctx_mk_server"] -opaque mk : IO Context.Server - -/-- -Loads a PEM certificate and private key into a server context. --/ -@[extern "lean_ssl_ctx_configure_server"] -opaque configure (ctx : @& Context.Server) (certFile : @& String) (keyFile : @& String) : IO Unit +opaque mk (certFile : @& String) (keyFile : @& String) : IO Context.Server end Server namespace Client /-- -Creates a new client-side TLS context. - -With `defaultVerify := true` (the default) the context trusts the platform's system root store and -verifies the peer certificate, so connections to public HTTPS servers work without further -configuration. A server whose certificate chains only to a private or unknown CA then fails to verify -unless that CA is added with `configure` or `configureFromPEM`. - -With `defaultVerify := false` the context performs no peer verification until a later `configure` -call enables it. --/ -@[extern "lean_ssl_ctx_mk_client"] -opaque mk (defaultVerify : Bool := true) : IO Context.Client - -/-- -Configures CA trust anchors and peer verification for a client context. +Creates a client-side TLS context. Trust-anchor semantics: -- With `verifyPeer := true` the client always trusts the platform default trust anchors (the system - root store). A non-empty `caFile` is trusted *in addition* to those system anchors, so public +- With `verifyPeer := true` (the default) the client trusts the platform default trust anchors (the + system root store) and verifies the peer certificate, so connections to public HTTPS servers work + out of the box. A non-empty `caFile` is trusted *in addition* to those system anchors, so public servers keep working while a private or self-signed CA also becomes trusted. - An empty `caFile` with `verifyPeer := true` uses just the platform default trust anchors. - `verifyPeer := false` disables peer verification entirely (the CA file is not parsed). -/ -@[extern "lean_ssl_ctx_configure_client"] -opaque configure (ctx : @& Context.Client) (caFile : @& String) (verifyPeer : Bool) : IO Unit +@[extern "lean_ssl_ctx_mk_client"] +opaque mk (caFile : @& String := "") (verifyPeer : Bool := true) : IO Context.Client /-- -Configures CA trust anchors from an in-memory PEM string instead of a file path. Accepts one or more -PEM-encoded certificates (same format as a CA bundle file). +Creates a client-side TLS context with CA trust anchors from an in-memory PEM string instead of a +file path. Accepts one or more PEM-encoded certificates (same format as a CA bundle file). -Trust-anchor semantics match `configure`: +Trust-anchor semantics match `mk`: - With `verifyPeer := true` the client always trusts the platform default trust anchors; a non-empty `caPEM` is trusted *in addition* to them. - An empty `caPEM` with `verifyPeer := true` uses just the platform default trust anchors. @@ -96,8 +77,8 @@ Trust-anchor semantics match `configure`: Use this when the CA certificate is embedded in the binary rather than on disk. -/ -@[extern "lean_ssl_ctx_configure_client_from_pem"] -opaque configureFromPEM (ctx : @& Context.Client) (caPEM : @& String) (verifyPeer : Bool) : IO Unit +@[extern "lean_ssl_ctx_mk_client_from_pem"] +opaque mkFromPEM (caPEM : @& String) (verifyPeer : Bool := true) : IO Context.Client end Client end Context diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 205516f32c30..bd8aea811662 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -196,33 +196,29 @@ static bool load_system_trust_store(SSL_CTX * ctx) { #endif } -static lean_obj_res mk_ssl_context(const SSL_METHOD * method, bool default_verify) { +// Creates an SSL_CTX with the hardened options shared by all contexts. Returns nullptr and stores +// an IO error in *err on failure. +static SSL_CTX * mk_ssl_ctx_base(const SSL_METHOD * method, lean_obj_res * err) { ERR_clear_error(); SSL_CTX * ctx = SSL_CTX_new(method); if (ctx == nullptr) { - return mk_openssl_io_error("SSL_CTX_new failed"); + *err = mk_openssl_io_error("SSL_CTX_new failed"); + return nullptr; } if (!configure_ctx_options(ctx)) { SSL_CTX_free(ctx); - return mk_openssl_io_error("SSL_CTX_set_min_proto_version failed"); + *err = mk_openssl_io_error("SSL_CTX_set_min_proto_version failed"); + return nullptr; } - if (default_verify) { - - // Secure default: verify the peer certificate against the system trust store. A later - // configure call can override this (e.g. the client's verifyPeer=false re-runs - // SSL_CTX_set_verify with SSL_VERIFY_NONE). - if (!load_system_trust_store(ctx)) { - SSL_CTX_free(ctx); - return mk_openssl_io_error("failed to load system trust store"); - } - - SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER, nullptr); - } + return ctx; +} +// Wraps a fully configured SSL_CTX into a Lean external object, taking ownership of ctx. +static lean_obj_res wrap_ssl_context(SSL_CTX * ctx) { lean_ssl_context_object * obj = (lean_ssl_context_object*)malloc(sizeof(lean_ssl_context_object)); if (obj == nullptr) { @@ -237,106 +233,106 @@ static lean_obj_res mk_ssl_context(const SSL_METHOD * method, bool default_verif return lean_io_result_mk_ok(lean_obj); } -/* Std.Internal.SSL.Context.Server.mk : IO Context.Server */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server() { +/* Std.Internal.SSL.Context.Server.mk (certFile keyFile : @& String) : IO Context.Server */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, b_obj_arg key_file) { + lean_obj_res err = nullptr; // The server presents its certificate but never authenticates the client (no mutual TLS). - return mk_ssl_context(TLS_server_method(), false); -} - -/* Std.Internal.SSL.Context.Client.mk (defaultVerify : Bool) : IO Context.Client */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(uint8_t default_verify) { - // With default_verify set, the client verifies the peer against system trust anchors. - return mk_ssl_context(TLS_client_method(), default_verify != 0); -} - -/* Std.Internal.SSL.Context.Server.configure (ctx : @& Context.Server) (certFile keyFile : @& String) : IO Unit */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_server(b_obj_arg ctx_obj, b_obj_arg cert_file, b_obj_arg key_file) { - ERR_clear_error(); + SSL_CTX * ctx = mk_ssl_ctx_base(TLS_server_method(), &err); + if (ctx == nullptr) return err; - lean_ssl_context_object * obj = lean_to_ssl_context_object(ctx_obj); const char * cert = lean_string_cstr(cert_file); const char * key = lean_string_cstr(key_file); // Load the leaf certificate plus any intermediates from the PEM file (unlike // SSL_CTX_use_certificate_file, which loads only the leaf), so the server presents the full // chain and clients can build a path to a trusted root. - if (SSL_CTX_use_certificate_chain_file(obj->ctx, cert) <= 0) { + if (SSL_CTX_use_certificate_chain_file(ctx, cert) <= 0) { + SSL_CTX_free(ctx); return mk_openssl_io_error("SSL_CTX_use_certificate_chain_file failed"); } - if (SSL_CTX_use_PrivateKey_file(obj->ctx, key, SSL_FILETYPE_PEM) <= 0) { + if (SSL_CTX_use_PrivateKey_file(ctx, key, SSL_FILETYPE_PEM) <= 0) { + SSL_CTX_free(ctx); return mk_openssl_io_error("SSL_CTX_use_PrivateKey_file failed"); } - if (SSL_CTX_check_private_key(obj->ctx) != 1) { + if (SSL_CTX_check_private_key(ctx) != 1) { + SSL_CTX_free(ctx); return mk_openssl_io_error("SSL_CTX_check_private_key failed"); } - return lean_io_result_mk_ok(lean_box(0)); + return wrap_ssl_context(ctx); } -/* Std.Internal.SSL.Context.Client.configure (ctx : @& Context.Client) (caFile : @& String) (verifyPeer : Bool) : IO Unit */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client(b_obj_arg ctx_obj, b_obj_arg ca_file, uint8_t verify_peer) { - ERR_clear_error(); - - lean_ssl_context_object * obj = lean_to_ssl_context_object(ctx_obj); - const char * ca = lean_string_cstr(ca_file); +/* Std.Internal.SSL.Context.Client.mk (caFile : @& String) (verifyPeer : Bool) : IO Context.Client */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, uint8_t verify_peer) { + lean_obj_res err = nullptr; + SSL_CTX * ctx = mk_ssl_ctx_base(TLS_client_method(), &err); + if (ctx == nullptr) return err; if (!verify_peer) { - SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_NONE, nullptr); - return lean_io_result_mk_ok(lean_box(0)); + SSL_CTX_set_verify(ctx, SSL_VERIFY_NONE, nullptr); + return wrap_ssl_context(ctx); } // Trust the platform's system roots (so public servers verify out of the box, like a browser), // then add the caller's CA file on top if one was supplied. The supplied CA is additive: it // never replaces the system trust anchors. - if (!load_system_trust_store(obj->ctx)) { + if (!load_system_trust_store(ctx)) { + SSL_CTX_free(ctx); return mk_openssl_io_error("failed to load system trust store"); } - if (ca != nullptr && ca[0] != '\0') { - if (SSL_CTX_load_verify_locations(obj->ctx, ca, nullptr) != 1) { + const char * ca = lean_string_cstr(ca_file); + + if (ca[0] != '\0') { + if (SSL_CTX_load_verify_locations(ctx, ca, nullptr) != 1) { + SSL_CTX_free(ctx); return mk_openssl_io_error("SSL_CTX_load_verify_locations failed"); } } - SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_PEER, nullptr); - return lean_io_result_mk_ok(lean_box(0)); + SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER, nullptr); + return wrap_ssl_context(ctx); } -/* Std.Internal.SSL.Context.Client.configureFromPEM (ctx : @& Context.Client) (caPEM : @& String) (verifyPeer : Bool) : IO Unit */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj_arg ctx_obj, b_obj_arg ca_pem, uint8_t verify_peer) { - ERR_clear_error(); - - lean_ssl_context_object * obj = lean_to_ssl_context_object(ctx_obj); - const char * pem = lean_string_cstr(ca_pem); - size_t pem_size = lean_string_size(ca_pem) - 1; +/* Std.Internal.SSL.Context.Client.mkFromPEM (caPEM : @& String) (verifyPeer : Bool) : IO Context.Client */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca_pem, uint8_t verify_peer) { + lean_obj_res err = nullptr; + SSL_CTX * ctx = mk_ssl_ctx_base(TLS_client_method(), &err); + if (ctx == nullptr) return err; // Without peer verification the supplied CA certificates would never be consulted, so skip - // parsing them and just disable verification (mirrors the file-based `configure`). + // parsing them and just disable verification (mirrors the file-based `mk`). if (!verify_peer) { - SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_NONE, nullptr); - return lean_io_result_mk_ok(lean_box(0)); + SSL_CTX_set_verify(ctx, SSL_VERIFY_NONE, nullptr); + return wrap_ssl_context(ctx); } // Trust the platform's system roots; any PEM certificates below are added on top of them. - if (!load_system_trust_store(obj->ctx)) { + if (!load_system_trust_store(ctx)) { + SSL_CTX_free(ctx); return mk_openssl_io_error("failed to load system trust store"); } + const char * pem = lean_string_cstr(ca_pem); + size_t pem_size = lean_string_size(ca_pem) - 1; + // An empty PEM leaves the client with just the system trust anchors. if (pem_size == 0) { - SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_PEER, nullptr); - return lean_io_result_mk_ok(lean_box(0)); + SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER, nullptr); + return wrap_ssl_context(ctx); } if (pem_size > INT_MAX) { + SSL_CTX_free(ctx); return mk_openssl_io_error("CA PEM string is too large"); } BIO * bio = BIO_new_mem_buf(pem, (int)pem_size); if (bio == nullptr) { + SSL_CTX_free(ctx); return mk_openssl_io_error("BIO_new_mem_buf failed"); } @@ -345,12 +341,13 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj BIO_free(bio); if (infos == nullptr) { + SSL_CTX_free(ctx); return mk_openssl_io_error("PEM_X509_INFO_read_bio failed"); } - // Add the parsed certificates to the context's existing verification store, which already holds - // the system roots; the store is owned by the context, so it must not be freed here. - X509_STORE * store = SSL_CTX_get_cert_store(obj->ctx); + // Add the parsed certificates to the context's verification store, which already holds the + // system roots; the store is owned by the context, so it must not be freed here. + X509_STORE * store = SSL_CTX_get_cert_store(ctx); int cert_count = 0; for (int i = 0; i < sk_X509_INFO_num(infos); i++) { @@ -359,13 +356,14 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj cert_count++; if (X509_STORE_add_cert(store, info->x509) != 1) { - unsigned long err = ERR_peek_last_error(); - if (ERR_GET_LIB(err) == ERR_LIB_X509 && ERR_GET_REASON(err) == X509_R_CERT_ALREADY_IN_HASH_TABLE) { + unsigned long err_code = ERR_peek_last_error(); + if (ERR_GET_LIB(err_code) == ERR_LIB_X509 && ERR_GET_REASON(err_code) == X509_R_CERT_ALREADY_IN_HASH_TABLE) { ERR_clear_error(); continue; } sk_X509_INFO_pop_free(infos, X509_INFO_free); + SSL_CTX_free(ctx); return mk_openssl_io_error("X509_STORE_add_cert failed"); } } @@ -373,34 +371,27 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj sk_X509_INFO_pop_free(infos, X509_INFO_free); if (cert_count == 0) { + SSL_CTX_free(ctx); return mk_openssl_io_error("no certificates found in CA PEM"); } - SSL_CTX_set_verify(obj->ctx, SSL_VERIFY_PEER, nullptr); - return lean_io_result_mk_ok(lean_box(0)); + SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER, nullptr); + return wrap_ssl_context(ctx); } #else void initialize_openssl_context() {} -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server() { - lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); -} - -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(uint8_t /*default_verify*/) { - lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); -} - -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_server(b_obj_arg /*ctx_obj*/, b_obj_arg /*cert_file*/, b_obj_arg /*key_file*/) { +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg /*cert_file*/, b_obj_arg /*key_file*/) { lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); } -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client(b_obj_arg /*ctx_obj*/, b_obj_arg /*ca_file*/, uint8_t /*verify_peer*/) { +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg /*ca_file*/, uint8_t /*verify_peer*/) { lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); } -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj_arg /*ctx_obj*/, b_obj_arg /*ca_pem*/, uint8_t /*verify_peer*/) { +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg /*ca_pem*/, uint8_t /*verify_peer*/) { lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); } diff --git a/src/runtime/openssl/context.h b/src/runtime/openssl/context.h index c635a566f71d..9a3c6cc16493 100644 --- a/src/runtime/openssl/context.h +++ b/src/runtime/openssl/context.h @@ -38,10 +38,8 @@ static inline lean_ssl_context_object * lean_to_ssl_context_object(lean_object * // ======================================= // Context Operations -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(); -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(uint8_t default_verify); -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_server(b_obj_arg ctx, b_obj_arg cert_file, b_obj_arg key_file); -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client(b_obj_arg ctx, b_obj_arg ca_file, uint8_t verify_peer); -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_configure_client_from_pem(b_obj_arg ctx, b_obj_arg ca_pem, uint8_t verify_peer); +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, b_obj_arg key_file); +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, uint8_t verify_peer); +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca_pem, uint8_t verify_peer); } diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index b50f9caeae88..c93dd3700205 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -33,27 +33,25 @@ def setupTestCerts : IO (String × String) := do -- Context creation and configuration (smoke test). def testContextCreation (certFile keyFile : String) : IO Unit := do - let serverCtx ← Context.Server.mk - serverCtx.configure certFile keyFile + let _serverCtx ← Context.Server.mk certFile keyFile -- Empty CA with `verifyPeer := false` disables verification without parsing any CA material. - let clientCtx ← Context.Client.mk - clientCtx.configure "" false + let _clientCtx ← Context.Client.mk "" false -- Non-empty CA file with `verifyPeer := true` exercises the additive trust path: the system -- roots plus the supplied CA (via `SSL_CTX_load_verify_locations`). - let clientCtx2 ← Context.Client.mk - clientCtx2.configure certFile true + let _clientCtx2 ← Context.Client.mk certFile true -- A non-empty CA path with `verifyPeer := false` is accepted, but the CA file is not parsed. - let clientCtx3 ← Context.Client.mk - clientCtx3.configure certFile false + let _clientCtx3 ← Context.Client.mk certFile false --- Configuring a client from an in-memory PEM string. -def testConfigureClientFromPEM (certFile : String) : IO Unit := do + -- Defaults: no CA file, peer verification against the system trust anchors. + let _clientCtx4 ← Context.Client.mk + +-- Creating a client from an in-memory PEM string. +def testMkClientFromPEM (certFile : String) : IO Unit := do let caPEM ← IO.FS.readFile certFile - let clientCtx ← Context.Client.mk - clientCtx.configureFromPEM caPEM true + let _clientCtx ← Context.Client.mkFromPEM caPEM true -- Asserts that an IO action fails, used to exercise the rejection/error paths. def assertThrows (label : String) (act : IO Unit) : IO Unit := do @@ -62,45 +60,39 @@ def assertThrows (label : String) (act : IO Unit) : IO Unit := do | .error _ => pure () -- An empty CA bundle with `verifyPeer := true` falls back to the platform trust anchors and succeeds. -def testConfigureFromPEMEmptyFallsBack : IO Unit := do - let clientCtx ← Context.Client.mk - clientCtx.configureFromPEM "" true +def testMkFromPEMEmptyFallsBack : IO Unit := do + let _clientCtx ← Context.Client.mkFromPEM "" true -- `verifyPeer := false` succeeds without parsing the CA material, even for a real bundle. -def testConfigureFromPEMNoVerify (certFile : String) : IO Unit := do +def testMkFromPEMNoVerify (certFile : String) : IO Unit := do let caPEM ← IO.FS.readFile certFile - let clientCtx ← Context.Client.mk - clientCtx.configureFromPEM caPEM false + let _clientCtx ← Context.Client.mkFromPEM caPEM false -- Malformed PEM input is rejected rather than silently ignored. -def testConfigureFromPEMRejectsGarbage : IO Unit := do - let clientCtx ← Context.Client.mk - assertThrows "garbage PEM" (clientCtx.configureFromPEM "not a certificate at all" true) +def testMkFromPEMRejectsGarbage : IO Unit := do + assertThrows "garbage PEM" + (discard <| Context.Client.mkFromPEM "not a certificate at all" true) -- A well-formed PEM block that contains no certificate is rejected. -def testConfigureFromPEMRejectsEmptyBlock : IO Unit := do - let clientCtx ← Context.Client.mk +def testMkFromPEMRejectsEmptyBlock : IO Unit := do assertThrows "PEM without certificates" - (clientCtx.configureFromPEM "-----BEGIN CERTIFICATE-----\n-----END CERTIFICATE-----\n" true) + (discard <| Context.Client.mkFromPEM "-----BEGIN CERTIFICATE-----\n-----END CERTIFICATE-----\n" true) -- A non-existent CA file with `verifyPeer := true` is rejected (the file-based additive path fails). -def testConfigureRejectsMissingCAFile : IO Unit := do - let clientCtx ← Context.Client.mk +def testMkRejectsMissingCAFile : IO Unit := do assertThrows "missing CA file" - (clientCtx.configure "/nonexistent/path/to/ca.pem" true) + (discard <| Context.Client.mk "/nonexistent/path/to/ca.pem" true) -- A server context with non-existent certificate/key files is rejected. -def testConfigureServerRejectsMissingFiles : IO Unit := do - let serverCtx ← Context.Server.mk +def testMkServerRejectsMissingFiles : IO Unit := do assertThrows "missing server cert" - (serverCtx.configure "/nonexistent/cert.pem" "/nonexistent/key.pem") + (discard <| Context.Server.mk "/nonexistent/cert.pem" "/nonexistent/key.pem") -- A server context whose certificate and key do not match is rejected (here by swapping the file -- arguments so neither parses as the expected PEM object). -def testConfigureServerRejectsSwappedFiles (certFile keyFile : String) : IO Unit := do - let serverCtx ← Context.Server.mk +def testMkServerRejectsSwappedFiles (certFile keyFile : String) : IO Unit := do assertThrows "swapped server cert/key" - (serverCtx.configure keyFile certFile) + (discard <| Context.Server.mk keyFile certFile) #eval do let (certFile, keyFile) ← setupTestCerts @@ -108,22 +100,22 @@ def testConfigureServerRejectsSwappedFiles (certFile keyFile : String) : IO Unit #eval do let (certFile, _) ← setupTestCerts - testConfigureClientFromPEM certFile + testMkClientFromPEM certFile -#eval testConfigureFromPEMEmptyFallsBack +#eval testMkFromPEMEmptyFallsBack #eval do let (certFile, _) ← setupTestCerts - testConfigureFromPEMNoVerify certFile + testMkFromPEMNoVerify certFile -#eval testConfigureFromPEMRejectsGarbage +#eval testMkFromPEMRejectsGarbage -#eval testConfigureFromPEMRejectsEmptyBlock +#eval testMkFromPEMRejectsEmptyBlock -#eval testConfigureRejectsMissingCAFile +#eval testMkRejectsMissingCAFile -#eval testConfigureServerRejectsMissingFiles +#eval testMkServerRejectsMissingFiles #eval do let (certFile, keyFile) ← setupTestCerts - testConfigureServerRejectsSwappedFiles certFile keyFile + testMkServerRejectsSwappedFiles certFile keyFile From bcf731791ec1ca7b3a35ab404cc45a1d8e5e18b7 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Sat, 4 Jul 2026 13:59:34 -0300 Subject: [PATCH 14/36] test: make it not depend on openssl cli --- tests/elab/async_ssl_context.lean | 78 ++++++++++++++++++++++++------- 1 file changed, 62 insertions(+), 16 deletions(-) diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index c93dd3700205..40f3177a980e 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -9,26 +9,72 @@ behaviour are exercised in separate test files. open Std.Internal.SSL --- Generates a fresh self-signed certificate in a temporary directory for testing. +-- A self-signed `CN=localhost` certificate and its matching RSA private key, embedded so the tests +-- neither shell out to `openssl` nor depend on it being installed. Valid until 2126; the smoke tests +-- only load these into a context (no handshake), so expiry is never checked. To regenerate: +-- openssl genrsa -out key.pem 2048 +-- openssl req -new -x509 -key key.pem -out cert.pem -days 36500 -subj "/CN=localhost" + +def testCertPEM : String := +"-----BEGIN CERTIFICATE----- +MIIDCzCCAfOgAwIBAgIUfBsMFFfMmVyfKr1HjIF9ZUsOz0MwDQYJKoZIhvcNAQEL +BQAwFDESMBAGA1UEAwwJbG9jYWxob3N0MCAXDTI2MDcwNDE1NDQyNVoYDzIxMjYw +NjEwMTU0NDI1WjAUMRIwEAYDVQQDDAlsb2NhbGhvc3QwggEiMA0GCSqGSIb3DQEB +AQUAA4IBDwAwggEKAoIBAQC7SwGfQ+WLyJwnRlX37WMUEDT/YVZd0PV/6PPJSFx3 +0z2vZnqMh9S7gQPvkYkon7qMtqF5jlJt3zDmddjuhhwHqeNj1htKnWPjhh8rc2DG +7v9u/36O92fz2jKUn8qHGG80+SiW4LkE8uXuC/ia0a1W03iT7rApICuSIgNrP5Zr +XZ3pHxn4m7GxnOxm/5jt0SX3HQkRV+VMEo0cGEq/8ZvmwnOOG14C/o/FxFw9zxw8 +pDTabvfLVxoHCMOu7UB3c0Hg6SzM8cD/QefWQRLyD/rZIw34GcTs9IklWxJ0loqj +Y1q0c5p5991zRC2SqmM6vpAjc6dpijIAZvsycewlnY1bAgMBAAGjUzBRMB0GA1Ud +DgQWBBRam+qywW30FsQlhzW2SV7dHs96NDAfBgNVHSMEGDAWgBRam+qywW30FsQl +hzW2SV7dHs96NDAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQC7 +ItNAWGWOQDfjSCi2XqbKPSMbo3d8x2fQclYuFXu3QjbsmTrkzCehvGAyXHUtbnwa +wAufdEDKjfmUZmquVQd54oTCDgNtDF4729kD7pBeIIyhWyH0osPAs9mva37ripqC +MQ3kMClzS8FSBhB03CSdkypzx0znI2rIcxbMDPCIoYtkKYyvc6/yztWZfVbhHWPC +6bYAHOFpqFCOSzcZFwzWjWmAnH+pPEX8khDTTY676VG/Yuy2F/BgCdXco8VE+kiW +hh/mZMXyGuGKuYexz8Tv5M3qzdqxNmhFObyJPk/Y7XgIoBtdyHLMkqYN5fnlUMtQ +gjuJv2wDBVKza1YhNdr1 +-----END CERTIFICATE----- +" + +def testKeyPEM : String := +"-----BEGIN PRIVATE KEY----- +MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQC7SwGfQ+WLyJwn +RlX37WMUEDT/YVZd0PV/6PPJSFx30z2vZnqMh9S7gQPvkYkon7qMtqF5jlJt3zDm +ddjuhhwHqeNj1htKnWPjhh8rc2DG7v9u/36O92fz2jKUn8qHGG80+SiW4LkE8uXu +C/ia0a1W03iT7rApICuSIgNrP5ZrXZ3pHxn4m7GxnOxm/5jt0SX3HQkRV+VMEo0c +GEq/8ZvmwnOOG14C/o/FxFw9zxw8pDTabvfLVxoHCMOu7UB3c0Hg6SzM8cD/QefW +QRLyD/rZIw34GcTs9IklWxJ0loqjY1q0c5p5991zRC2SqmM6vpAjc6dpijIAZvsy +cewlnY1bAgMBAAECggEADV4RnBHnAL6NMpppCVx2jViIx89lMCX5V6tDNxMEkoLP +rMSmK4CIVOek5cTf4rffwypHxRq81F2xKkmv9Xo55uwfsCD4aq9oETWh5OKDvj8R +mRUALekHkNZ6dLQg6tp6GXBNDtO0MN+7PG27TSV49zD5sqk/Bnhm07O8xbtQm5IA +LheZd4GPqBdTIf1krFNP86Th4X+DKrnuNmiXS4lDuhH/rheRfTQ4VK/srnrj//Zw +I+AeXwnch25CByXp+CoSHpwZGPYzfknZBjmkh1QbwMR/ivjA954BxbVsWl+/cAYh +7+MEvkrInJYqbwSVWQrVrKjRuHqI0OcvymBbGXoaHQKBgQDg+HBLB0Tt+mQqX+Kb +eo0ymK+V2Y0kprlVthTHPJHpA+zMcEBJWjlz0IpdfkjKAMrVoVJB4Fn8Y4Wj4Nzq +yV1AsZ/cHsH3NWnwiMaRvVTs7O60Vhs0G/I2lIx6T0dl4qWFjJQizrvMctNFVkvR +rh4tnGQnTMBViqKAB5CiW/o/dwKBgQDVIDNchhEAijUNJ60c4XcbrhGjlBmjDRyG +KfVM1LMQz9u20bZvOP/qL5wNHrlGqplOBUvD1o/J6b4ZIgzhWNB0WrPrBBi40pvv +9v7wCTZ3XfJ+KrGlWOfB0fPVs2kKjLd8b+1xoa7JM/RJIBmytXj3o9lS/6F7SkjH +0EQv086CPQKBgE83jCsPOzllMwIs01mWNMP9Oc7VVTrzrk09GWHytRpM9IQkfq6V +o6dhZmd3gWAIGWRSMunZezZBQRysoH3YPAr8wOK8veYzm8NEFk/ZUF9BKui7bUbT +FF4dvr2OzwBUZ554Gu2KyFw8jqJaucXyvtOmvymLgCpe78uPXmGda6gPAoGBAL3y +5xPtgTXD+ChzVjzJTkjjSWFLW9YQl32T48bIQ5gWSbKVEk3qtVvZdvHSkjrDTcNV +wQMYNis1InJwAJ7Pc2pgdL5fdlEzlDu5Hdp9u4eDud5s2suNg3EhWHr8XgBDDj3f +2/ZMreUxYuXRsFWwm9HKvKTWpOund1pu6nbeBc3ZAoGAWKJkhw7KoELqiCpTn3If +7ZN64vgqkNacXfjzc4D5oJ2aqAPJsTBdJ14+VShecgc5Kn0QriP0mTU712/GiK08 +A0Xb02+1ouerqiUE+Ea++rZphkyC0g+MKcoCWFWKDmtJuC7vtCGLOeFuLgHahqqS +yIGPWTqB+JUmYpWBWIvu0Gg= +-----END PRIVATE KEY----- +" + +-- Writes the embedded certificate and key to a temporary directory, returning their paths. def setupTestCerts : IO (String × String) := do let dir ← IO.FS.createTempDir let keyFile := toString (dir / "key.pem") let certFile := toString (dir / "cert.pem") - - let keyOut ← IO.Process.output { - cmd := "openssl" - args := #["genrsa", "-out", keyFile, "2048"] - } - unless keyOut.exitCode == 0 do - throw <| IO.userError s!"openssl genrsa failed: {keyOut.stderr}" - - let certOut ← IO.Process.output { - cmd := "openssl" - args := #["req", "-new", "-x509", "-key", keyFile, "-out", certFile, "-days", "1", "-subj", "/CN=localhost"] - } - unless certOut.exitCode == 0 do - throw <| IO.userError s!"openssl req failed: {certOut.stderr}" - + IO.FS.writeFile keyFile testKeyPEM + IO.FS.writeFile certFile testCertPEM return (certFile, keyFile) -- Context creation and configuration (smoke test). From 2eb9f5bb7d4fc13bc15273f2b1262b30ce7e5239 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Sat, 4 Jul 2026 22:24:33 -0300 Subject: [PATCH 15/36] test: make a folder to all tests to avoid calling openssl cli --- tests/elab/async_ssl_certs/README.md | 34 ++++++++++++ tests/elab/async_ssl_certs/cert.pem | 19 +++++++ tests/elab/async_ssl_certs/expired.pem | 17 ++++++ tests/elab/async_ssl_certs/key.pem | 28 ++++++++++ tests/elab/async_ssl_certs/multisan.pem | 20 +++++++ tests/elab/async_ssl_certs/wildcard.pem | 20 +++++++ tests/elab/async_ssl_context.lean | 71 ++++--------------------- 7 files changed, 149 insertions(+), 60 deletions(-) create mode 100644 tests/elab/async_ssl_certs/README.md create mode 100644 tests/elab/async_ssl_certs/cert.pem create mode 100644 tests/elab/async_ssl_certs/expired.pem create mode 100644 tests/elab/async_ssl_certs/key.pem create mode 100644 tests/elab/async_ssl_certs/multisan.pem create mode 100644 tests/elab/async_ssl_certs/wildcard.pem diff --git a/tests/elab/async_ssl_certs/README.md b/tests/elab/async_ssl_certs/README.md new file mode 100644 index 000000000000..74a574cdb59a --- /dev/null +++ b/tests/elab/async_ssl_certs/README.md @@ -0,0 +1,34 @@ +# TLS test certificate fixtures + +Self-signed certificates used by the `async_ssl_*` tests. These contain **no secrets**: the +private key exists only so the tests can drive a real TLS handshake, and nothing outside the +test suite trusts these certificates. They are committed as fixtures (instead of generated at +test time) so the tests neither shell out to the `openssl` CLI nor depend on it being +installed — subprocess spawning in these tests also produced spurious LeakSanitizer reports +in the sanitizer CI build. + +All certificates are signed by `key.pem` (RSA-2048) and are valid until 2126, except +`expired.pem`, whose validity window is entirely in 2020 (used to verify that expired +certificates are rejected). + +| file | subject | notes | +|---|---|---| +| `key.pem` | | RSA-2048 private key for all certs below | +| `cert.pem` | `CN=localhost` | standard server cert (no SAN; hostname matching uses the CN fallback) | +| `wildcard.pem` | `CN=*.test.local` | SAN: `DNS:*.test.local, DNS:test.local` | +| `multisan.pem` | `CN=alpha.test.local` | SAN: `DNS:alpha.test.local, DNS:beta.test.local` | +| `expired.pem` | `CN=localhost` | valid 2020-01-01 → 2020-01-02 only | + +To regenerate: + +```sh +openssl genrsa -out key.pem 2048 +openssl req -new -x509 -key key.pem -out cert.pem -days 36500 -subj "/CN=localhost" +openssl req -new -x509 -key key.pem -out wildcard.pem -days 36500 -subj "/CN=*.test.local" \ + -addext "subjectAltName=DNS:*.test.local,DNS:test.local" +openssl req -new -x509 -key key.pem -out multisan.pem -days 36500 -subj "/CN=alpha.test.local" \ + -addext "subjectAltName=DNS:alpha.test.local,DNS:beta.test.local" +openssl req -new -key key.pem -out expired.csr -subj "/CN=localhost" +openssl x509 -req -in expired.csr -signkey key.pem -out expired.pem -set_serial 99 \ + -not_before 20200101000000Z -not_after 20200102000000Z && rm expired.csr +``` diff --git a/tests/elab/async_ssl_certs/cert.pem b/tests/elab/async_ssl_certs/cert.pem new file mode 100644 index 000000000000..414acf80d633 --- /dev/null +++ b/tests/elab/async_ssl_certs/cert.pem @@ -0,0 +1,19 @@ +-----BEGIN CERTIFICATE----- +MIIDCzCCAfOgAwIBAgIUfBsMFFfMmVyfKr1HjIF9ZUsOz0MwDQYJKoZIhvcNAQEL +BQAwFDESMBAGA1UEAwwJbG9jYWxob3N0MCAXDTI2MDcwNDE1NDQyNVoYDzIxMjYw +NjEwMTU0NDI1WjAUMRIwEAYDVQQDDAlsb2NhbGhvc3QwggEiMA0GCSqGSIb3DQEB +AQUAA4IBDwAwggEKAoIBAQC7SwGfQ+WLyJwnRlX37WMUEDT/YVZd0PV/6PPJSFx3 +0z2vZnqMh9S7gQPvkYkon7qMtqF5jlJt3zDmddjuhhwHqeNj1htKnWPjhh8rc2DG +7v9u/36O92fz2jKUn8qHGG80+SiW4LkE8uXuC/ia0a1W03iT7rApICuSIgNrP5Zr +XZ3pHxn4m7GxnOxm/5jt0SX3HQkRV+VMEo0cGEq/8ZvmwnOOG14C/o/FxFw9zxw8 +pDTabvfLVxoHCMOu7UB3c0Hg6SzM8cD/QefWQRLyD/rZIw34GcTs9IklWxJ0loqj +Y1q0c5p5991zRC2SqmM6vpAjc6dpijIAZvsycewlnY1bAgMBAAGjUzBRMB0GA1Ud +DgQWBBRam+qywW30FsQlhzW2SV7dHs96NDAfBgNVHSMEGDAWgBRam+qywW30FsQl +hzW2SV7dHs96NDAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQC7 +ItNAWGWOQDfjSCi2XqbKPSMbo3d8x2fQclYuFXu3QjbsmTrkzCehvGAyXHUtbnwa +wAufdEDKjfmUZmquVQd54oTCDgNtDF4729kD7pBeIIyhWyH0osPAs9mva37ripqC +MQ3kMClzS8FSBhB03CSdkypzx0znI2rIcxbMDPCIoYtkKYyvc6/yztWZfVbhHWPC +6bYAHOFpqFCOSzcZFwzWjWmAnH+pPEX8khDTTY676VG/Yuy2F/BgCdXco8VE+kiW +hh/mZMXyGuGKuYexz8Tv5M3qzdqxNmhFObyJPk/Y7XgIoBtdyHLMkqYN5fnlUMtQ +gjuJv2wDBVKza1YhNdr1 +-----END CERTIFICATE----- diff --git a/tests/elab/async_ssl_certs/expired.pem b/tests/elab/async_ssl_certs/expired.pem new file mode 100644 index 000000000000..bcd1bcd32005 --- /dev/null +++ b/tests/elab/async_ssl_certs/expired.pem @@ -0,0 +1,17 @@ +-----BEGIN CERTIFICATE----- +MIICxDCCAaygAwIBAgIBYzANBgkqhkiG9w0BAQsFADAUMRIwEAYDVQQDDAlsb2Nh +bGhvc3QwHhcNMjAwMTAxMDAwMDAwWhcNMjAwMTAyMDAwMDAwWjAUMRIwEAYDVQQD +DAlsb2NhbGhvc3QwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQC7SwGf +Q+WLyJwnRlX37WMUEDT/YVZd0PV/6PPJSFx30z2vZnqMh9S7gQPvkYkon7qMtqF5 +jlJt3zDmddjuhhwHqeNj1htKnWPjhh8rc2DG7v9u/36O92fz2jKUn8qHGG80+SiW +4LkE8uXuC/ia0a1W03iT7rApICuSIgNrP5ZrXZ3pHxn4m7GxnOxm/5jt0SX3HQkR +V+VMEo0cGEq/8ZvmwnOOG14C/o/FxFw9zxw8pDTabvfLVxoHCMOu7UB3c0Hg6SzM +8cD/QefWQRLyD/rZIw34GcTs9IklWxJ0loqjY1q0c5p5991zRC2SqmM6vpAjc6dp +ijIAZvsycewlnY1bAgMBAAGjITAfMB0GA1UdDgQWBBRam+qywW30FsQlhzW2SV7d +Hs96NDANBgkqhkiG9w0BAQsFAAOCAQEAjaXKUdudCDoUKCswhiW3bZalzxwzDWQz +C18pqR2pyVSUCifwkgyGWDsX3UMwA9NiM3S/q10KqQXqHpFADvtD1vZsKpORDEmN +Wcgb5d7LteGU6Wsgadvy9kCiKj6jr7VkmMi6ixsLtNWgU2oPC4NLVsThWkltY2j0 +tGtjMok4hrmWyuPpk+2VMjbx09O/gY60Il4KnNoObRWV9lv8Fz1+Q0ARZygqzlrB +ZBQl6tdysiB34vR7KBCiqwq1h8p3FfsiPu7CS6zrRnrugk/h9AhNewf0mI6KHzPi +KYDraf9jUej4BG2cSeZARCWPavBZD/5y4gQPaXUtbXsv+yX87049nQ== +-----END CERTIFICATE----- diff --git a/tests/elab/async_ssl_certs/key.pem b/tests/elab/async_ssl_certs/key.pem new file mode 100644 index 000000000000..556172331cda --- /dev/null +++ b/tests/elab/async_ssl_certs/key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQC7SwGfQ+WLyJwn +RlX37WMUEDT/YVZd0PV/6PPJSFx30z2vZnqMh9S7gQPvkYkon7qMtqF5jlJt3zDm +ddjuhhwHqeNj1htKnWPjhh8rc2DG7v9u/36O92fz2jKUn8qHGG80+SiW4LkE8uXu +C/ia0a1W03iT7rApICuSIgNrP5ZrXZ3pHxn4m7GxnOxm/5jt0SX3HQkRV+VMEo0c +GEq/8ZvmwnOOG14C/o/FxFw9zxw8pDTabvfLVxoHCMOu7UB3c0Hg6SzM8cD/QefW +QRLyD/rZIw34GcTs9IklWxJ0loqjY1q0c5p5991zRC2SqmM6vpAjc6dpijIAZvsy +cewlnY1bAgMBAAECggEADV4RnBHnAL6NMpppCVx2jViIx89lMCX5V6tDNxMEkoLP +rMSmK4CIVOek5cTf4rffwypHxRq81F2xKkmv9Xo55uwfsCD4aq9oETWh5OKDvj8R +mRUALekHkNZ6dLQg6tp6GXBNDtO0MN+7PG27TSV49zD5sqk/Bnhm07O8xbtQm5IA +LheZd4GPqBdTIf1krFNP86Th4X+DKrnuNmiXS4lDuhH/rheRfTQ4VK/srnrj//Zw +I+AeXwnch25CByXp+CoSHpwZGPYzfknZBjmkh1QbwMR/ivjA954BxbVsWl+/cAYh +7+MEvkrInJYqbwSVWQrVrKjRuHqI0OcvymBbGXoaHQKBgQDg+HBLB0Tt+mQqX+Kb +eo0ymK+V2Y0kprlVthTHPJHpA+zMcEBJWjlz0IpdfkjKAMrVoVJB4Fn8Y4Wj4Nzq +yV1AsZ/cHsH3NWnwiMaRvVTs7O60Vhs0G/I2lIx6T0dl4qWFjJQizrvMctNFVkvR +rh4tnGQnTMBViqKAB5CiW/o/dwKBgQDVIDNchhEAijUNJ60c4XcbrhGjlBmjDRyG +KfVM1LMQz9u20bZvOP/qL5wNHrlGqplOBUvD1o/J6b4ZIgzhWNB0WrPrBBi40pvv +9v7wCTZ3XfJ+KrGlWOfB0fPVs2kKjLd8b+1xoa7JM/RJIBmytXj3o9lS/6F7SkjH +0EQv086CPQKBgE83jCsPOzllMwIs01mWNMP9Oc7VVTrzrk09GWHytRpM9IQkfq6V +o6dhZmd3gWAIGWRSMunZezZBQRysoH3YPAr8wOK8veYzm8NEFk/ZUF9BKui7bUbT +FF4dvr2OzwBUZ554Gu2KyFw8jqJaucXyvtOmvymLgCpe78uPXmGda6gPAoGBAL3y +5xPtgTXD+ChzVjzJTkjjSWFLW9YQl32T48bIQ5gWSbKVEk3qtVvZdvHSkjrDTcNV +wQMYNis1InJwAJ7Pc2pgdL5fdlEzlDu5Hdp9u4eDud5s2suNg3EhWHr8XgBDDj3f +2/ZMreUxYuXRsFWwm9HKvKTWpOund1pu6nbeBc3ZAoGAWKJkhw7KoELqiCpTn3If +7ZN64vgqkNacXfjzc4D5oJ2aqAPJsTBdJ14+VShecgc5Kn0QriP0mTU712/GiK08 +A0Xb02+1ouerqiUE+Ea++rZphkyC0g+MKcoCWFWKDmtJuC7vtCGLOeFuLgHahqqS +yIGPWTqB+JUmYpWBWIvu0Gg= +-----END PRIVATE KEY----- diff --git a/tests/elab/async_ssl_certs/multisan.pem b/tests/elab/async_ssl_certs/multisan.pem new file mode 100644 index 000000000000..f394984d0d37 --- /dev/null +++ b/tests/elab/async_ssl_certs/multisan.pem @@ -0,0 +1,20 @@ +-----BEGIN CERTIFICATE----- +MIIDSDCCAjCgAwIBAgIUT5RcMZXOiovpwJ8d+UGsA8mm6KwwDQYJKoZIhvcNAQEL +BQAwGzEZMBcGA1UEAwwQYWxwaGEudGVzdC5sb2NhbDAgFw0yNjA3MDQxNzA3MzJa +GA8yMTI2MDYxMDE3MDczMlowGzEZMBcGA1UEAwwQYWxwaGEudGVzdC5sb2NhbDCC +ASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBALtLAZ9D5YvInCdGVfftYxQQ +NP9hVl3Q9X/o88lIXHfTPa9meoyH1LuBA++RiSifuoy2oXmOUm3fMOZ12O6GHAep +42PWG0qdY+OGHytzYMbu/27/fo73Z/PaMpSfyocYbzT5KJbguQTy5e4L+JrRrVbT +eJPusCkgK5IiA2s/lmtdnekfGfibsbGc7Gb/mO3RJfcdCRFX5UwSjRwYSr/xm+bC +c44bXgL+j8XEXD3PHDykNNpu98tXGgcIw67tQHdzQeDpLMzxwP9B59ZBEvIP+tkj +DfgZxOz0iSVbEnSWiqNjWrRzmnn33XNELZKqYzq+kCNzp2mKMgBm+zJx7CWdjVsC +AwEAAaOBgTB/MB0GA1UdDgQWBBRam+qywW30FsQlhzW2SV7dHs96NDAfBgNVHSME +GDAWgBRam+qywW30FsQlhzW2SV7dHs96NDAPBgNVHRMBAf8EBTADAQH/MCwGA1Ud +EQQlMCOCEGFscGhhLnRlc3QubG9jYWyCD2JldGEudGVzdC5sb2NhbDANBgkqhkiG +9w0BAQsFAAOCAQEARAL62Nvmy0njSp9Zze3vFUkrnT0NnAfXZ7KdTLCtOAbhNWug +zm9ytVXI2mwMSoRWIKq6Mkl1LlrqYUBf/L37Bkkx1wcxtutJ02r2nzX3ahK1S706 +WVZhFOMeS1LJJR4IcHzJ7GaQogVascwqwA/2EAwg6eGQ6og6ZAwAFfo9NJxmq3P2 +99iApuVTp6rm621c8pnXQ9ag+L4VNMZFpCYZWckc/qw7wRhTD61uPKkd2U+msz0Z +Q/OYQ3nt3ZFRG55NLflRkrOqtdcwZnmUKyEcMDG8HFN1tryj6q95lh8O49DSK1Rw +TY2KaD8AAPmYvJhFxhNIVhdhq/UDisDKunY+vQ== +-----END CERTIFICATE----- diff --git a/tests/elab/async_ssl_certs/wildcard.pem b/tests/elab/async_ssl_certs/wildcard.pem new file mode 100644 index 000000000000..717245d75d0e --- /dev/null +++ b/tests/elab/async_ssl_certs/wildcard.pem @@ -0,0 +1,20 @@ +-----BEGIN CERTIFICATE----- +MIIDNjCCAh6gAwIBAgIUFf/bf1yMwzDScis3gQg4g6aMoaYwDQYJKoZIhvcNAQEL +BQAwFzEVMBMGA1UEAwwMKi50ZXN0LmxvY2FsMCAXDTI2MDcwNDE3MDczMloYDzIx +MjYwNjEwMTcwNzMyWjAXMRUwEwYDVQQDDAwqLnRlc3QubG9jYWwwggEiMA0GCSqG +SIb3DQEBAQUAA4IBDwAwggEKAoIBAQC7SwGfQ+WLyJwnRlX37WMUEDT/YVZd0PV/ +6PPJSFx30z2vZnqMh9S7gQPvkYkon7qMtqF5jlJt3zDmddjuhhwHqeNj1htKnWPj +hh8rc2DG7v9u/36O92fz2jKUn8qHGG80+SiW4LkE8uXuC/ia0a1W03iT7rApICuS +IgNrP5ZrXZ3pHxn4m7GxnOxm/5jt0SX3HQkRV+VMEo0cGEq/8ZvmwnOOG14C/o/F +xFw9zxw8pDTabvfLVxoHCMOu7UB3c0Hg6SzM8cD/QefWQRLyD/rZIw34GcTs9Ikl +WxJ0loqjY1q0c5p5991zRC2SqmM6vpAjc6dpijIAZvsycewlnY1bAgMBAAGjeDB2 +MB0GA1UdDgQWBBRam+qywW30FsQlhzW2SV7dHs96NDAfBgNVHSMEGDAWgBRam+qy +wW30FsQlhzW2SV7dHs96NDAPBgNVHRMBAf8EBTADAQH/MCMGA1UdEQQcMBqCDCou +dGVzdC5sb2NhbIIKdGVzdC5sb2NhbDANBgkqhkiG9w0BAQsFAAOCAQEAc2uKoGPh +24uBrLtisOjXoQPmrU8LaKxKRG9+0PHKnfVHMB8barkefXDTrMSNB3zNKw3YI29Y +QDeWkD+MqtfkSyQICgMuwVKcmQUvddc056h5L37+pJhr6BoJMcI/d78w6GFgwbjo +otyzj1JI8YcBhAjbajzFwf762OuNj1baOh06uwnSenews3KnGJNeEM8xpuwdSthw +Tl+VbiRLuF2nDXjmwbWphil+3iP/0AVHUb8JLLMEypZoBLDoPAeqqVwxwxMYt2+K +T8LHCFILbr/nuBPi2/MfZ3sYSPHihu9duaHByimWueplB7lpOJZG3tnZIYZ0xxoh +S4Ssy7Qdt4wZuw== +-----END CERTIFICATE----- diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index 40f3177a980e..aa32c18335e6 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -1,4 +1,5 @@ import Std.Internal.SSL +import Lean /-! Tests for `Std.Internal.SSL.Context`: TLS context creation and configuration. @@ -9,66 +10,16 @@ behaviour are exercised in separate test files. open Std.Internal.SSL --- A self-signed `CN=localhost` certificate and its matching RSA private key, embedded so the tests --- neither shell out to `openssl` nor depend on it being installed. Valid until 2126; the smoke tests --- only load these into a context (no handshake), so expiry is never checked. To regenerate: --- openssl genrsa -out key.pem 2048 --- openssl req -new -x509 -key key.pem -out cert.pem -days 36500 -subj "/CN=localhost" - -def testCertPEM : String := -"-----BEGIN CERTIFICATE----- -MIIDCzCCAfOgAwIBAgIUfBsMFFfMmVyfKr1HjIF9ZUsOz0MwDQYJKoZIhvcNAQEL -BQAwFDESMBAGA1UEAwwJbG9jYWxob3N0MCAXDTI2MDcwNDE1NDQyNVoYDzIxMjYw -NjEwMTU0NDI1WjAUMRIwEAYDVQQDDAlsb2NhbGhvc3QwggEiMA0GCSqGSIb3DQEB -AQUAA4IBDwAwggEKAoIBAQC7SwGfQ+WLyJwnRlX37WMUEDT/YVZd0PV/6PPJSFx3 -0z2vZnqMh9S7gQPvkYkon7qMtqF5jlJt3zDmddjuhhwHqeNj1htKnWPjhh8rc2DG -7v9u/36O92fz2jKUn8qHGG80+SiW4LkE8uXuC/ia0a1W03iT7rApICuSIgNrP5Zr -XZ3pHxn4m7GxnOxm/5jt0SX3HQkRV+VMEo0cGEq/8ZvmwnOOG14C/o/FxFw9zxw8 -pDTabvfLVxoHCMOu7UB3c0Hg6SzM8cD/QefWQRLyD/rZIw34GcTs9IklWxJ0loqj -Y1q0c5p5991zRC2SqmM6vpAjc6dpijIAZvsycewlnY1bAgMBAAGjUzBRMB0GA1Ud -DgQWBBRam+qywW30FsQlhzW2SV7dHs96NDAfBgNVHSMEGDAWgBRam+qywW30FsQl -hzW2SV7dHs96NDAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQC7 -ItNAWGWOQDfjSCi2XqbKPSMbo3d8x2fQclYuFXu3QjbsmTrkzCehvGAyXHUtbnwa -wAufdEDKjfmUZmquVQd54oTCDgNtDF4729kD7pBeIIyhWyH0osPAs9mva37ripqC -MQ3kMClzS8FSBhB03CSdkypzx0znI2rIcxbMDPCIoYtkKYyvc6/yztWZfVbhHWPC -6bYAHOFpqFCOSzcZFwzWjWmAnH+pPEX8khDTTY676VG/Yuy2F/BgCdXco8VE+kiW -hh/mZMXyGuGKuYexz8Tv5M3qzdqxNmhFObyJPk/Y7XgIoBtdyHLMkqYN5fnlUMtQ -gjuJv2wDBVKza1YhNdr1 ------END CERTIFICATE----- -" - -def testKeyPEM : String := -"-----BEGIN PRIVATE KEY----- -MIIEvQIBADANBgkqhkiG9w0BAQEFAASCBKcwggSjAgEAAoIBAQC7SwGfQ+WLyJwn -RlX37WMUEDT/YVZd0PV/6PPJSFx30z2vZnqMh9S7gQPvkYkon7qMtqF5jlJt3zDm -ddjuhhwHqeNj1htKnWPjhh8rc2DG7v9u/36O92fz2jKUn8qHGG80+SiW4LkE8uXu -C/ia0a1W03iT7rApICuSIgNrP5ZrXZ3pHxn4m7GxnOxm/5jt0SX3HQkRV+VMEo0c -GEq/8ZvmwnOOG14C/o/FxFw9zxw8pDTabvfLVxoHCMOu7UB3c0Hg6SzM8cD/QefW -QRLyD/rZIw34GcTs9IklWxJ0loqjY1q0c5p5991zRC2SqmM6vpAjc6dpijIAZvsy -cewlnY1bAgMBAAECggEADV4RnBHnAL6NMpppCVx2jViIx89lMCX5V6tDNxMEkoLP -rMSmK4CIVOek5cTf4rffwypHxRq81F2xKkmv9Xo55uwfsCD4aq9oETWh5OKDvj8R -mRUALekHkNZ6dLQg6tp6GXBNDtO0MN+7PG27TSV49zD5sqk/Bnhm07O8xbtQm5IA -LheZd4GPqBdTIf1krFNP86Th4X+DKrnuNmiXS4lDuhH/rheRfTQ4VK/srnrj//Zw -I+AeXwnch25CByXp+CoSHpwZGPYzfknZBjmkh1QbwMR/ivjA954BxbVsWl+/cAYh -7+MEvkrInJYqbwSVWQrVrKjRuHqI0OcvymBbGXoaHQKBgQDg+HBLB0Tt+mQqX+Kb -eo0ymK+V2Y0kprlVthTHPJHpA+zMcEBJWjlz0IpdfkjKAMrVoVJB4Fn8Y4Wj4Nzq -yV1AsZ/cHsH3NWnwiMaRvVTs7O60Vhs0G/I2lIx6T0dl4qWFjJQizrvMctNFVkvR -rh4tnGQnTMBViqKAB5CiW/o/dwKBgQDVIDNchhEAijUNJ60c4XcbrhGjlBmjDRyG -KfVM1LMQz9u20bZvOP/qL5wNHrlGqplOBUvD1o/J6b4ZIgzhWNB0WrPrBBi40pvv -9v7wCTZ3XfJ+KrGlWOfB0fPVs2kKjLd8b+1xoa7JM/RJIBmytXj3o9lS/6F7SkjH -0EQv086CPQKBgE83jCsPOzllMwIs01mWNMP9Oc7VVTrzrk09GWHytRpM9IQkfq6V -o6dhZmd3gWAIGWRSMunZezZBQRysoH3YPAr8wOK8veYzm8NEFk/ZUF9BKui7bUbT -FF4dvr2OzwBUZ554Gu2KyFw8jqJaucXyvtOmvymLgCpe78uPXmGda6gPAoGBAL3y -5xPtgTXD+ChzVjzJTkjjSWFLW9YQl32T48bIQ5gWSbKVEk3qtVvZdvHSkjrDTcNV -wQMYNis1InJwAJ7Pc2pgdL5fdlEzlDu5Hdp9u4eDud5s2suNg3EhWHr8XgBDDj3f -2/ZMreUxYuXRsFWwm9HKvKTWpOund1pu6nbeBc3ZAoGAWKJkhw7KoELqiCpTn3If -7ZN64vgqkNacXfjzc4D5oJ2aqAPJsTBdJ14+VShecgc5Kn0QriP0mTU712/GiK08 -A0Xb02+1ouerqiUE+Ea++rZphkyC0g+MKcoCWFWKDmtJuC7vtCGLOeFuLgHahqqS -yIGPWTqB+JUmYpWBWIvu0Gg= ------END PRIVATE KEY----- -" - --- Writes the embedded certificate and key to a temporary directory, returning their paths. +open Lean in + +elab "include_cert% " path:str : term => do + let dir := (System.FilePath.mk (← readThe Core.Context).fileName).parent.getD ⟨"."⟩ + return mkStrLit (← IO.FS.readFile (dir / path.getString)) + +def testCertPEM : String := include_cert% "async_ssl_certs/cert.pem" +def testKeyPEM : String := include_cert% "async_ssl_certs/key.pem" + +-- Writes the embedded certificate and key to a temporary directory for the path-based APIs. def setupTestCerts : IO (String × String) := do let dir ← IO.FS.createTempDir let keyFile := toString (dir / "key.pem") From d5aa8d3e082326ee7aa15bf425938fba26a59e0e Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Sat, 4 Jul 2026 23:38:13 -0300 Subject: [PATCH 16/36] fix: borrowing issue --- src/Std/Internal/SSL/Context.lean | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Std/Internal/SSL/Context.lean b/src/Std/Internal/SSL/Context.lean index 66c636016b70..e0295588ca8d 100644 --- a/src/Std/Internal/SSL/Context.lean +++ b/src/Std/Internal/SSL/Context.lean @@ -51,6 +51,14 @@ end Server namespace Client +/- +A default value on a borrowed parameter wraps its type in `optParam`, which hides the `@&` marker +from the compiler: the parameter is then treated as owned and every argument leaks. So the extern +takes `caFile` explicitly and the public wrapper below carries the default. +-/ +@[extern "lean_ssl_ctx_mk_client"] +private opaque mkImpl (caFile : @& String) (verifyPeer : Bool) : IO Context.Client + /-- Creates a client-side TLS context. @@ -62,8 +70,8 @@ Trust-anchor semantics: - An empty `caFile` with `verifyPeer := true` uses just the platform default trust anchors. - `verifyPeer := false` disables peer verification entirely (the CA file is not parsed). -/ -@[extern "lean_ssl_ctx_mk_client"] -opaque mk (caFile : @& String := "") (verifyPeer : Bool := true) : IO Context.Client +@[inline] def mk (caFile : String := "") (verifyPeer : Bool := true) : IO Context.Client := + mkImpl caFile verifyPeer /-- Creates a client-side TLS context with CA trust anchors from an in-memory PEM string instead of a From 2c7c1374dfcfd485a06f305f7d055f5be2f17cce Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Fri, 24 Jul 2026 16:33:23 -0300 Subject: [PATCH 17/36] test: pin version of MIMALLOC so we can check if the problem is that :s --- CMakeLists.txt | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index aeeceb722759..cfd46ecf1568 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -125,7 +125,12 @@ if(USE_MIMALLOC) mimalloc GIT_REPOSITORY https://github.com/microsoft/mimalloc GIT_BRANCH dev3 - GIT_TAG v3.4.1 + # Pinned to the parent of f211b370 (the v3.4.0/v3.4.1 TLS-slot move to 126/127) because those + # slots collide with CoreFoundation's undocumented TLS reservations, corrupting the heap at + # thread exit on macOS/arm64 whenever CoreFoundation is linked (microsoft/mimalloc#1333). This + # commit keeps the dev3 fixes over v3.3.2 while avoiding the collision; revert to v3.4.x once + # upstream ships a fix. + GIT_TAG 41dd408d80236e8a5c9e979ec91fb7e2b18d561f # Unnecessarily deep directory structure, but it saves us from a complicated # stage0 update for now. If we ever update the other dependencies like # cadical, it might be worth reorganizing the directory structure. From 759c9eb044194371663b147b8ad28f0c8b9469cb Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Sat, 25 Jul 2026 09:09:31 -0300 Subject: [PATCH 18/36] revert: version pin --- CMakeLists.txt | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index cfd46ecf1568..aeeceb722759 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -125,12 +125,7 @@ if(USE_MIMALLOC) mimalloc GIT_REPOSITORY https://github.com/microsoft/mimalloc GIT_BRANCH dev3 - # Pinned to the parent of f211b370 (the v3.4.0/v3.4.1 TLS-slot move to 126/127) because those - # slots collide with CoreFoundation's undocumented TLS reservations, corrupting the heap at - # thread exit on macOS/arm64 whenever CoreFoundation is linked (microsoft/mimalloc#1333). This - # commit keeps the dev3 fixes over v3.3.2 while avoiding the collision; revert to v3.4.x once - # upstream ships a fix. - GIT_TAG 41dd408d80236e8a5c9e979ec91fb7e2b18d561f + GIT_TAG v3.4.1 # Unnecessarily deep directory structure, but it saves us from a complicated # stage0 update for now. If we ever update the other dependencies like # cadical, it might be worth reorganizing the directory structure. From 2a485e63fb248a001ea09cf69a6aec436776b13e Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Tue, 28 Jul 2026 12:11:22 -0300 Subject: [PATCH 19/36] feat: update minalloc to solve problem with MacOS --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index aeeceb722759..0c08bc111b04 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -125,7 +125,7 @@ if(USE_MIMALLOC) mimalloc GIT_REPOSITORY https://github.com/microsoft/mimalloc GIT_BRANCH dev3 - GIT_TAG v3.4.1 + GIT_TAG v3.4.3 # Unnecessarily deep directory structure, but it saves us from a complicated # stage0 update for now. If we ever update the other dependencies like # cadical, it might be worth reorganizing the directory structure. From 8dceee7df3ace2f106f08ec255c33180ba9701d3 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Tue, 11 Aug 2026 14:12:17 -0300 Subject: [PATCH 20/36] fix: null check, error messages and emscripten --- src/CMakeLists.txt | 3 +- src/runtime/openssl/context.cpp | 125 +++++++++++++++----------------- 2 files changed, 59 insertions(+), 69 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 983f013e9c55..65edf91e0a74 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -384,7 +384,8 @@ if(NOT "${CMAKE_SYSTEM_NAME}" MATCHES "Emscripten") string(APPEND LEAN_EXTRA_LINKER_FLAGS " -framework CoreFoundation -framework Security") endif() - # Windows reads its trust store via the CryptoAPI (CertOpenSystemStore et al.) in crypt32. + # OpenSSL's Windows trust store loader reaches the `ROOT` store through the CryptoAPI in + # crypt32, which a static libcrypto expects its consumer to provide. if(CMAKE_SYSTEM_NAME MATCHES "Windows") string(APPEND LEAN_EXTRA_LINKER_FLAGS " -lcrypt32") endif() diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index bd8aea811662..0f1209b7772f 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -5,28 +5,22 @@ Author: Sofia Rodrigues */ #include "runtime/openssl/context.h" + +#ifndef LEAN_EMSCRIPTEN + #include #include #include #include +#include #include +#include #if defined(__APPLE__) #include #include -#elif defined(_WIN32) -#include -#include -// wincrypt.h defines these as object-like macros that collide with OpenSSL's identically named -// types (e.g. X509_NAME). We only need the certificate-store API from it, so drop the macros; the -// OpenSSL types were already declared by the headers above and remain intact. -#undef X509_NAME -#undef X509_EXTENSIONS -#undef X509_CERT_PAIR -#undef PKCS7_ISSUER_AND_SERIAL -#undef PKCS7_SIGNER_INFO -#undef OCSP_REQUEST -#undef OCSP_RESPONSE +#endif + #endif namespace lean { @@ -35,6 +29,26 @@ lean_external_class * g_ssl_context_external_class = NULL; #ifndef LEAN_EMSCRIPTEN + +static lean_obj_res mk_ssl_file_error(b_obj_arg file, char const * msg) { + int errnum = 0; + unsigned long err; + + while ((err = ERR_get_error()) != 0) { + if (errnum == 0 && ERR_GET_LIB(err) == ERR_LIB_SYS) errnum = ERR_GET_REASON(err); + } + + if (errnum != 0) return lean_io_result_mk_error(decode_io_error(errnum, file)); + + lean_inc(file); + return lean_io_result_mk_error(lean_mk_io_error_invalid_argument_file(file, EINVAL, mk_string(msg))); +} + +static lean_obj_res mk_ssl_invalid_argument(char const * msg) { + ERR_clear_error(); + return lean_io_result_mk_error(lean_mk_io_error_invalid_argument(EINVAL, mk_string(msg))); +} + lean_object * mk_openssl_error(char const * where, int ssl_err) { std::string msg(where); @@ -118,46 +132,11 @@ static bool configure_ctx_options(SSL_CTX * ctx) { } // Loads the platform's system root certificates into the context's trust store so clients verify -// public servers out of the box (like a browser), independent of where OpenSSL was built to look -// for its default certificate bundle. +// public servers out of the box (like a browser). static bool load_system_trust_store(SSL_CTX * ctx) { -#if defined(_WIN32) - if (ctx == nullptr) return false; - - X509_STORE * store = SSL_CTX_get_cert_store(ctx); - if (store == nullptr) return false; - - HCERTSTORE win_store = CertOpenSystemStoreA(0, "ROOT"); - if (win_store == nullptr) { - return false; - } - - PCCERT_CONTEXT cert = nullptr; - while ((cert = CertEnumCertificatesInStore(win_store, cert)) != nullptr) { - const unsigned char * data = cert->pbCertEncoded; - - X509 * x509 = d2i_X509( - nullptr, - &data, - static_cast(cert->cbCertEncoded) - ); - - if (x509 == nullptr) { - continue; - } - - X509_STORE_add_cert(store, x509); - X509_free(x509); - } - - CertCloseStore(win_store, 0); - - // Ignore duplicate-cert errors left in OpenSSL's error queue. - ERR_clear_error(); - return true; -#elif defined(__APPLE__) - // On macOS OpenSSL's compiled-in default paths usually don't point at the Keychain, so pull the - // trusted anchor certificates directly from the Security framework instead. +#if defined(__APPLE__) + // OpenSSL's default paths don't reach the Keychain, so the trusted anchors are pulled from the + // Security framework instead. X509_STORE * store = SSL_CTX_get_cert_store(ctx); if (store == nullptr) return false; @@ -185,13 +164,13 @@ static bool load_system_trust_store(SSL_CTX * ctx) { } CFRelease(anchors); - // Drop any "already in hash table" errors left by duplicate anchors so they don't leak into a - // later error message. ERR_clear_error(); + return true; #else - // Linux/BSD (and any other platform): OpenSSL's default verify paths already resolve to the - // system certificate bundle. + // Everywhere else OpenSSL's own defaults already resolve to the system trust anchors: besides + // the default certificate file and directory, this installs the default store URI, which on + // Windows is the `ROOT` certificate store (OpenSSL 3.2 and later). return SSL_CTX_set_default_verify_paths(ctx) == 1; #endif } @@ -235,30 +214,39 @@ static lean_obj_res wrap_ssl_context(SSL_CTX * ctx) { /* Std.Internal.SSL.Context.Server.mk (certFile keyFile : @& String) : IO Context.Server */ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, b_obj_arg key_file) { + const char * cert = lean_string_cstr(cert_file); + if (strlen(cert) != lean_string_size(cert_file) - 1) return mk_embedded_nul_error(cert_file); + + const char * key = lean_string_cstr(key_file); + if (strlen(key) != lean_string_size(key_file) - 1) return mk_embedded_nul_error(key_file); + lean_obj_res err = nullptr; // The server presents its certificate but never authenticates the client (no mutual TLS). SSL_CTX * ctx = mk_ssl_ctx_base(TLS_server_method(), &err); if (ctx == nullptr) return err; - const char * cert = lean_string_cstr(cert_file); - const char * key = lean_string_cstr(key_file); - // Load the leaf certificate plus any intermediates from the PEM file (unlike // SSL_CTX_use_certificate_file, which loads only the leaf), so the server presents the full // chain and clients can build a path to a trusted root. if (SSL_CTX_use_certificate_chain_file(ctx, cert) <= 0) { SSL_CTX_free(ctx); - return mk_openssl_io_error("SSL_CTX_use_certificate_chain_file failed"); + return mk_ssl_file_error(cert_file, "could not read a PEM certificate chain"); } if (SSL_CTX_use_PrivateKey_file(ctx, key, SSL_FILETYPE_PEM) <= 0) { + unsigned long err_code = ERR_peek_last_error(); + + bool mismatch = ERR_GET_LIB(err_code) == ERR_LIB_X509 && ERR_GET_REASON(err_code) == X509_R_KEY_VALUES_MISMATCH; + SSL_CTX_free(ctx); - return mk_openssl_io_error("SSL_CTX_use_PrivateKey_file failed"); + return mk_ssl_file_error(key_file, mismatch + ? "the private key does not match the certificate" + : "could not read an unencrypted PEM private key"); } if (SSL_CTX_check_private_key(ctx) != 1) { SSL_CTX_free(ctx); - return mk_openssl_io_error("SSL_CTX_check_private_key failed"); + return mk_ssl_file_error(key_file, "the private key does not match the certificate"); } return wrap_ssl_context(ctx); @@ -266,6 +254,9 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, /* Std.Internal.SSL.Context.Client.mk (caFile : @& String) (verifyPeer : Bool) : IO Context.Client */ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, uint8_t verify_peer) { + const char * ca = lean_string_cstr(ca_file); + if (strlen(ca) != lean_string_size(ca_file) - 1) return mk_embedded_nul_error(ca_file); + lean_obj_res err = nullptr; SSL_CTX * ctx = mk_ssl_ctx_base(TLS_client_method(), &err); if (ctx == nullptr) return err; @@ -283,12 +274,10 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, ui return mk_openssl_io_error("failed to load system trust store"); } - const char * ca = lean_string_cstr(ca_file); - if (ca[0] != '\0') { if (SSL_CTX_load_verify_locations(ctx, ca, nullptr) != 1) { SSL_CTX_free(ctx); - return mk_openssl_io_error("SSL_CTX_load_verify_locations failed"); + return mk_ssl_file_error(ca_file, "could not read PEM CA certificates"); } } @@ -326,7 +315,7 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca if (pem_size > INT_MAX) { SSL_CTX_free(ctx); - return mk_openssl_io_error("CA PEM string is too large"); + return mk_ssl_invalid_argument("the CA PEM string is too large"); } BIO * bio = BIO_new_mem_buf(pem, (int)pem_size); @@ -342,7 +331,7 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca if (infos == nullptr) { SSL_CTX_free(ctx); - return mk_openssl_io_error("PEM_X509_INFO_read_bio failed"); + return mk_ssl_invalid_argument("could not read PEM CA certificates from the given string"); } // Add the parsed certificates to the context's verification store, which already holds the @@ -372,7 +361,7 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca if (cert_count == 0) { SSL_CTX_free(ctx); - return mk_openssl_io_error("no certificates found in CA PEM"); + return mk_ssl_invalid_argument("the given CA PEM string contains no certificates"); } SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER, nullptr); From 485d2973115fa5bf998c49755b7485545d921489 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Tue, 11 Aug 2026 20:26:41 -0300 Subject: [PATCH 21/36] chore: comment --- src/runtime/openssl/context.cpp | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 0f1209b7772f..602d113f164f 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -168,10 +168,9 @@ static bool load_system_trust_store(SSL_CTX * ctx) { return true; #else - // Everywhere else OpenSSL's own defaults already resolve to the system trust anchors: besides - // the default certificate file and directory, this installs the default store URI, which on - // Windows is the `ROOT` certificate store (OpenSSL 3.2 and later). - return SSL_CTX_set_default_verify_paths(ctx) == 1; + // Everywhere else OpenSSL's own defaults already resolve to the system trust anchors. + // Works on Windows if OpenSSL version is greater than 3.2. + return SSL_CTX_set_default_verify_paths(ctx); #endif } From daf29d84ff1c2025b02754ffe9a53d6801a879ba Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Wed, 12 Aug 2026 20:30:16 -0300 Subject: [PATCH 22/36] test: add tests for each one of the possible errors --- tests/elab/async_ssl_certs/README.md | 14 ++ tests/elab/async_ssl_certs/corrupt.pem | 19 +++ tests/elab/async_ssl_certs/key2.pem | 28 ++++ tests/elab/async_ssl_context.lean | 205 +++++++++++++++++++++++-- 4 files changed, 249 insertions(+), 17 deletions(-) create mode 100644 tests/elab/async_ssl_certs/corrupt.pem create mode 100644 tests/elab/async_ssl_certs/key2.pem diff --git a/tests/elab/async_ssl_certs/README.md b/tests/elab/async_ssl_certs/README.md index 74a574cdb59a..6c3bcdf831f8 100644 --- a/tests/elab/async_ssl_certs/README.md +++ b/tests/elab/async_ssl_certs/README.md @@ -14,10 +14,16 @@ certificates are rejected). | file | subject | notes | |---|---|---| | `key.pem` | | RSA-2048 private key for all certs below | +| `key2.pem` | | second RSA-2048 key, matching none of the certificates | | `cert.pem` | `CN=localhost` | standard server cert (no SAN; hostname matching uses the CN fallback) | | `wildcard.pem` | `CN=*.test.local` | SAN: `DNS:*.test.local, DNS:test.local` | | `multisan.pem` | `CN=alpha.test.local` | SAN: `DNS:alpha.test.local, DNS:beta.test.local` | | `expired.pem` | `CN=localhost` | valid 2020-01-01 → 2020-01-02 only | +| `corrupt.pem` | | `cert.pem` with one bit flipped in the first DER byte (`SEQUENCE` tag → `SET`) | + +`corrupt.pem` still has intact PEM armour and valid base64 — it differs from `cert.pem` by a single +character — so it only fails once the certificate body is decoded, which exercises the +"malformed certificate" paths rather than the "not a PEM file" ones. To regenerate: @@ -31,4 +37,12 @@ openssl req -new -x509 -key key.pem -out multisan.pem -days 36500 -subj "/CN=alp openssl req -new -key key.pem -out expired.csr -subj "/CN=localhost" openssl x509 -req -in expired.csr -signkey key.pem -out expired.pem -set_serial 99 \ -not_before 20200101000000Z -not_after 20200102000000Z && rm expired.csr +openssl genrsa -out key2.pem 2048 +python3 -c ' +import base64, textwrap +der = bytearray(base64.b64decode("".join(open("cert.pem").read().strip().splitlines()[1:-1]))) +der[0] = 0x31 +body = "\n".join(textwrap.wrap(base64.b64encode(bytes(der)).decode(), 64)) +open("corrupt.pem", "w").write("-----BEGIN CERTIFICATE-----\n" + body + "\n-----END CERTIFICATE-----\n") +' ``` diff --git a/tests/elab/async_ssl_certs/corrupt.pem b/tests/elab/async_ssl_certs/corrupt.pem new file mode 100644 index 000000000000..2b4ed0ec16b9 --- /dev/null +++ b/tests/elab/async_ssl_certs/corrupt.pem @@ -0,0 +1,19 @@ +-----BEGIN CERTIFICATE----- +MYIDCzCCAfOgAwIBAgIUfBsMFFfMmVyfKr1HjIF9ZUsOz0MwDQYJKoZIhvcNAQEL +BQAwFDESMBAGA1UEAwwJbG9jYWxob3N0MCAXDTI2MDcwNDE1NDQyNVoYDzIxMjYw +NjEwMTU0NDI1WjAUMRIwEAYDVQQDDAlsb2NhbGhvc3QwggEiMA0GCSqGSIb3DQEB +AQUAA4IBDwAwggEKAoIBAQC7SwGfQ+WLyJwnRlX37WMUEDT/YVZd0PV/6PPJSFx3 +0z2vZnqMh9S7gQPvkYkon7qMtqF5jlJt3zDmddjuhhwHqeNj1htKnWPjhh8rc2DG +7v9u/36O92fz2jKUn8qHGG80+SiW4LkE8uXuC/ia0a1W03iT7rApICuSIgNrP5Zr +XZ3pHxn4m7GxnOxm/5jt0SX3HQkRV+VMEo0cGEq/8ZvmwnOOG14C/o/FxFw9zxw8 +pDTabvfLVxoHCMOu7UB3c0Hg6SzM8cD/QefWQRLyD/rZIw34GcTs9IklWxJ0loqj +Y1q0c5p5991zRC2SqmM6vpAjc6dpijIAZvsycewlnY1bAgMBAAGjUzBRMB0GA1Ud +DgQWBBRam+qywW30FsQlhzW2SV7dHs96NDAfBgNVHSMEGDAWgBRam+qywW30FsQl +hzW2SV7dHs96NDAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQC7 +ItNAWGWOQDfjSCi2XqbKPSMbo3d8x2fQclYuFXu3QjbsmTrkzCehvGAyXHUtbnwa +wAufdEDKjfmUZmquVQd54oTCDgNtDF4729kD7pBeIIyhWyH0osPAs9mva37ripqC +MQ3kMClzS8FSBhB03CSdkypzx0znI2rIcxbMDPCIoYtkKYyvc6/yztWZfVbhHWPC +6bYAHOFpqFCOSzcZFwzWjWmAnH+pPEX8khDTTY676VG/Yuy2F/BgCdXco8VE+kiW +hh/mZMXyGuGKuYexz8Tv5M3qzdqxNmhFObyJPk/Y7XgIoBtdyHLMkqYN5fnlUMtQ +gjuJv2wDBVKza1YhNdr1 +-----END CERTIFICATE----- diff --git a/tests/elab/async_ssl_certs/key2.pem b/tests/elab/async_ssl_certs/key2.pem new file mode 100644 index 000000000000..ccf9868835ab --- /dev/null +++ b/tests/elab/async_ssl_certs/key2.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvgIBADANBgkqhkiG9w0BAQEFAASCBKgwggSkAgEAAoIBAQDXp0dIiVIxGvXw +Kc4gvqknV39r0k/ACEi903siuNDiHlM2BJtZ0RSNO2EyZz+sUKUiJsNPVBSRQQru +3dwwt2Lg8JSY3/3Rcs/vgsrHB/fGRFGHgHFgj++XX2BxwnywQ7BgwtjTNNdOrDeE +O6goJYrgfc/vBMgMJH+o1dnGwdkUWD7/ZbpZM7wIPCDhLnTuyncoMH8IUdMW6iGp +Tyu5NOQR0rjMB3rqw0KyD6y8uTwPTcV+53zAfmE+kQ+n2p2wxkWE9f50RACTMjac +7ZKQMxI3/kEqFUbUIGHVBGiM1Ly6VZ6oSo//9e26nbRgghRkiHXkwJa0OJfsBXIq +LiRiNXGXAgMBAAECggEAHO3QNq9RKswylMKO576b426t5bFjSF/0Hh7aBFjlkIe/ +4t2wV1agWqfODJxkIsH4vQGVLrWZQrkGde+mI5TeO02aqX1Wx7uOoFMbz6JGfz7X +7wTwcKMuYVCGmAwefOi/puNMgdyzS1b35ZG5J5WNsTq/Y5FxIovc4jG50ptbewpy +R1xl4lna0nI5mwnNmrNuz6gLHfNPrIygXCD4Rn1EIQXpGI9bI+gRcue7O7aR7j83 +2OTnC90Mg9Hv5JssqwC1dxwTg6DJ00VP+YqJrA53WK/2X72TboVE+Uojh/jC3vXt +G8UuunhcvAVm1gHntQeZhiPiHI5l+N2J2qXZjliKBQKBgQD84NSg/MgEwvGCbQbA +aEDDVqKZ3ued1bmKsegvBYuoxxPAyS8uWjQE+LsskLXSx7BghblV65ti4taiQiVv +iX8O/NPbqOUbsPUGCHjhJjpLOR3/3jtaXjEetPkjRaOMv0xsd6MhQiIbktqlyCnW +RwaxdAFeKyiSDfziuY/pSa8+owKBgQDaUM55kCTOVrfFKOoG43wafVxeystuz/7Q +OLijwkcRYZpvfMSJNkUX/IgUvSX4qs3ymuZu6HOwiqA2yIVugFejF8MD1b4oikQz +RxYQg5P0mynWSuCShhNEn4JjIu4waTL61/aqX3MysDWz68r3I7cCi1mS0ht+t9uq +u8wpAdZ0fQKBgApmGHhSTMtdVN8fKqLo5pjhzCf1saKc8ldQv5KHcNnM7fQEkesf +DHqT2+aWQNPdIFSnyxpMaQRk/ZyIic+PYOk13mRvCpTb7weDe60OjGEhhSlLczdh +HjX8DS61I2ebSkI/nTa16H8nx9P/ajEElLLhaVj8/1saNicAqHlYbVtvAoGBAMEm +4zbcWCQSxy5xv3Ruyfsp1JKte4VEEt8of/uqxHPVVeyzh7MaR9EsBT3MB49VlzbA +44VWthyI2az+hkc419CdElYPQtndUu/HQfdEYp/0s/Q7dStN4jhBo/uQCQrd2FPk +xQEByAsdqbXQtVcoyx8+KPbkW50mj/wjgUL6tEGFAoGBANFfxX7FFIAHokerNCQC +juGi/Vm4hfKe2GZ9wpNPv1XTJ8IjsQ//ou1Fd0HTkOzlllL7mdBzjOHN+wcB3FRp +20OHlJX7vP6pZr6Hov1UBgqQcaksloysecPiPJpGcjXv9aBu0kw2M+/19R0pkHF1 +9TR36Io5p4bDq/W+IfPgv9QI +-----END PRIVATE KEY----- diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index aa32c18335e6..0e0deb82bbe1 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -18,6 +18,15 @@ elab "include_cert% " path:str : term => do def testCertPEM : String := include_cert% "async_ssl_certs/cert.pem" def testKeyPEM : String := include_cert% "async_ssl_certs/key.pem" +def testWildcardCertPEM : String := include_cert% "async_ssl_certs/wildcard.pem" +def testMultiSANCertPEM : String := include_cert% "async_ssl_certs/multisan.pem" +def testCorruptCertPEM : String := include_cert% "async_ssl_certs/corrupt.pem" + +-- Matches none of the certificates above, so it is only good for provoking a key/cert mismatch. +def testUnrelatedKeyPEM : String := include_cert% "async_ssl_certs/key2.pem" + +-- Three distinct certificates in one file, the shape of a real CA bundle. +def testBundlePEM : String := testCertPEM ++ testWildcardCertPEM ++ testMultiSANCertPEM -- Writes the embedded certificate and key to a temporary directory for the path-based APIs. def setupTestCerts : IO (String × String) := do @@ -50,11 +59,49 @@ def testMkClientFromPEM (certFile : String) : IO Unit := do let caPEM ← IO.FS.readFile certFile let _clientCtx ← Context.Client.mkFromPEM caPEM true --- Asserts that an IO action fails, used to exercise the rejection/error paths. -def assertThrows (label : String) (act : IO Unit) : IO Unit := do +-- Materializes rejected input on disk for the path-based APIs. +def writeTempFile (name contents : String) : IO String := do + let dir ← IO.FS.createTempDir + let path := toString (dir / name) + IO.FS.writeFile path contents + return path + +def setupMalformedFile : IO String := writeTempFile "junk.pem" "this is not pem\n" + +def setupCorruptCert : IO String := writeTempFile "corrupt.pem" testCorruptCertPEM + +def setupUnrelatedKey : IO String := writeTempFile "key2.pem" testUnrelatedKeyPEM + +def setupBundle : IO String := writeTempFile "bundle.pem" testBundlePEM + +def setupDuplicateBundle : IO String := writeTempFile "dup.pem" (testBundlePEM ++ testCertPEM) + +-- Asserts that an IO action fails with exactly `expected` as its message. +def assertErrorMessage (label expected : String) (act : IO Unit) : IO Unit := do match ← act.toBaseIO with | .ok _ => throw <| IO.userError s!"{label}: expected failure, but it succeeded" - | .error _ => pure () + | .error e => + let actual := toString e + unless actual == expected do + throw <| IO.userError s!"{label}:\nexpected error: {expected}\nactual error: {actual}" + +-- A missing file reaches OpenSSL's error queue as an `ENOENT` entry, which is turned back into the +-- corresponding `IO.Error` on the offending path. +def missingFileError (path : String) : String := + s!"no such file or directory (error code: 2)\n file: {path}" + +-- Failures with no `errno` behind them (unparsable PEM, key/cert mismatch) are reported as `EINVAL` +-- plus a description of what went wrong with the material on the offending path. +def malformedFileError (path detail : String) : String := + s!"invalid argument (error code: 22, {detail})\n file: {path}" + +-- A path is rejected before it reaches OpenSSL if it cannot be passed as a C string. +def nulByteError (path : String) : String := + s!"invalid argument (error code: 22, string contains NUL bytes)\n file: {path}" + +-- The in-memory variants report the same way, but have no path to attach. +def malformedPEMError (detail : String) : String := + s!"invalid argument (error code: 22, {detail})" -- An empty CA bundle with `verifyPeer := true` falls back to the platform trust anchors and succeeds. def testMkFromPEMEmptyFallsBack : IO Unit := do @@ -65,32 +112,125 @@ def testMkFromPEMNoVerify (certFile : String) : IO Unit := do let caPEM ← IO.FS.readFile certFile let _clientCtx ← Context.Client.mkFromPEM caPEM false --- Malformed PEM input is rejected rather than silently ignored. +-- A bundle of several distinct certificates is loaded in full: every certificate in the PEM becomes +-- a trust anchor, not just the first one. +def testMkFromPEMAcceptsBundle : IO Unit := do + let _clientCtx ← Context.Client.mkFromPEM testBundlePEM true + +def testMkAcceptsBundleFile (bundleFile : String) : IO Unit := do + let _clientCtx ← Context.Client.mk bundleFile true + +-- Repeated certificates are skipped instead of failing, so a bundle that overlaps the system trust +-- anchors (or repeats itself) still yields a usable context. +def testMkFromPEMAcceptsDuplicates : IO Unit := do + let _clientCtx ← Context.Client.mkFromPEM (testCertPEM ++ testCertPEM) true + +def testMkAcceptsDuplicatesInFile (dupFile : String) : IO Unit := do + let _clientCtx ← Context.Client.mk dupFile true + +-- Unlike the path-based APIs, `mkFromPEM` hands OpenSSL an explicit length rather than a C string, +-- so a NUL byte is data (here: trailing junk after a complete certificate) and not an error. +def testMkFromPEMAcceptsNulBytes : IO Unit := do + let _clientCtx ← Context.Client.mkFromPEM (testCertPEM.push '\x00') true + def testMkFromPEMRejectsGarbage : IO Unit := do - assertThrows "garbage PEM" + assertErrorMessage "garbage PEM" + (malformedPEMError "the given CA PEM string contains no certificates") (discard <| Context.Client.mkFromPEM "not a certificate at all" true) --- A well-formed PEM block that contains no certificate is rejected. +def testMkNoVerifyIgnoresCorruptCAFile (corruptFile : String) : IO Unit := do + let _clientCtx ← Context.Client.mk corruptFile false + def testMkFromPEMRejectsEmptyBlock : IO Unit := do - assertThrows "PEM without certificates" + assertErrorMessage "PEM without certificates" + (malformedPEMError "could not read PEM CA certificates from the given string") (discard <| Context.Client.mkFromPEM "-----BEGIN CERTIFICATE-----\n-----END CERTIFICATE-----\n" true) --- A non-existent CA file with `verifyPeer := true` is rejected (the file-based additive path fails). +def testMkFromPEMRejectsCorruptCert : IO Unit := do + assertErrorMessage "one-bit-flipped CA PEM" + (malformedPEMError "could not read PEM CA certificates from the given string") + (discard <| Context.Client.mkFromPEM testCorruptCertPEM true) + +def testMkRejectsMalformedCAFile (junkFile : String) : IO Unit := do + assertErrorMessage "malformed CA file" + (malformedFileError junkFile "could not read PEM CA certificates") + (discard <| Context.Client.mk junkFile true) + +def testMkRejectsCorruptCAFile (corruptFile : String) : IO Unit := do + assertErrorMessage "one-bit-flipped CA file" + (malformedFileError corruptFile "could not read PEM CA certificates") + (discard <| Context.Client.mk corruptFile true) + def testMkRejectsMissingCAFile : IO Unit := do - assertThrows "missing CA file" + assertErrorMessage "missing CA file" + (missingFileError "/nonexistent/path/to/ca.pem") (discard <| Context.Client.mk "/nonexistent/path/to/ca.pem" true) --- A server context with non-existent certificate/key files is rejected. -def testMkServerRejectsMissingFiles : IO Unit := do - assertThrows "missing server cert" - (discard <| Context.Server.mk "/nonexistent/cert.pem" "/nonexistent/key.pem") +def testMkServerRejectsMissingCert (keyFile : String) : IO Unit := do + assertErrorMessage "missing server cert" + (missingFileError "/nonexistent/cert.pem") + (discard <| Context.Server.mk "/nonexistent/cert.pem" keyFile) + +def testMkServerRejectsMissingKey (certFile : String) : IO Unit := do + assertErrorMessage "missing server key" + (missingFileError "/nonexistent/key.pem") + (discard <| Context.Server.mk certFile "/nonexistent/key.pem") + +def testMkServerRejectsMalformedKey (certFile junkFile : String) : IO Unit := do + assertErrorMessage "malformed server key" + (malformedFileError junkFile "could not read an unencrypted PEM private key") + (discard <| Context.Server.mk certFile junkFile) + +def testMkServerRejectsCertAsKey (certFile : String) : IO Unit := do + assertErrorMessage "certificate used as server key" + (malformedFileError certFile "could not read an unencrypted PEM private key") + (discard <| Context.Server.mk certFile certFile) + +def testMkServerRejectsMalformedCert (junkFile keyFile : String) : IO Unit := do + assertErrorMessage "malformed server cert" + (malformedFileError junkFile "could not read a PEM certificate chain") + (discard <| Context.Server.mk junkFile keyFile) + +def testMkServerRejectsCorruptCert (corruptFile keyFile : String) : IO Unit := do + assertErrorMessage "one-bit-flipped server cert" + (malformedFileError corruptFile "could not read a PEM certificate chain") + (discard <| Context.Server.mk corruptFile keyFile) --- A server context whose certificate and key do not match is rejected (here by swapping the file --- arguments so neither parses as the expected PEM object). def testMkServerRejectsSwappedFiles (certFile keyFile : String) : IO Unit := do - assertThrows "swapped server cert/key" + assertErrorMessage "swapped server cert/key" + (malformedFileError keyFile "could not read a PEM certificate chain") (discard <| Context.Server.mk keyFile certFile) +-- Both files parse, but the key belongs to a different pair, so the context is rejected before any +-- session can present a certificate the peer cannot use. +def testMkServerRejectsMismatchedKey (certFile key2File : String) : IO Unit := do + assertErrorMessage "server key from a different pair" + (malformedFileError key2File "the private key does not match the certificate") + (discard <| Context.Server.mk certFile key2File) + +def testMkServerRejectsNulInCert (keyFile : String) : IO Unit := do + let certPath := "cert\x00.pem" + assertErrorMessage "NUL byte in server cert path" + (nulByteError certPath) + (discard <| Context.Server.mk certPath keyFile) + +def testMkServerRejectsNulInKey (certFile : String) : IO Unit := do + let keyPath := "key\x00.pem" + assertErrorMessage "NUL byte in server key path" + (nulByteError keyPath) + (discard <| Context.Server.mk certFile keyPath) + +-- The CA path is checked before `verifyPeer`, so a NUL is rejected even when the file would never +-- have been opened. +def testMkRejectsNulInCAFile : IO Unit := do + let caPath := "ca\x00.pem" + assertErrorMessage "NUL byte in CA path" + (nulByteError caPath) + (discard <| Context.Client.mk caPath true) + assertErrorMessage "NUL byte in CA path without verification" + (nulByteError caPath) + (discard <| Context.Client.mk caPath false) + #eval do let (certFile, keyFile) ← setupTestCerts testContextCreation certFile keyFile @@ -105,14 +245,45 @@ def testMkServerRejectsSwappedFiles (certFile keyFile : String) : IO Unit := do let (certFile, _) ← setupTestCerts testMkFromPEMNoVerify certFile +#eval do + testMkFromPEMAcceptsBundle + testMkFromPEMAcceptsDuplicates + testMkFromPEMAcceptsNulBytes + testMkAcceptsBundleFile (← setupBundle) + testMkAcceptsDuplicatesInFile (← setupDuplicateBundle) + #eval testMkFromPEMRejectsGarbage #eval testMkFromPEMRejectsEmptyBlock #eval testMkRejectsMissingCAFile -#eval testMkServerRejectsMissingFiles +#eval do + let junkFile ← setupMalformedFile + testMkRejectsMalformedCAFile junkFile + +#eval testMkFromPEMRejectsCorruptCert + +#eval do + let corruptFile ← setupCorruptCert + testMkRejectsCorruptCAFile corruptFile + testMkNoVerifyIgnoresCorruptCAFile corruptFile #eval do let (certFile, keyFile) ← setupTestCerts + let junkFile ← setupMalformedFile + let corruptFile ← setupCorruptCert + testMkServerRejectsMissingCert keyFile + testMkServerRejectsMissingKey certFile + testMkServerRejectsMalformedCert junkFile keyFile + testMkServerRejectsMalformedKey certFile junkFile + testMkServerRejectsCorruptCert corruptFile keyFile + testMkServerRejectsCertAsKey certFile testMkServerRejectsSwappedFiles certFile keyFile + testMkServerRejectsMismatchedKey certFile (← setupUnrelatedKey) + +#eval do + let (certFile, keyFile) ← setupTestCerts + testMkServerRejectsNulInCert keyFile + testMkServerRejectsNulInKey certFile + testMkRejectsNulInCAFile From e2dca67546f2066e4e28b7b44a12807114abc20f Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Wed, 12 Aug 2026 20:43:00 -0300 Subject: [PATCH 23/36] style: linebreaks --- tests/elab/async_ssl_context.lean | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index 0e0deb82bbe1..449585ec9740 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -201,8 +201,6 @@ def testMkServerRejectsSwappedFiles (certFile keyFile : String) : IO Unit := do (malformedFileError keyFile "could not read a PEM certificate chain") (discard <| Context.Server.mk keyFile certFile) --- Both files parse, but the key belongs to a different pair, so the context is rejected before any --- session can present a certificate the peer cannot use. def testMkServerRejectsMismatchedKey (certFile key2File : String) : IO Unit := do assertErrorMessage "server key from a different pair" (malformedFileError key2File "the private key does not match the certificate") @@ -210,12 +208,14 @@ def testMkServerRejectsMismatchedKey (certFile key2File : String) : IO Unit := d def testMkServerRejectsNulInCert (keyFile : String) : IO Unit := do let certPath := "cert\x00.pem" + assertErrorMessage "NUL byte in server cert path" (nulByteError certPath) (discard <| Context.Server.mk certPath keyFile) def testMkServerRejectsNulInKey (certFile : String) : IO Unit := do let keyPath := "key\x00.pem" + assertErrorMessage "NUL byte in server key path" (nulByteError keyPath) (discard <| Context.Server.mk certFile keyPath) @@ -224,9 +224,11 @@ def testMkServerRejectsNulInKey (certFile : String) : IO Unit := do -- have been opened. def testMkRejectsNulInCAFile : IO Unit := do let caPath := "ca\x00.pem" + assertErrorMessage "NUL byte in CA path" (nulByteError caPath) (discard <| Context.Client.mk caPath true) + assertErrorMessage "NUL byte in CA path without verification" (nulByteError caPath) (discard <| Context.Client.mk caPath false) @@ -252,11 +254,14 @@ def testMkRejectsNulInCAFile : IO Unit := do testMkAcceptsBundleFile (← setupBundle) testMkAcceptsDuplicatesInFile (← setupDuplicateBundle) -#eval testMkFromPEMRejectsGarbage +#eval + testMkFromPEMRejectsGarbage -#eval testMkFromPEMRejectsEmptyBlock +#eval + testMkFromPEMRejectsEmptyBlock -#eval testMkRejectsMissingCAFile +#eval + testMkRejectsMissingCAFile #eval do let junkFile ← setupMalformedFile @@ -273,6 +278,7 @@ def testMkRejectsNulInCAFile : IO Unit := do let (certFile, keyFile) ← setupTestCerts let junkFile ← setupMalformedFile let corruptFile ← setupCorruptCert + testMkServerRejectsMissingCert keyFile testMkServerRejectsMissingKey certFile testMkServerRejectsMalformedCert junkFile keyFile From 923b981c5e26965d60e5bdd8e6d7b16702c15c6e Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Sat, 15 Aug 2026 13:35:22 -0300 Subject: [PATCH 24/36] fix: client_from_pem possible misusage --- src/runtime/openssl/context.cpp | 240 ++++++++++++-------------- src/runtime/openssl/context.h | 13 +- tests/elab/async_ssl_certs/README.md | 4 + tests/elab/async_ssl_certs/eckey.pem | 5 + tests/elab/async_ssl_certs/enckey.pem | 30 ++++ tests/elab/async_ssl_context.lean | 28 +++ 6 files changed, 184 insertions(+), 136 deletions(-) create mode 100644 tests/elab/async_ssl_certs/eckey.pem create mode 100644 tests/elab/async_ssl_certs/enckey.pem diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 602d113f164f..e1a36b628728 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -8,13 +8,15 @@ Author: Sofia Rodrigues #ifndef LEAN_EMSCRIPTEN +#include #include #include #include #include -#include -#include -#include +#include +#include +#include +#include #if defined(__APPLE__) #include @@ -25,7 +27,7 @@ Author: Sofia Rodrigues namespace lean { -lean_external_class * g_ssl_context_external_class = NULL; +lean_external_class * g_ssl_context_external_class = nullptr; #ifndef LEAN_EMSCRIPTEN @@ -44,6 +46,8 @@ static lean_obj_res mk_ssl_file_error(b_obj_arg file, char const * msg) { return lean_io_result_mk_error(lean_mk_io_error_invalid_argument_file(file, EINVAL, mk_string(msg))); } +// Reports a failure that has no errno behind it. The OpenSSL error queue is discarded rather than +// appended, so its entries cannot leak into a later, unrelated diagnosis. static lean_obj_res mk_ssl_invalid_argument(char const * msg) { ERR_clear_error(); return lean_io_result_mk_error(lean_mk_io_error_invalid_argument(EINVAL, mk_string(msg))); @@ -54,7 +58,7 @@ lean_object * mk_openssl_error(char const * where, int ssl_err) { if (ssl_err != 0) msg += " (ssl_error=" + std::to_string(ssl_err) + ")"; - // Drain up to 10 entries from the OpenSSL error queue; mark with "(truncated)" if more remain. + // Drains up to 10 entries from the OpenSSL error queue; marks with "(truncated)" if more remain. unsigned long err; bool first = true; int cap = 10; @@ -67,25 +71,20 @@ lean_object * mk_openssl_error(char const * where, int ssl_err) { first = false; } - if (!first && ERR_peek_error() != 0) { + if (ERR_peek_error() != 0) { msg += "; ... (truncated)"; ERR_clear_error(); } - return lean_mk_io_user_error(mk_string(msg.c_str())); + return lean_mk_io_user_error(mk_string(msg)); } static void lean_ssl_context_finalizer(void * ptr) { - lean_ssl_context_object * obj = (lean_ssl_context_object*)ptr; - SSL_CTX_free(obj->ctx); - free(obj); + SSL_CTX_free((SSL_CTX*)ptr); } void initialize_openssl_context() { - g_ssl_context_external_class = lean_register_external_class(lean_ssl_context_finalizer, [](void * obj, lean_object * f) { - (void)obj; - (void)f; - }); + g_ssl_context_external_class = lean_register_external_class(lean_ssl_context_finalizer, [](void *, lean_object *) {}); } static bool configure_ctx_options(SSL_CTX * ctx) { @@ -99,18 +98,17 @@ static bool configure_ctx_options(SSL_CTX * ctx) { // but set explicitly so the intent is clear. SSL_OP_NO_COMPRESSION | - // Disables session tickets (TLS 1.2 RFC 5077 and TLS 1.3 PSK resumption). - // This prevents 0-RTT session resumption but avoids stateful ticket - // management complexity and removes one tracking vector in server deployments. - // If session resumption performance matters, remove this flag and implement - // a ticket key rotation strategy. + // Disables RFC 5077 session tickets in TLS 1.2. TLS 1.3 tickets cannot be switched off this + // way: there the flag only downgrades them to the stateful form, which the disabled session + // cache below then suppresses. If resumption performance matters, remove this flag and + // implement a ticket key rotation strategy. SSL_OP_NO_TICKET ); - // Disable the internal session cache as well. SSL_OP_NO_TICKET only suppresses ticket-based - // resumption (RFC 5077 and TLS 1.3 PSK); a TLS 1.2 server still offers session-ID resumption - // through the cache, which defaults to SSL_SESS_CACHE_SERVER. Turning the cache off makes the - // "no session resumption" guarantee hold for both client and server contexts. + // Backs the flag above. A TLS 1.2 server still offers session-ID resumption through this cache + // (which defaults to SSL_SESS_CACHE_SERVER), and the TLS 1.3 stateful tickets left by + // SSL_OP_NO_TICKET are stored in it too, so turning it off is what makes "no session + // resumption" hold for both protocol versions. SSL_CTX_set_session_cache_mode(ctx, SSL_SESS_CACHE_OFF); // Reject TLS 1.0 and 1.1. Both are deprecated (RFC 8996) and have known @@ -132,19 +130,26 @@ static bool configure_ctx_options(SSL_CTX * ctx) { } // Loads the platform's system root certificates into the context's trust store so clients verify -// public servers out of the box (like a browser). +// public servers out of the box (like a browser). Success does not promise a non-empty trust store: +// only the Apple branch loads anchors eagerly and can count them. static bool load_system_trust_store(SSL_CTX * ctx) { #if defined(__APPLE__) - // OpenSSL's default paths don't reach the Keychain, so the trusted anchors are pulled from the - // Security framework instead. + // OpenSSL's default paths don't reach the Keychain, so the anchors are pulled from the Security + // framework instead. This yields the built-in system roots only: certificates a user or an + // administrator added to a keychain are not included, and per-certificate trust settings are + // not consulted, so a root the user explicitly distrusted is still added here. X509_STORE * store = SSL_CTX_get_cert_store(ctx); - if (store == nullptr) return false; CFArrayRef anchors = nullptr; - if (SecTrustCopyAnchorCertificates(&anchors) != errSecSuccess || anchors == nullptr) { + OSStatus status = SecTrustCopyAnchorCertificates(&anchors); + + if (status != errSecSuccess || anchors == nullptr) { + if (anchors != nullptr) CFRelease(anchors); return false; } + int added = 0; + for (CFIndex i = 0, n = CFArrayGetCount(anchors); i < n; i++) { SecCertificateRef cert = (SecCertificateRef)CFArrayGetValueAtIndex(anchors, i); if (cert == nullptr) continue; @@ -158,19 +163,17 @@ static bool load_system_trust_store(SSL_CTX * ctx) { if (x509 == nullptr) continue; // X509_STORE_add_cert bumps the certificate's refcount, so drop our own reference after. - // Duplicate anchors are harmless and ignored. - X509_STORE_add_cert(store, x509); + // An anchor already in the store is reported as success and counted like any other. + if (X509_STORE_add_cert(store, x509) == 1) added++; X509_free(x509); } CFRelease(anchors); ERR_clear_error(); - return true; + return added > 0; #else - // Everywhere else OpenSSL's own defaults already resolve to the system trust anchors. - // Works on Windows if OpenSSL version is greater than 3.2. - return SSL_CTX_set_default_verify_paths(ctx); + return SSL_CTX_set_default_verify_paths(ctx) == 1; #endif } @@ -188,6 +191,8 @@ static SSL_CTX * mk_ssl_ctx_base(const SSL_METHOD * method, lean_obj_res * err) if (!configure_ctx_options(ctx)) { SSL_CTX_free(ctx); + // SSL_CTX_set_min_proto_version is the only way to get here, and it reports failure without + // pushing anything onto the OpenSSL error queue, so this message has to stand on its own. *err = mk_openssl_io_error("SSL_CTX_set_min_proto_version failed"); return nullptr; } @@ -197,18 +202,10 @@ static SSL_CTX * mk_ssl_ctx_base(const SSL_METHOD * method, lean_obj_res * err) // Wraps a fully configured SSL_CTX into a Lean external object, taking ownership of ctx. static lean_obj_res wrap_ssl_context(SSL_CTX * ctx) { - lean_ssl_context_object * obj = (lean_ssl_context_object*)malloc(sizeof(lean_ssl_context_object)); + lean_object * obj = lean_ssl_context_new(ctx); + lean_mark_mt(obj); - if (obj == nullptr) { - SSL_CTX_free(ctx); - return mk_openssl_io_error("failed to allocate SSL context object"); - } - - obj->ctx = ctx; - lean_object * lean_obj = lean_ssl_context_object_new(obj); - lean_mark_mt(lean_obj); - - return lean_io_result_mk_ok(lean_obj); + return lean_io_result_mk_ok(obj); } /* Std.Internal.SSL.Context.Server.mk (certFile keyFile : @& String) : IO Context.Server */ @@ -232,10 +229,20 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, return mk_ssl_file_error(cert_file, "could not read a PEM certificate chain"); } - if (SSL_CTX_use_PrivateKey_file(ctx, key, SSL_FILETYPE_PEM) <= 0) { - unsigned long err_code = ERR_peek_last_error(); + // Encrypted private keys are not supported. Without a callback here OpenSSL falls back to + // PEM_def_callback, which prompts for a passphrase on the terminal and blocks; returning 0 + // turns that into the ordinary read failure diagnosed below. + SSL_CTX_set_default_passwd_cb(ctx, [](char *, int, int, void *) { return 0; }); - bool mismatch = ERR_GET_LIB(err_code) == ERR_LIB_X509 && ERR_GET_REASON(err_code) == X509_R_KEY_VALUES_MISMATCH; + // Both key calls below are diagnosed from the error queue, so each must see only its own + // entries. + ERR_clear_error(); + + // A key of the same algorithm as the certificate is compared against it here. The only errors + // this raises from ERR_LIB_X509 come from that comparison, so they distinguish a key that does + // not belong to the certificate from one that could not be read at all. + if (SSL_CTX_use_PrivateKey_file(ctx, key, SSL_FILETYPE_PEM) <= 0) { + bool mismatch = ERR_GET_LIB(ERR_peek_last_error()) == ERR_LIB_X509; SSL_CTX_free(ctx); return mk_ssl_file_error(key_file, mismatch @@ -243,6 +250,11 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, : "could not read an unencrypted PEM private key"); } + ERR_clear_error(); + + // A key whose algorithm differs from the certificate's occupies a different slot in the context + // and is never compared above, so it is accepted there and only caught here. Without this the + // context would be built with no usable certificate and fail at handshake time instead. if (SSL_CTX_check_private_key(ctx) != 1) { SSL_CTX_free(ctx); return mk_ssl_file_error(key_file, "the private key does not match the certificate"); @@ -251,11 +263,12 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, return wrap_ssl_context(ctx); } -/* Std.Internal.SSL.Context.Client.mk (caFile : @& String) (verifyPeer : Bool) : IO Context.Client */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, uint8_t verify_peer) { - const char * ca = lean_string_cstr(ca_file); - if (strlen(ca) != lean_string_size(ca_file) - 1) return mk_embedded_nul_error(ca_file); - +// Shared skeleton of the client constructors. With verification off the CA material is never +// consulted, so `load_ca` is skipped entirely; otherwise the platform's trust anchors are loaded +// first and `load_ca` adds the caller's own CAs on top of them, additively. `load_ca` returns +// nullptr on success, or an IO error to propagate. +template +static lean_obj_res mk_client_ctx(uint8_t verify_peer, LoadCA load_ca) { lean_obj_res err = nullptr; SSL_CTX * ctx = mk_ssl_ctx_base(TLS_client_method(), &err); if (ctx == nullptr) return err; @@ -265,106 +278,81 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, ui return wrap_ssl_context(ctx); } - // Trust the platform's system roots (so public servers verify out of the box, like a browser), - // then add the caller's CA file on top if one was supplied. The supplied CA is additive: it - // never replaces the system trust anchors. if (!load_system_trust_store(ctx)) { SSL_CTX_free(ctx); return mk_openssl_io_error("failed to load system trust store"); } - if (ca[0] != '\0') { - if (SSL_CTX_load_verify_locations(ctx, ca, nullptr) != 1) { - SSL_CTX_free(ctx); - return mk_ssl_file_error(ca_file, "could not read PEM CA certificates"); - } + if (lean_obj_res ca_err = load_ca(ctx)) { + SSL_CTX_free(ctx); + return ca_err; } SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER, nullptr); return wrap_ssl_context(ctx); } -/* Std.Internal.SSL.Context.Client.mkFromPEM (caPEM : @& String) (verifyPeer : Bool) : IO Context.Client */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca_pem, uint8_t verify_peer) { - lean_obj_res err = nullptr; - SSL_CTX * ctx = mk_ssl_ctx_base(TLS_client_method(), &err); - if (ctx == nullptr) return err; +/* Std.Internal.SSL.Context.Client.mk (caFile : @& String) (verifyPeer : Bool) : IO Context.Client */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, uint8_t verify_peer) { + const char * ca = lean_string_cstr(ca_file); + if (strlen(ca) != lean_string_size(ca_file) - 1) return mk_embedded_nul_error(ca_file); - // Without peer verification the supplied CA certificates would never be consulted, so skip - // parsing them and just disable verification (mirrors the file-based `mk`). - if (!verify_peer) { - SSL_CTX_set_verify(ctx, SSL_VERIFY_NONE, nullptr); - return wrap_ssl_context(ctx); - } + return mk_client_ctx(verify_peer, [&](SSL_CTX * ctx) -> lean_obj_res { + // An empty CA path leaves the client with just the system trust anchors. + if (ca[0] == '\0') return nullptr; - // Trust the platform's system roots; any PEM certificates below are added on top of them. - if (!load_system_trust_store(ctx)) { - SSL_CTX_free(ctx); - return mk_openssl_io_error("failed to load system trust store"); - } + if (SSL_CTX_load_verify_locations(ctx, ca, nullptr) != 1) { + return mk_ssl_file_error(ca_file, "could not read PEM CA certificates"); + } - const char * pem = lean_string_cstr(ca_pem); - size_t pem_size = lean_string_size(ca_pem) - 1; + return nullptr; + }); +} - // An empty PEM leaves the client with just the system trust anchors. - if (pem_size == 0) { - SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER, nullptr); - return wrap_ssl_context(ctx); - } +/* Std.Internal.SSL.Context.Client.mkFromPEM (caPEM : @& String) (verifyPeer : Bool) : IO Context.Client */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca_pem, uint8_t verify_peer) { + return mk_client_ctx(verify_peer, [&](SSL_CTX * ctx) -> lean_obj_res { + const char * pem = lean_string_cstr(ca_pem); + size_t pem_size = lean_string_size(ca_pem) - 1; - if (pem_size > INT_MAX) { - SSL_CTX_free(ctx); - return mk_ssl_invalid_argument("the CA PEM string is too large"); - } + // An empty PEM leaves the client with just the system trust anchors. + if (pem_size == 0) return nullptr; - BIO * bio = BIO_new_mem_buf(pem, (int)pem_size); + if (pem_size > INT_MAX) return mk_ssl_invalid_argument("the CA PEM string is too large"); - if (bio == nullptr) { - SSL_CTX_free(ctx); - return mk_openssl_io_error("BIO_new_mem_buf failed"); - } + BIO * bio = BIO_new_mem_buf(pem, (int)pem_size); + if (bio == nullptr) return mk_openssl_io_error("BIO_new_mem_buf failed"); - STACK_OF(X509_INFO) * infos = PEM_X509_INFO_read_bio(bio, nullptr, nullptr, nullptr); + STACK_OF(X509_INFO) * infos = PEM_X509_INFO_read_bio(bio, nullptr, nullptr, nullptr); - BIO_free(bio); + BIO_free(bio); - if (infos == nullptr) { - SSL_CTX_free(ctx); - return mk_ssl_invalid_argument("could not read PEM CA certificates from the given string"); - } + if (infos == nullptr) return mk_ssl_invalid_argument("could not read PEM CA certificates from the given string"); - // Add the parsed certificates to the context's verification store, which already holds the - // system roots; the store is owned by the context, so it must not be freed here. - X509_STORE * store = SSL_CTX_get_cert_store(ctx); - int cert_count = 0; - - for (int i = 0; i < sk_X509_INFO_num(infos); i++) { - X509_INFO * info = sk_X509_INFO_value(infos, i); - if (info->x509 == nullptr) continue; - cert_count++; - - if (X509_STORE_add_cert(store, info->x509) != 1) { - unsigned long err_code = ERR_peek_last_error(); - if (ERR_GET_LIB(err_code) == ERR_LIB_X509 && ERR_GET_REASON(err_code) == X509_R_CERT_ALREADY_IN_HASH_TABLE) { - ERR_clear_error(); - continue; - } + // The store already holds the system roots and is owned by the context, so it is not freed + // here. + X509_STORE * store = SSL_CTX_get_cert_store(ctx); + int cert_count = 0; + + for (int i = 0; i < sk_X509_INFO_num(infos); i++) { + X509_INFO * info = sk_X509_INFO_value(infos, i); + if (info->x509 == nullptr) continue; + cert_count++; - sk_X509_INFO_pop_free(infos, X509_INFO_free); - SSL_CTX_free(ctx); - return mk_openssl_io_error("X509_STORE_add_cert failed"); + // A certificate that is already an anchor (e.g. a system root repeated in the bundle) + // is reported as success, so duplicates need no special handling here. + if (X509_STORE_add_cert(store, info->x509) != 1) { + sk_X509_INFO_pop_free(infos, X509_INFO_free); + return mk_openssl_io_error("X509_STORE_add_cert failed"); + } } - } - sk_X509_INFO_pop_free(infos, X509_INFO_free); + sk_X509_INFO_pop_free(infos, X509_INFO_free); - if (cert_count == 0) { - SSL_CTX_free(ctx); - return mk_ssl_invalid_argument("the given CA PEM string contains no certificates"); - } + if (cert_count == 0) return mk_ssl_invalid_argument("the given CA PEM string contains no certificates"); - SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER, nullptr); - return wrap_ssl_context(ctx); + return nullptr; + }); } #else diff --git a/src/runtime/openssl/context.h b/src/runtime/openssl/context.h index 9a3c6cc16493..81f1fba3d0a9 100644 --- a/src/runtime/openssl/context.h +++ b/src/runtime/openssl/context.h @@ -12,8 +12,6 @@ Author: Sofia Rodrigues #ifndef LEAN_EMSCRIPTEN #include -#include -#include #endif namespace lean { @@ -23,16 +21,11 @@ void initialize_openssl_context(); #ifndef LEAN_EMSCRIPTEN -// Structure for managing a single Context object. -typedef struct { - SSL_CTX * ctx; -} lean_ssl_context_object; - // Drains the OpenSSL error queue and returns a single error message combining up to 10 entries. lean_object * mk_openssl_error(char const * where, int ssl_err = 0); -static inline lean_obj_res mk_openssl_io_error(char const * where, int ssl_err = 0) { return lean_io_result_mk_error(mk_openssl_error(where, ssl_err)); } -static inline lean_object * lean_ssl_context_object_new(lean_ssl_context_object * c) { return lean_alloc_external(g_ssl_context_external_class, c); } -static inline lean_ssl_context_object * lean_to_ssl_context_object(lean_object * o) { return (lean_ssl_context_object*)(lean_get_external_data(o)); } +inline lean_obj_res mk_openssl_io_error(char const * where, int ssl_err = 0) { return lean_io_result_mk_error(mk_openssl_error(where, ssl_err)); } +inline lean_object * lean_ssl_context_new(SSL_CTX * ctx) { return lean_alloc_external(g_ssl_context_external_class, ctx); } +inline SSL_CTX * lean_to_ssl_context(lean_object * o) { return (SSL_CTX*)lean_get_external_data(o); } #endif // ======================================= diff --git a/tests/elab/async_ssl_certs/README.md b/tests/elab/async_ssl_certs/README.md index 6c3bcdf831f8..80dd8bf7e93d 100644 --- a/tests/elab/async_ssl_certs/README.md +++ b/tests/elab/async_ssl_certs/README.md @@ -15,6 +15,8 @@ certificates are rejected). |---|---|---| | `key.pem` | | RSA-2048 private key for all certs below | | `key2.pem` | | second RSA-2048 key, matching none of the certificates | +| `eckey.pem` | | P-256 key; a *different algorithm* from every certificate here, which OpenSSL accepts against an RSA certificate unless `SSL_CTX_check_private_key` is consulted | +| `enckey.pem` | | `key.pem` encrypted with the passphrase `lean4`; encrypted keys are unsupported and must be rejected without prompting for one | | `cert.pem` | `CN=localhost` | standard server cert (no SAN; hostname matching uses the CN fallback) | | `wildcard.pem` | `CN=*.test.local` | SAN: `DNS:*.test.local, DNS:test.local` | | `multisan.pem` | `CN=alpha.test.local` | SAN: `DNS:alpha.test.local, DNS:beta.test.local` | @@ -38,6 +40,8 @@ openssl req -new -key key.pem -out expired.csr -subj "/CN=localhost" openssl x509 -req -in expired.csr -signkey key.pem -out expired.pem -set_serial 99 \ -not_before 20200101000000Z -not_after 20200102000000Z && rm expired.csr openssl genrsa -out key2.pem 2048 +openssl genpkey -algorithm EC -pkeyopt ec_paramgen_curve:P-256 -out eckey.pem +openssl pkey -in key.pem -aes256 -passout pass:lean4 -out enckey.pem python3 -c ' import base64, textwrap der = bytearray(base64.b64decode("".join(open("cert.pem").read().strip().splitlines()[1:-1]))) diff --git a/tests/elab/async_ssl_certs/eckey.pem b/tests/elab/async_ssl_certs/eckey.pem new file mode 100644 index 000000000000..3b23fa9bddf8 --- /dev/null +++ b/tests/elab/async_ssl_certs/eckey.pem @@ -0,0 +1,5 @@ +-----BEGIN PRIVATE KEY----- +MIGHAgEAMBMGByqGSM49AgEGCCqGSM49AwEHBG0wawIBAQQghGZua23+ku595fBF +kULMnWb6u5NS+bDRb0qQw5kUo7uhRANCAAQI0CBXJc4VPetl+b628Yvj52aN1r88 +OWg9CdCMEJ2DnQXil9s3tBh0Wgsch5mWLaylaRdUcxeZwkzsgPrFjDN1 +-----END PRIVATE KEY----- diff --git a/tests/elab/async_ssl_certs/enckey.pem b/tests/elab/async_ssl_certs/enckey.pem new file mode 100644 index 000000000000..291234a758cd --- /dev/null +++ b/tests/elab/async_ssl_certs/enckey.pem @@ -0,0 +1,30 @@ +-----BEGIN ENCRYPTED PRIVATE KEY----- +MIIFNTBfBgkqhkiG9w0BBQ0wUjAxBgkqhkiG9w0BBQwwJAQQ4r90nr4TGuyNM5lg +rrm25QICCAAwDAYIKoZIhvcNAgkFADAdBglghkgBZQMEASoEEOymnMvrb8PdBcht +uX4Oz2QEggTQjvshSWTucNIVX5GJoNgWj2EVV+PmbnJ0gWITNL6PS5TY5X/uDGfL +X3ULXRy6F1Ypuk6yBfOgRWQI267BEc4eEYe0ECLqCa+5ebpV6OCJv8WR7urxBVF0 +lF9K4abWJOaExvK6TT2iIU+4aYvckXpJrss6fdMZ4y8Ez9GAMaCaw4x565/6ej3N +HW5ezxpXItoPkhPdHyWIJWGqgGK/RVro23UnteqsPpl5K5x2NLUoh1BQm74W8cdL +OoSi9c7yDOy7jaaPwwovcpJJkpE0PhTxrUUU2NNEvcK9bvPBkkZxFYtPPTGmErOH +QGF/43peHVD3yF2E/Z3YHN0xXyqqkf7lB2nuIl2rveg8JzvyZunGoYjoNTj6BlqO +FEIE8iWUAtdn8RutjdujSnv2fLGhDcHtBwVzT+Ia6poL+RW4TnBR9J3dIWVWmw0H +WNuOJzia3SRQUbHyC3M+suxqZ629Z0YQBc2cn2Tck+JgSx3o2/ILHpVwP96zZzRr +Al2Z/O4/BZnQ8VdaKYuacpkX3N76nkMOF+10Mr2Qy+pFjQRgFhMQVcaHfIwCv9BC +MgfIgwQi8+gY0wgNEM0ItYLABRg1f8/wmh2g4L2Da7RsKJSRwpFBXvHG4PlPfxNH +SUQKKPH+cwgcA6HOHHd3O7HoQRgnwNXNc5wfpaNxyNWHKajvbgo18tQrXu7/45ax +M4GS9eq6v8NDFqhz72iKNNaN//jRSCH/MKzLU/oMv/pDBCovnAc+HwA4G3+NE+/6 +jE1I+p5SEvJEiMWzsfFw8MLeKDOa3kvBB5rutV2/jV/XW7LqgZwA7XZqkHyIoPYt +BbL4VrJs9xMwRQOQmYqmumv1g1/TOXn4QQbjJtDcfmYJhJ0I8LXzOKpuAFZNn3E1 +SX+V969YzfGt10toZ2/kMeg0xzof9d0nrOa+jgzoAChIBsm8Oz93S1zhnJRJflEt +d+jI+ceL0N97DkLUlEz0np/qYwYaoeDPKU0L50j0yesywyc2xuMshpL/2xt0QN9J +PjpwVIMp0w1J9i5QYdaH4twGk5vMFSa44AZ8844RW3FSf5quqz5Og5/TPK6ZNsQi +3VqUfGSCutdB8bQ7yb/Q7rQJKJyFRDDZUiicDUmkhAr00Xa/HlPp76mQw85E2Xrj +/L+PMPJnMcGBlm4MkCAQNjimRBka5dlVDUzi8HmgvOkoaJag4vCf4Ipr52JbOBTu +3Z+aQyO0BCdncKVzYHXZ1XpafRjZb6YHJDJcJ/NneEKY7EzRCTAwiwMTlK9dNU+M +KcTrfECP/HG7wTiPo7X3MmsZ8WDOSTaLF5WbgCohY2sK+hWUXBNvL3RLs/bpzNzq +GSdiE9eftNkeBCKG72cUkMpsWJW7+ZJp1BE63JKKs1qfan+1iwVWYjcXd9rJn/FZ +RDkyvQVc+EE5xmq4kqXPG2BuiBmp/SfDpV1EfJaTIi10YBmUf2mlmrvBH07GhHkx +fjDdNnP9rvKpHNanVgSObUT5bAmER8u8x83ZtNzZWpPe8ZNNb3ERjQ7s7Qpp6a9o +wCLUepYLb0JtKsa7OliL6XtboyuNg9suqygAKmxMSqe9q90rkS0CiGv4J+KginkN +MowNIidl/EhUN7UgyEYoLlPFlUMDspxH9yJLVEqFfIgrv2JcqeLbwdU= +-----END ENCRYPTED PRIVATE KEY----- diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index 449585ec9740..5fad7ed725d0 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -25,6 +25,12 @@ def testCorruptCertPEM : String := include_cert% "async_ssl_certs/corrupt.pem" -- Matches none of the certificates above, so it is only good for provoking a key/cert mismatch. def testUnrelatedKeyPEM : String := include_cert% "async_ssl_certs/key2.pem" +-- A P-256 key, so the mismatch against the RSA certificates is one of algorithm rather than value. +def testECKeyPEM : String := include_cert% "async_ssl_certs/eckey.pem" + +-- `key.pem` behind a passphrase, which OpenSSL asks for on the terminal unless it is told not to. +def testEncryptedKeyPEM : String := include_cert% "async_ssl_certs/enckey.pem" + -- Three distinct certificates in one file, the shape of a real CA bundle. def testBundlePEM : String := testCertPEM ++ testWildcardCertPEM ++ testMultiSANCertPEM @@ -72,6 +78,10 @@ def setupCorruptCert : IO String := writeTempFile "corrupt.pem" testCorruptCertP def setupUnrelatedKey : IO String := writeTempFile "key2.pem" testUnrelatedKeyPEM +def setupECKey : IO String := writeTempFile "eckey.pem" testECKeyPEM + +def setupEncryptedKey : IO String := writeTempFile "enckey.pem" testEncryptedKeyPEM + def setupBundle : IO String := writeTempFile "bundle.pem" testBundlePEM def setupDuplicateBundle : IO String := writeTempFile "dup.pem" (testBundlePEM ++ testCertPEM) @@ -206,6 +216,22 @@ def testMkServerRejectsMismatchedKey (certFile key2File : String) : IO Unit := d (malformedFileError key2File "the private key does not match the certificate") (discard <| Context.Server.mk certFile key2File) +-- A key of a different algorithm than the certificate lands in an unused slot of the context, so +-- `SSL_CTX_use_PrivateKey_file` accepts it without ever comparing the two; only the separate +-- `SSL_CTX_check_private_key` rejects it. +def testMkServerRejectsCrossAlgorithmKey (certFile ecKeyFile : String) : IO Unit := do + assertErrorMessage "EC server key against an RSA certificate" + (malformedFileError ecKeyFile "the private key does not match the certificate") + (discard <| Context.Server.mk certFile ecKeyFile) + +-- Encrypted keys are unsupported. The point of this test is as much the absence of output as the +-- error itself: with no password callback installed OpenSSL prompts for the passphrase on the +-- terminal, which blocks when one is attached and pollutes the test output when one is not. +def testMkServerRejectsEncryptedKey (certFile encKeyFile : String) : IO Unit := do + assertErrorMessage "passphrase-protected server key" + (malformedFileError encKeyFile "could not read an unencrypted PEM private key") + (discard <| Context.Server.mk certFile encKeyFile) + def testMkServerRejectsNulInCert (keyFile : String) : IO Unit := do let certPath := "cert\x00.pem" @@ -287,6 +313,8 @@ def testMkRejectsNulInCAFile : IO Unit := do testMkServerRejectsCertAsKey certFile testMkServerRejectsSwappedFiles certFile keyFile testMkServerRejectsMismatchedKey certFile (← setupUnrelatedKey) + testMkServerRejectsCrossAlgorithmKey certFile (← setupECKey) + testMkServerRejectsEncryptedKey certFile (← setupEncryptedKey) #eval do let (certFile, keyFile) ← setupTestCerts From 82a2fe9319477b746133bcf456eaa44ffc041299 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Sat, 15 Aug 2026 15:40:02 -0300 Subject: [PATCH 25/36] fix: winstore --- src/runtime/openssl/context.cpp | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index e1a36b628728..2f59c98b9cba 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -172,6 +172,20 @@ static bool load_system_trust_store(SSL_CTX * ctx) { ERR_clear_error(); return added > 0; +#elif defined(LEAN_WINDOWS) + // The Windows ROOT store is reachable only through OpenSSL's winstore provider, which + // `SSL_CTX_set_default_verify_paths` does not consult, so it has to be named explicitly. The + // default paths are still added on top, and a build configured with `no-winstore` falls back to + // them alone. + int winstore = SSL_CTX_load_verify_store(ctx, "org.openssl.winstore://"); + int paths = SSL_CTX_set_default_verify_paths(ctx); + + if (winstore != 1 && paths != 1) return false; + + // Entries a failed load left behind would otherwise be picked up by a later diagnosis in this + // call as its own. + ERR_clear_error(); + return true; #else return SSL_CTX_set_default_verify_paths(ctx) == 1; #endif @@ -230,9 +244,10 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, } // Encrypted private keys are not supported. Without a callback here OpenSSL falls back to - // PEM_def_callback, which prompts for a passphrase on the terminal and blocks; returning 0 - // turns that into the ordinary read failure diagnosed below. - SSL_CTX_set_default_passwd_cb(ctx, [](char *, int, int, void *) { return 0; }); + // PEM_def_callback, which prompts for a passphrase on the terminal and blocks. The return value + // is the passphrase length, so it has to be -1 (the documented failure code) and not 0: 0 is an + // empty passphrase, which loads a key encrypted under one instead of rejecting it. + SSL_CTX_set_default_passwd_cb(ctx, [](char *, int, int, void *) { return -1; }); // Both key calls below are diagnosed from the error queue, so each must see only its own // entries. From 33a7fb9962d8f9ec556b9a8dc6c83f9c48fc5ce8 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Sat, 15 Aug 2026 15:44:02 -0300 Subject: [PATCH 26/36] feat: empty pw key test --- tests/elab/async_ssl_certs/README.md | 2 ++ tests/elab/async_ssl_certs/emptypwkey.pem | 30 +++++++++++++++++++++++ tests/elab/async_ssl_context.lean | 14 +++++++++++ 3 files changed, 46 insertions(+) create mode 100644 tests/elab/async_ssl_certs/emptypwkey.pem diff --git a/tests/elab/async_ssl_certs/README.md b/tests/elab/async_ssl_certs/README.md index 80dd8bf7e93d..d6b6f7c76abf 100644 --- a/tests/elab/async_ssl_certs/README.md +++ b/tests/elab/async_ssl_certs/README.md @@ -17,6 +17,7 @@ certificates are rejected). | `key2.pem` | | second RSA-2048 key, matching none of the certificates | | `eckey.pem` | | P-256 key; a *different algorithm* from every certificate here, which OpenSSL accepts against an RSA certificate unless `SSL_CTX_check_private_key` is consulted | | `enckey.pem` | | `key.pem` encrypted with the passphrase `lean4`; encrypted keys are unsupported and must be rejected without prompting for one | +| `emptypwkey.pem` | | `key.pem` encrypted under an *empty* passphrase; still an encrypted key, and rejected only because the password callback reports a failure rather than a zero-length passphrase | | `cert.pem` | `CN=localhost` | standard server cert (no SAN; hostname matching uses the CN fallback) | | `wildcard.pem` | `CN=*.test.local` | SAN: `DNS:*.test.local, DNS:test.local` | | `multisan.pem` | `CN=alpha.test.local` | SAN: `DNS:alpha.test.local, DNS:beta.test.local` | @@ -42,6 +43,7 @@ openssl x509 -req -in expired.csr -signkey key.pem -out expired.pem -set_serial openssl genrsa -out key2.pem 2048 openssl genpkey -algorithm EC -pkeyopt ec_paramgen_curve:P-256 -out eckey.pem openssl pkey -in key.pem -aes256 -passout pass:lean4 -out enckey.pem +openssl pkey -in key.pem -aes256 -passout pass: -out emptypwkey.pem python3 -c ' import base64, textwrap der = bytearray(base64.b64decode("".join(open("cert.pem").read().strip().splitlines()[1:-1]))) diff --git a/tests/elab/async_ssl_certs/emptypwkey.pem b/tests/elab/async_ssl_certs/emptypwkey.pem new file mode 100644 index 000000000000..b349a6d946d7 --- /dev/null +++ b/tests/elab/async_ssl_certs/emptypwkey.pem @@ -0,0 +1,30 @@ +-----BEGIN ENCRYPTED PRIVATE KEY----- +MIIFNTBfBgkqhkiG9w0BBQ0wUjAxBgkqhkiG9w0BBQwwJAQQSMe7Ss5ZImymPYZ6 +tfMw7QICCAAwDAYIKoZIhvcNAgkFADAdBglghkgBZQMEASoEEK/Yq1PS40HsgfwK +EvdzDDgEggTQRgtk/fYVAYO1ykpinPLAsLCRtxeu6fiqdLgvDKwOF8SnynGIRxQg +L9kBxYZzWRpoqwoZgOrCw6HK81y+PwIvVoN+gHp01ushWPt5W121DiMnhdLsyEUf +HWv4v5VyHuQoXb7tgUUdG0Rc3JUGiH+kYpC5acHvssX0dBNVMc1Vf3i+LhO2uUL/ +HsnNt5vYqi01cEQq67mSeQ6RRGEvAmJ944ktGvwjDFlKrg7S86Lplg/wCDuMLRh+ +D5HhchLmWjWyPbcCh9/47GE2FjRvcmDDC1bbdcp1hwsBQkqE8utJ2DYS8QJp4WUA +4keYnxMpHWkJ9yEW/H/30IV40bzvsIGX/hdhzv5yO4TF2AKI5Zn5rhIK88yfbqqh +r1OLIm8Nxk3nRY1uVlvg6siXNaevKe8sv5DKPexnMwRQbuKlcBZHOj+yFODllExu +Vfq3tBqRkXK648hfDNRblM68y3fT9rFCUguUNb0q+DX+EY/l4ZeUiGgmMe25JwtC +RT1c2RQ09FP5cT2KAOf2VJA43vf4Xs6a/lpYnVybyLXA+0AMWM2qLr/G5DeN6+fq +sASQUCDvmwxhMoIEcG6uyNntKMtUZAd9FhuRvkqM7pW3jTGtUMVj9mj10dnPTQB1 +IpT0IqcfVMI1nU7MeEwGgaHW6KuJkj+f5m2pxojmBnfxCczijIVbsRWfoY9P4iKB +us1ZQa4lUxSiUGAbhIPE7usa01GkLbZOjnYeJDC640ReFSqTEzS0RKuz/2G4DoTD +ZvDKB4Kjfv80QLnIt4BWiG1oCsd+n8sVXuPd+vmcOnpDLdWCpQgONa0ivT+vyLAz +m2fN2Qsih4V8QPUeZi54YRrlESy2Syt29mep58OekU+lJhhxt+OXso50/MDwgkiS +ZhaQ09BPiHMmXKk0smaZMoc78h4LuX3EgK4JKyvLxPmHtykbFsPEx+rPYOqvLATf +quyYKx/TEFuwS1DfuzBfggEXkT2L0HRaQNuTzyvr9BQ9C1ASGREe8h1AP8Mzjpqc +yjNEovSOvDkD5zhVdLPU0tBXl5T7/vZd21i0/AAkB/czIg4FHh7E626JHmPYkuXV +gDqLHGCVXl+I7dWZqV4+DHLqTdHIa2ZN88q0ttpf8xoyaO4q5igNuw/BIVhWBLz5 +bzFTUbMNYOEYyovQcZOXdm6Fo14MOJ/SUypTeP8eFLq2lsaa56AujRXEgV8zCFCx +wj4Pu14Q9A2eXlwYmRnE2TbXxZci8sUi1jDLlnyjvgYYJ5TkyxhS+5cXrS3/W8VR +YCPbyPjQO+42YSveIIUruJFfhJ2qOZPchmIJqaPaFa5Zr0e5SAv6t7uwquI9FkGY +SNQfRlrkVFDufZaUdbLzLstIae2JWOxi9ZxNWLhOREtWnUvwU6jONN23obJAEDR7 +FU1mKxC5vmJjudYS/advxvghV1WKTxvLHGVczkDKEDrax7OJflCOPfi92nt25IRc +DzmOULeV8AeNkNH52k1Dy+qjMhMFA3NnX1Jfs2/4TtsvdDBFhWQqRb1jxRQg1e85 +xZnKLqCej2e1d2lN0OD/FMCitZAfWF+1SneDzKVtmafsiZsvQmouACEw/MaGAzfR +9kQkQJgW+D6PqDz0l04PjNsx/yXXmG5XVl+SOhg8wi1/y+D8MKIUACk= +-----END ENCRYPTED PRIVATE KEY----- diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index 5fad7ed725d0..35e3f8698e63 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -31,6 +31,10 @@ def testECKeyPEM : String := include_cert% "async_ssl_certs/eckey.pem" -- `key.pem` behind a passphrase, which OpenSSL asks for on the terminal unless it is told not to. def testEncryptedKeyPEM : String := include_cert% "async_ssl_certs/enckey.pem" +-- `key.pem` encrypted under an *empty* passphrase, which a password callback reporting a zero-length +-- passphrase rather than a failure decrypts instead of rejecting. +def testEmptyPassphraseKeyPEM : String := include_cert% "async_ssl_certs/emptypwkey.pem" + -- Three distinct certificates in one file, the shape of a real CA bundle. def testBundlePEM : String := testCertPEM ++ testWildcardCertPEM ++ testMultiSANCertPEM @@ -82,6 +86,8 @@ def setupECKey : IO String := writeTempFile "eckey.pem" testECKeyPEM def setupEncryptedKey : IO String := writeTempFile "enckey.pem" testEncryptedKeyPEM +def setupEmptyPassphraseKey : IO String := writeTempFile "emptypwkey.pem" testEmptyPassphraseKeyPEM + def setupBundle : IO String := writeTempFile "bundle.pem" testBundlePEM def setupDuplicateBundle : IO String := writeTempFile "dup.pem" (testBundlePEM ++ testCertPEM) @@ -232,6 +238,13 @@ def testMkServerRejectsEncryptedKey (certFile encKeyFile : String) : IO Unit := (malformedFileError encKeyFile "could not read an unencrypted PEM private key") (discard <| Context.Server.mk certFile encKeyFile) +-- An empty passphrase still counts as encrypted. A password callback that reports a zero-length +-- passphrase instead of a failure decrypts this key and accepts it. +def testMkServerRejectsEmptyPassphraseKey (certFile emptyPwKeyFile : String) : IO Unit := do + assertErrorMessage "server key encrypted under an empty passphrase" + (malformedFileError emptyPwKeyFile "could not read an unencrypted PEM private key") + (discard <| Context.Server.mk certFile emptyPwKeyFile) + def testMkServerRejectsNulInCert (keyFile : String) : IO Unit := do let certPath := "cert\x00.pem" @@ -315,6 +328,7 @@ def testMkRejectsNulInCAFile : IO Unit := do testMkServerRejectsMismatchedKey certFile (← setupUnrelatedKey) testMkServerRejectsCrossAlgorithmKey certFile (← setupECKey) testMkServerRejectsEncryptedKey certFile (← setupEncryptedKey) + testMkServerRejectsEmptyPassphraseKey certFile (← setupEmptyPassphraseKey) #eval do let (certFile, keyFile) ← setupTestCerts From 718e0a26380c2695bffeeeb4d592e011e649cdb5 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Sat, 15 Aug 2026 17:28:45 -0300 Subject: [PATCH 27/36] fix: reject encrypted PEM before it can prompt on the terminal --- src/Std/Internal/SSL/Context.lean | 47 +++++-- src/runtime/openssl.cpp | 24 +++- src/runtime/openssl.h | 7 ++ src/runtime/openssl/context.cpp | 140 ++++++++++++++------- tests/elab/async_ssl_certs/README.md | 23 +++- tests/elab/async_ssl_certs/enccert.pem | 22 ++++ tests/elab/async_ssl_certs/tradkey.pem | 27 ++++ tests/elab/async_ssl_context.lean | 167 ++++++++++++++++++++++++- tests/elab/openssl.lean | 10 +- 9 files changed, 405 insertions(+), 62 deletions(-) create mode 100644 tests/elab/async_ssl_certs/enccert.pem create mode 100644 tests/elab/async_ssl_certs/tradkey.pem diff --git a/src/Std/Internal/SSL/Context.lean b/src/Std/Internal/SSL/Context.lean index e0295588ca8d..d81c76db2487 100644 --- a/src/Std/Internal/SSL/Context.lean +++ b/src/Std/Internal/SSL/Context.lean @@ -12,8 +12,15 @@ OpenSSL context types for server and client TLS sessions. Contexts configure the certificate/key, peer-verification mode, and protocol options shared across all sessions created from the same context. -For every context, session tickets and TLS compression are disabled and TLS 1.2 is the minimum -version. Session resumption is therefore not supported. +For every context, session tickets and TLS compression are disabled, renegotiation is refused, and +TLS 1.2 is the minimum version. Session resumption is therefore not supported. + +A context settles who is trusted, not who is being talked to: nothing here checks that a peer +certificate matches the host it came from. That check belongs to the session layer, which binds a +hostname per connection. + +Encrypted PEM material is rejected rather than prompted for, so no constructor can block on a +terminal. -/ public section @@ -43,6 +50,9 @@ namespace Context.Server /-- Creates a server-side TLS context, loading the PEM certificate chain and private key from the given files. The server presents its certificate but does not authenticate the client (no mutual TLS). + +`certFile` holds the leaf certificate followed by any intermediates; the whole chain is sent so +clients can build a path to a trusted root. `keyFile` must be an unencrypted key matching that leaf. -/ @[extern "lean_ssl_ctx_mk_server"] opaque mk (certFile : @& String) (keyFile : @& String) : IO Context.Server @@ -53,36 +63,53 @@ namespace Client /- A default value on a borrowed parameter wraps its type in `optParam`, which hides the `@&` marker -from the compiler: the parameter is then treated as owned and every argument leaks. So the extern -takes `caFile` explicitly and the public wrapper below carries the default. +from the compiler: that parameter is then treated as owned and every argument leaks. So the extern +takes `caFile` explicitly and the public wrapper below carries the default. Only the parameter +carrying the default is affected, which is why `mkFromPEM` needs no such wrapper. -/ @[extern "lean_ssl_ctx_mk_client"] private opaque mkImpl (caFile : @& String) (verifyPeer : Bool) : IO Context.Client /-- -Creates a client-side TLS context. +Creates a client-side TLS context, reading CA trust anchors from a PEM bundle file. Trust-anchor semantics: - With `verifyPeer := true` (the default) the client trusts the platform default trust anchors (the system root store) and verifies the peer certificate, so connections to public HTTPS servers work out of the box. A non-empty `caFile` is trusted *in addition* to those system anchors, so public - servers keep working while a private or self-signed CA also becomes trusted. -- An empty `caFile` with `verifyPeer := true` uses just the platform default trust anchors. -- `verifyPeer := false` disables peer verification entirely (the CA file is not parsed). + servers keep working while a private or self-signed CA also becomes trusted. There is no way to + trust `caFile` alone, so this cannot be used to pin against a single CA. +- An empty `caFile` with `verifyPeer := true` uses just the platform default trust anchors. Which + anchors those are is platform-specific: the Keychain system roots on macOS, the `ROOT` store on + Windows, OpenSSL's configured paths elsewhere. `SSL_CERT_FILE` and `SSL_CERT_DIR` are honoured on + every platform, but user-added or explicitly distrusted keychain entries are not consulted. +- `verifyPeer := false` disables peer verification entirely and the CA file is not parsed. This + cannot be undone: a context built this way can never be made to verify. + +`caFile` must be a path without embedded NUL bytes, which is checked before `verifyPeer` is +consulted. A file containing no certificates is rejected. + +Verifying the peer proves the certificate chains to a trusted anchor; it does **not** prove the +certificate belongs to the host being connected to. Binding a hostname is the session layer's job. -/ @[inline] def mk (caFile : String := "") (verifyPeer : Bool := true) : IO Context.Client := mkImpl caFile verifyPeer /-- Creates a client-side TLS context with CA trust anchors from an in-memory PEM string instead of a -file path. Accepts one or more PEM-encoded certificates (same format as a CA bundle file). +file path. Accepts one or more PEM-encoded certificates (same format as a CA bundle file); private +key and CRL entries are ignored, and a string yielding no certificates at all is rejected. -Trust-anchor semantics match `mk`: +Trust-anchor semantics match `mk`, including that the platform anchors cannot be excluded and that +hostname verification is left to the session layer: - With `verifyPeer := true` the client always trusts the platform default trust anchors; a non-empty `caPEM` is trusted *in addition* to them. - An empty `caPEM` with `verifyPeer := true` uses just the platform default trust anchors. - `verifyPeer := false` disables peer verification entirely (the PEM is not parsed). +Unlike `mk`, which takes a path and so rejects embedded NUL bytes, this reads `caPEM` as bytes with +an explicit length: a NUL is ordinary data and the certificates around it are still parsed. + Use this when the CA certificate is embedded in the binary rather than on disk. -/ @[extern "lean_ssl_ctx_mk_client_from_pem"] diff --git a/src/runtime/openssl.cpp b/src/runtime/openssl.cpp index 105678cf2b20..1046deaa0892 100644 --- a/src/runtime/openssl.cpp +++ b/src/runtime/openssl.cpp @@ -7,8 +7,10 @@ Author: Sofia Rodrigues #ifndef LEAN_EMSCRIPTEN #include +#include #include #include +#include namespace lean { @@ -17,10 +19,30 @@ void initialize_openssl() { void finalize_openssl() {} +bool ensure_openssl_initialized() { + static bool ok = false; + static std::once_flag once; + + std::call_once(once, []() { + // `OPENSSL_INIT_NO_ATEXIT` is the load-bearing flag. By default OpenSSL registers + // `atexit(OPENSSL_cleanup)`, which tears down global state — among it the ENGINE lock that + // `SSL_CTX_new` reads — while other threads may still be inside OpenSSL, dereferencing the + // freed lock. Lean hands work to a thread pool that can outlive `main`, so that handler + // must not be installed. Nothing then frees OpenSSL's globals, which is intended: they stay + // reachable from static storage for the life of the process. + ok = OPENSSL_init_ssl(OPENSSL_INIT_NO_ATEXIT, nullptr) == 1; + }); + + return ok; +} + } extern "C" LEAN_EXPORT lean_obj_res lean_openssl_version(lean_obj_arg o) { - return lean_unsigned_to_nat(OPENSSL_VERSION_NUMBER); + // The linked library rather than the headers it was compiled against, so a Lean binary running + // against an upgraded shared OpenSSL reports what it actually loaded (as `lean_libuv_version` + // does for libuv). + return lean_unsigned_to_nat(OpenSSL_version_num()); } #else diff --git a/src/runtime/openssl.h b/src/runtime/openssl.h index a05b27cf241e..f4d2ee1dd2d3 100644 --- a/src/runtime/openssl.h +++ b/src/runtime/openssl.h @@ -9,6 +9,13 @@ Author: Sofia Rodrigues namespace lean { void initialize_openssl(); void finalize_openssl(); + +#ifndef LEAN_EMSCRIPTEN +// Initializes OpenSSL on first call, returning whether the library is usable. Deliberately lazy: a +// program that never opens a TLS connection never loads OpenSSL's providers. Every entry point that +// touches OpenSSL must call this first. +bool ensure_openssl_initialized(); +#endif } extern "C" LEAN_EXPORT lean_obj_res lean_openssl_version(lean_obj_arg); diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 2f59c98b9cba..0fec1ebf13fb 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -15,6 +15,7 @@ Author: Sofia Rodrigues #include #include #include +#include #include #include @@ -31,21 +32,27 @@ lean_external_class * g_ssl_context_external_class = nullptr; #ifndef LEAN_EMSCRIPTEN - static lean_obj_res mk_ssl_file_error(b_obj_arg file, char const * msg) { + ERR_clear_error(); + int errnum = 0; - unsigned long err; + FILE * probe = fopen(lean_string_cstr(file), "rb"); - while ((err = ERR_get_error()) != 0) { - if (errnum == 0 && ERR_GET_LIB(err) == ERR_LIB_SYS) errnum = ERR_GET_REASON(err); - } + if (probe == nullptr) errnum = errno; else fclose(probe); - if (errnum != 0) return lean_io_result_mk_error(decode_io_error(errnum, file)); + if (errnum == ENOENT || errnum == EACCES || errnum == EPERM || errnum == EISDIR || + errnum == ENOTDIR || errnum == ELOOP || errnum == ENAMETOOLONG || errnum == EMFILE || + errnum == ENFILE || errnum == ENOMEM) { + return lean_io_result_mk_error(decode_io_error(errnum, file)); + } lean_inc(file); - return lean_io_result_mk_error(lean_mk_io_error_invalid_argument_file(file, EINVAL, mk_string(msg))); + return lean_io_result_mk_error(lean_mk_io_error_invalid_argument_file( + file, errnum != 0 ? errnum : EINVAL, mk_string(msg))); } +static int reject_encrypted_pem(char *, int, int, void *) { return -1; } + // Reports a failure that has no errno behind it. The OpenSSL error queue is discarded rather than // appended, so its entries cannot leak into a later, unrelated diagnosis. static lean_obj_res mk_ssl_invalid_argument(char const * msg) { @@ -98,16 +105,22 @@ static bool configure_ctx_options(SSL_CTX * ctx) { // but set explicitly so the intent is clear. SSL_OP_NO_COMPRESSION | - // Disables RFC 5077 session tickets in TLS 1.2. TLS 1.3 tickets cannot be switched off this - // way: there the flag only downgrades them to the stateful form, which the disabled session - // cache below then suppresses. If resumption performance matters, remove this flag and - // implement a ticket key rotation strategy. + // Disables RFC 5077 session tickets in TLS 1.2. It does not switch them off in TLS 1.3, + // where it only downgrades them to the stateful form; SSL_CTX_set_num_tickets below is what + // stops those being sent. SSL_OP_NO_TICKET ); - // Backs the flag above. A TLS 1.2 server still offers session-ID resumption through this cache - // (which defaults to SSL_SESS_CACHE_SERVER), and the TLS 1.3 stateful tickets left by - // SSL_OP_NO_TICKET are stored in it too, so turning it off is what makes "no session + // Sends no NewSessionTicket at all in TLS 1.3. Without this a server still puts two of them on + // the wire per connection, useless against the disabled cache below but not free. + SSL_CTX_set_num_tickets(ctx, 0); + + // Installed before any PEM is read, so it covers the certificate chain and the CA bundle as well + // as the private key. + SSL_CTX_set_default_passwd_cb(ctx, reject_encrypted_pem); + + // Backs the flags above. A TLS 1.2 server still offers session-ID resumption through this cache + // (which defaults to SSL_SESS_CACHE_SERVER), so turning it off is what makes "no session // resumption" hold for both protocol versions. SSL_CTX_set_session_cache_mode(ctx, SSL_SESS_CACHE_OFF); @@ -135,7 +148,7 @@ static bool configure_ctx_options(SSL_CTX * ctx) { static bool load_system_trust_store(SSL_CTX * ctx) { #if defined(__APPLE__) // OpenSSL's default paths don't reach the Keychain, so the anchors are pulled from the Security - // framework instead. This yields the built-in system roots only: certificates a user or an + // framework as well. This yields the built-in system roots only: certificates a user or an // administrator added to a keychain are not included, and per-certificate trust settings are // not consulted, so a root the user explicitly distrusted is still added here. X509_STORE * store = SSL_CTX_get_cert_store(ctx); @@ -169,9 +182,11 @@ static bool load_system_trust_store(SSL_CTX * ctx) { } CFRelease(anchors); + + int paths = SSL_CTX_set_default_verify_paths(ctx); ERR_clear_error(); - return added > 0; + return added > 0 || paths == 1; #elif defined(LEAN_WINDOWS) // The Windows ROOT store is reachable only through OpenSSL's winstore provider, which // `SSL_CTX_set_default_verify_paths` does not consult, so it has to be named explicitly. The @@ -194,6 +209,11 @@ static bool load_system_trust_store(SSL_CTX * ctx) { // Creates an SSL_CTX with the hardened options shared by all contexts. Returns nullptr and stores // an IO error in *err on failure. static SSL_CTX * mk_ssl_ctx_base(const SSL_METHOD * method, lean_obj_res * err) { + if (!ensure_openssl_initialized()) { + *err = mk_openssl_io_error("OPENSSL_init_ssl failed"); + return nullptr; + } + ERR_clear_error(); SSL_CTX * ctx = SSL_CTX_new(method); @@ -243,12 +263,6 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, return mk_ssl_file_error(cert_file, "could not read a PEM certificate chain"); } - // Encrypted private keys are not supported. Without a callback here OpenSSL falls back to - // PEM_def_callback, which prompts for a passphrase on the terminal and blocks. The return value - // is the passphrase length, so it has to be -1 (the documented failure code) and not 0: 0 is an - // empty passphrase, which loads a key encrypted under one instead of rejecting it. - SSL_CTX_set_default_passwd_cb(ctx, [](char *, int, int, void *) { return -1; }); - // Both key calls below are diagnosed from the error queue, so each must see only its own // entries. ERR_clear_error(); @@ -307,6 +321,42 @@ static lean_obj_res mk_client_ctx(uint8_t verify_peer, LoadCA load_ca) { return wrap_ssl_context(ctx); } +// Adds every certificate the BIO yields to the context's trust store, on top of the system anchors +// already there. Returns 0 if the PEM could not be read at all, otherwise the number of +// certificates found; `*err` is set only for a hard failure. Non-certificate entries (private keys, +// CRLs) are skipped, matching what a CA bundle file is allowed to contain. +// +// Both client constructors share this, so an in-memory bundle and a bundle on disk are accepted and +// rejected on exactly the same terms. +static int add_ca_certificates(SSL_CTX * ctx, BIO * bio, bool * read_failed, lean_obj_res * err) { + STACK_OF(X509_INFO) * infos = PEM_X509_INFO_read_bio(bio, nullptr, reject_encrypted_pem, nullptr); + + if (infos == nullptr) { + *read_failed = true; + return 0; + } + + *read_failed = false; + + X509_STORE * store = SSL_CTX_get_cert_store(ctx); + int cert_count = 0; + + for (int i = 0; i < sk_X509_INFO_num(infos); i++) { + X509_INFO * info = sk_X509_INFO_value(infos, i); + if (info->x509 == nullptr) continue; + cert_count++; +. + if (X509_STORE_add_cert(store, info->x509) != 1) { + sk_X509_INFO_pop_free(infos, X509_INFO_free); + *err = mk_openssl_io_error("X509_STORE_add_cert failed"); + return 0; + } + } + + sk_X509_INFO_pop_free(infos, X509_INFO_free); + return cert_count; +} + /* Std.Internal.SSL.Context.Client.mk (caFile : @& String) (verifyPeer : Bool) : IO Context.Client */ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, uint8_t verify_peer) { const char * ca = lean_string_cstr(ca_file); @@ -316,8 +366,23 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, ui // An empty CA path leaves the client with just the system trust anchors. if (ca[0] == '\0') return nullptr; - if (SSL_CTX_load_verify_locations(ctx, ca, nullptr) != 1) { - return mk_ssl_file_error(ca_file, "could not read PEM CA certificates"); + BIO * bio = BIO_new_file(ca, "r"); + if (bio == nullptr) return mk_ssl_file_error(ca_file, "could not read PEM CA certificates"); + + bool read_failed = false; + lean_obj_res err = nullptr; + int cert_count = add_ca_certificates(ctx, bio, &read_failed, &err); + + BIO_free(bio); + + if (err != nullptr) return err; + if (read_failed) return mk_ssl_file_error(ca_file, "could not read PEM CA certificates"); + + // `SSL_CTX_load_verify_locations` reports success for a file holding no certificates at all + // (a lone CRL, or a private key), which silently leaves the trust store unchanged. Counting + // is what turns that misconfiguration into an error. + if (cert_count == 0) { + return mk_ssl_file_error(ca_file, "the CA file contains no certificates"); } return nullptr; @@ -338,31 +403,14 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca BIO * bio = BIO_new_mem_buf(pem, (int)pem_size); if (bio == nullptr) return mk_openssl_io_error("BIO_new_mem_buf failed"); - STACK_OF(X509_INFO) * infos = PEM_X509_INFO_read_bio(bio, nullptr, nullptr, nullptr); + bool read_failed = false; + lean_obj_res err = nullptr; + int cert_count = add_ca_certificates(ctx, bio, &read_failed, &err); BIO_free(bio); - if (infos == nullptr) return mk_ssl_invalid_argument("could not read PEM CA certificates from the given string"); - - // The store already holds the system roots and is owned by the context, so it is not freed - // here. - X509_STORE * store = SSL_CTX_get_cert_store(ctx); - int cert_count = 0; - - for (int i = 0; i < sk_X509_INFO_num(infos); i++) { - X509_INFO * info = sk_X509_INFO_value(infos, i); - if (info->x509 == nullptr) continue; - cert_count++; - - // A certificate that is already an anchor (e.g. a system root repeated in the bundle) - // is reported as success, so duplicates need no special handling here. - if (X509_STORE_add_cert(store, info->x509) != 1) { - sk_X509_INFO_pop_free(infos, X509_INFO_free); - return mk_openssl_io_error("X509_STORE_add_cert failed"); - } - } - - sk_X509_INFO_pop_free(infos, X509_INFO_free); + if (err != nullptr) return err; + if (read_failed) return mk_ssl_invalid_argument("could not read PEM CA certificates from the given string"); if (cert_count == 0) return mk_ssl_invalid_argument("the given CA PEM string contains no certificates"); diff --git a/tests/elab/async_ssl_certs/README.md b/tests/elab/async_ssl_certs/README.md index d6b6f7c76abf..5bddba8d2df6 100644 --- a/tests/elab/async_ssl_certs/README.md +++ b/tests/elab/async_ssl_certs/README.md @@ -18,6 +18,8 @@ certificates are rejected). | `eckey.pem` | | P-256 key; a *different algorithm* from every certificate here, which OpenSSL accepts against an RSA certificate unless `SSL_CTX_check_private_key` is consulted | | `enckey.pem` | | `key.pem` encrypted with the passphrase `lean4`; encrypted keys are unsupported and must be rejected without prompting for one | | `emptypwkey.pem` | | `key.pem` encrypted under an *empty* passphrase; still an encrypted key, and rejected only because the password callback reports a failure rather than a zero-length passphrase | +| `tradkey.pem` | | `key.pem` in the traditional (RFC 1421) encoding rather than PKCS#8; the only key form that reaches the bundle loader as a parsed entry carrying no certificate, so it exercises the skip branch | +| `enccert.pem` | | `cert.pem` as an RFC 1421 encrypted `CERTIFICATE` block; decrypted in place while a bundle is read, so it is the input that makes a missing password callback prompt on the terminal and hang | | `cert.pem` | `CN=localhost` | standard server cert (no SAN; hostname matching uses the CN fallback) | | `wildcard.pem` | `CN=*.test.local` | SAN: `DNS:*.test.local, DNS:test.local` | | `multisan.pem` | `CN=alpha.test.local` | SAN: `DNS:alpha.test.local, DNS:beta.test.local` | @@ -28,7 +30,8 @@ certificates are rejected). character — so it only fails once the certificate body is decoded, which exercises the "malformed certificate" paths rather than the "not a PEM file" ones. -To regenerate: +To regenerate (`-not_before`/`-not_after` need OpenSSL 3.5 or later; on older versions use +`-startdate`/`-enddate`): ```sh openssl genrsa -out key.pem 2048 @@ -44,6 +47,24 @@ openssl genrsa -out key2.pem 2048 openssl genpkey -algorithm EC -pkeyopt ec_paramgen_curve:P-256 -out eckey.pem openssl pkey -in key.pem -aes256 -passout pass:lean4 -out enckey.pem openssl pkey -in key.pem -aes256 -passout pass: -out emptypwkey.pem +openssl rsa -in key.pem -traditional -out tradkey.pem +python3 -c ' +import base64, hashlib, subprocess, textwrap +# Legacy RFC 1421 PEM encryption: key = EVP_BytesToKey(MD5, salt=IV, passphrase), 24 bytes for 3DES. +iv = bytes(range(1, 9)) +pw = b"lean4" +d = b""; key = b"" +while len(key) < 24: + d = hashlib.md5(d + pw + iv).digest() + key += d +key = key[:24] +der = base64.b64decode("".join(open("cert.pem").read().strip().splitlines()[1:-1])) +enc = subprocess.run(["openssl", "enc", "-des-ede3-cbc", "-K", key.hex(), "-iv", iv.hex()], + input=der, capture_output=True, check=True).stdout +body = "\n".join(textwrap.wrap(base64.b64encode(enc).decode(), 64)) +open("enccert.pem", "w").write("-----BEGIN CERTIFICATE-----\nProc-Type: 4,ENCRYPTED\n" + f"DEK-Info: DES-EDE3-CBC,{iv.hex().upper()}\n\n" + body + "\n-----END CERTIFICATE-----\n") +' python3 -c ' import base64, textwrap der = bytearray(base64.b64decode("".join(open("cert.pem").read().strip().splitlines()[1:-1]))) diff --git a/tests/elab/async_ssl_certs/enccert.pem b/tests/elab/async_ssl_certs/enccert.pem new file mode 100644 index 000000000000..d0bcd783452f --- /dev/null +++ b/tests/elab/async_ssl_certs/enccert.pem @@ -0,0 +1,22 @@ +-----BEGIN CERTIFICATE----- +Proc-Type: 4,ENCRYPTED +DEK-Info: DES-EDE3-CBC,0102030405060708 + +1SJtlSJSeUM3VYOB2tnDAfkc+2wXK4F+LKusyjJZIt1brdNy88s3srU74zlqUXES +BnF+/muCKthRyprrzncWx+Ac0Oyb89C3i9q30FV4Ly3pSvwnomCjuYEBqWRvEALt +STz2yxd71pZRItMe75VUjbcGiGa3Viev9SoS2KUuu9zEtk/Y7TkhDrWg/WSmtK8o +Ua1m5ZZQ1YNGtxrE/Za6YnC+RAzUzdpnetGTYQyWe0mMZAxbKuf9mXzgnO3Gxuwb +yVhWltv/E/TdBNkddIDd+miJ6plFZXcdDx1zXmH/2oKXR4CcSFd8a2UHZONTM4RU +88AnS4UFIYFy6dcfcPaIeTSyG+wd8nc2jUCn2Ih5tVlGej9FCy4r+Ah2EiYuTNxY +ai1L2DXrky7hgdbvZkiK1V6aDtLvxmqUDcqdo7j3Fbox+u26uUikJdQGELmQ89ou +0gw4CXoeFuo03k4c0kw6gxvz+ChUhS79jkAcnR4bUSRMpctIi8EgmguA0q6kPSsF +udtgGCf547A47u59J/SRrV3HNJYkka6L0iFFPlVlvzyvXEw/zajwlvBTd6reW79J +1SXdOfLvSA55nKfV622W9IhFlIMoqOuF+gcbH5z4c8bNvw2fydCdBW6FUku/t/4q +HkYci6NAdMtBJzonzwJpQA3EsVQo4818qzm7oyNOjZA3phJbQUG8gEVO17jNK+v7 +fpFnjFDMR55feu5OMcCdlihlriPB8v4YEt4zaEgXjMyScl5sAVRRB3ssb5JI63f9 +lxJq0k8W5nBaJQmwMxYdvtJDkfGq9a7GowY9S9F6JkW/BxZ5/MnTghTq5RmQ/ylo +lIxLJ9H7Gj8LldL0Bg3NhBdaylBv//XrVQPg9ZRryNDWmzGReFa5G/t24aywB3zk +kjlyVz2nEhgfJaU7Jx9uM3WdH8WiuNVaHl4QP8d7Fl0+bO903Pzv2+pmthvuPWA+ +k8ZbluDJi6FMB5IOBZ9XxSlQDkm5R4Ji2xgPAhcD+o93ZA6eo+DMZcw7kGq6wP4a +6bf8h+6xMBaKHcaXxKT/ew== +-----END CERTIFICATE----- diff --git a/tests/elab/async_ssl_certs/tradkey.pem b/tests/elab/async_ssl_certs/tradkey.pem new file mode 100644 index 000000000000..81ccf446f6ea --- /dev/null +++ b/tests/elab/async_ssl_certs/tradkey.pem @@ -0,0 +1,27 @@ +-----BEGIN RSA PRIVATE KEY----- +MIIEowIBAAKCAQEAu0sBn0Pli8icJ0ZV9+1jFBA0/2FWXdD1f+jzyUhcd9M9r2Z6 +jIfUu4ED75GJKJ+6jLaheY5Sbd8w5nXY7oYcB6njY9YbSp1j44YfK3Ngxu7/bv9+ +jvdn89oylJ/KhxhvNPkoluC5BPLl7gv4mtGtVtN4k+6wKSArkiIDaz+Wa12d6R8Z ++JuxsZzsZv+Y7dEl9x0JEVflTBKNHBhKv/Gb5sJzjhteAv6PxcRcPc8cPKQ02m73 +y1caBwjDru1Ad3NB4OkszPHA/0Hn1kES8g/62SMN+BnE7PSJJVsSdJaKo2NatHOa +effdc0QtkqpjOr6QI3OnaYoyAGb7MnHsJZ2NWwIDAQABAoIBAA1eEZwR5wC+jTKa +aQlcdo1YiMfPZTAl+VerQzcTBJKCz6zEpiuAiFTnpOXE3+K338MqR8UavNRdsSpJ +r/V6OebsH7Ag+GqvaBE1oeTig74/EZkVAC3pB5DWenS0IOraehlwTQ7TtDDfuzxt +u00lePcw+bKpPwZ4ZtOzvMW7UJuSAC4XmXeBj6gXUyH9ZKxTT/Ok4eF/gyq57jZo +l0uJQ7oR/64XkX00OFSv7K564//2cCPgHl8J3IduQgcl6fgqEh6cGRj2M35J2QY5 +pIdUG8DEf4r4wPeeAcW1bFpfv3AGIe/jBL5KyJyWKm8ElVkK1ayo0bh6iNDnL8pg +Wxl6Gh0CgYEA4PhwSwdE7fpkKl/im3qNMpivldmNJKa5VbYUxzyR6QPszHBASVo5 +c9CKXX5IygDK1aFSQeBZ/GOFo+Dc6sldQLGf3B7B9zVp8IjGkb1U7OzutFYbNBvy +NpSMek9HZeKlhYyUIs67zHLTRVZL0a4eLZxkJ0zAVYqigAeQolv6P3cCgYEA1SAz +XIYRAIo1DSetHOF3G64Ro5QZow0chin1TNSzEM/bttG2bzj/6i+cDR65RqqZTgVL +w9aPyem+GSIM4VjQdFqz6wQYuNKb7/b+8Ak2d13yfiqxpVjnwdHz1bNpCoy3fG/t +caGuyTP0SSAZsrV496PZUv+he0pIx9BEL9POgj0CgYBPN4wrDzs5ZTMCLNNZljTD +/TnO1VU6865NPRlh8rUaTPSEJH6ulaOnYWZnd4FgCBlkUjLp2Xs2QUEcrKB92DwK +/MDivL3mM5vDRBZP2VBfQSrou21G0xReHb69js8AVGeeeBrtishcPI6iWrnF8r7T +pr8pi4AqXu/Lj15hnWuoDwKBgQC98ucT7YE1w/goc1Y8yU5I40lhS1vWEJd9k+PG +yEOYFkmylRJN6rVb2Xbx0pI6w03DVcEDGDYrNSJycACez3NqYHS+X3ZRM5Q7uR3a +fbuHg7nebNrLjYNxIVh6/F4AQw4939v2TK3lMWLl0bBVsJvRyryk1qTrp3dabup2 +3gXN2QKBgFiiZIcOyqBC6ogqU59yH+2TeuL4KpDWnF3483OA+aCdmqgDybEwXSde +PlUoXnIHOSp9EK4j9Jk1O9dvxoitPANF29NvtaLnq6olBPhGvvq2aYZMgtIPjCnK +AlhVig5rSbgu77Qhiznhbi4B2oaqksiBj1k6gfiVJmKVgViL7tBo +-----END RSA PRIVATE KEY----- diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index 35e3f8698e63..9d556cc71c67 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -22,6 +22,15 @@ def testWildcardCertPEM : String := include_cert% "async_ssl_certs/wildcard.pem" def testMultiSANCertPEM : String := include_cert% "async_ssl_certs/multisan.pem" def testCorruptCertPEM : String := include_cert% "async_ssl_certs/corrupt.pem" +-- Validity window entirely in 2020. Building a context parses certificates without checking their +-- validity period, so this is expected to load like any other. +def testExpiredCertPEM : String := include_cert% "async_ssl_certs/expired.pem" + +-- `key.pem` in the traditional (RFC 1421) encoding rather than PKCS#8. The distinction matters: +-- `PEM_X509_INFO_read_bio` drops a `BEGIN PRIVATE KEY` block entirely, but yields an entry with no +-- certificate for `BEGIN RSA PRIVATE KEY`, which is the case the loader has to skip. +def testTraditionalKeyPEM : String := include_cert% "async_ssl_certs/tradkey.pem" + -- Matches none of the certificates above, so it is only good for provoking a key/cert mismatch. def testUnrelatedKeyPEM : String := include_cert% "async_ssl_certs/key2.pem" @@ -35,6 +44,11 @@ def testEncryptedKeyPEM : String := include_cert% "async_ssl_certs/enckey.pem" -- passphrase rather than a failure decrypts instead of rejecting. def testEmptyPassphraseKeyPEM : String := include_cert% "async_ssl_certs/emptypwkey.pem" +-- `cert.pem` as an RFC 1421 encrypted `CERTIFICATE` block. Unlike an encrypted key, this is +-- decrypted in place while the bundle is read, so it reaches the password callback through a +-- different path in every constructor. +def testEncryptedCertPEM : String := include_cert% "async_ssl_certs/enccert.pem" + -- Three distinct certificates in one file, the shape of a real CA bundle. def testBundlePEM : String := testCertPEM ++ testWildcardCertPEM ++ testMultiSANCertPEM @@ -92,6 +106,23 @@ def setupBundle : IO String := writeTempFile "bundle.pem" testBundlePEM def setupDuplicateBundle : IO String := writeTempFile "dup.pem" (testBundlePEM ++ testCertPEM) +def setupEncryptedCert : IO String := writeTempFile "enccert.pem" testEncryptedCertPEM + +def setupExpiredCert : IO String := writeTempFile "expired.pem" testExpiredCertPEM + +-- A valid leaf followed by a corrupt second certificate, i.e. a chain whose *intermediate* is bad. +def setupCorruptChain : IO String := writeTempFile "chain.pem" (testCertPEM ++ testCorruptCertPEM) + +def setupUnreadableFile : IO String := do + let path ← writeTempFile "secret.pem" testCertPEM + IO.setAccessRights path { user := { read := false, write := false, execution := false } } + return path + +-- A path that treats a regular file as if it were a directory, which the OS refuses with ENOTDIR. +def setupNonDirectoryParent : IO String := do + let path ← writeTempFile "notadir.pem" testCertPEM + return toString (System.FilePath.mk path / "ca.pem") + -- Asserts that an IO action fails with exactly `expected` as its message. def assertErrorMessage (label expected : String) (act : IO Unit) : IO Unit := do match ← act.toBaseIO with @@ -167,9 +198,11 @@ def testMkFromPEMRejectsCorruptCert : IO Unit := do (malformedPEMError "could not read PEM CA certificates from the given string") (discard <| Context.Client.mkFromPEM testCorruptCertPEM true) +-- Text with no PEM armour at all parses to an empty bundle rather than failing to parse, so it is +-- reported as "no certificates" — the same way `mkFromPEM` reports the same bytes. def testMkRejectsMalformedCAFile (junkFile : String) : IO Unit := do assertErrorMessage "malformed CA file" - (malformedFileError junkFile "could not read PEM CA certificates") + (malformedFileError junkFile "the CA file contains no certificates") (discard <| Context.Client.mk junkFile true) def testMkRejectsCorruptCAFile (corruptFile : String) : IO Unit := do @@ -272,6 +305,102 @@ def testMkRejectsNulInCAFile : IO Unit := do (nulByteError caPath) (discard <| Context.Client.mk caPath false) +/-! +Encrypted PEM material must be rejected outright. A passphrase callback reporting failure is what +prevents OpenSSL falling back to its own callback, which prompts on `/dev/tty` and blocks forever — +a hang that no amount of redirecting stdin escapes. `enckey.pem` and `emptypwkey.pem` cover the +private key; the tests here cover an encrypted *certificate*, which is read by a different code path +in each of the three constructors. +-/ + +def testMkServerRejectsEncryptedCert (encCertFile keyFile : String) : IO Unit := do + assertErrorMessage "encrypted server certificate" + (malformedFileError encCertFile "could not read a PEM certificate chain") + (discard <| Context.Server.mk encCertFile keyFile) + +def testMkRejectsEncryptedCertCAFile (encCertFile : String) : IO Unit := do + assertErrorMessage "encrypted CA certificate file" + (malformedFileError encCertFile "could not read PEM CA certificates") + (discard <| Context.Client.mk encCertFile true) + +def testMkFromPEMRejectsEncryptedCert : IO Unit := do + assertErrorMessage "encrypted CA certificate string" + (malformedPEMError "could not read PEM CA certificates from the given string") + (discard <| Context.Client.mkFromPEM testEncryptedCertPEM true) + +-- A CA bundle is required to contain at least one certificate. `SSL_CTX_load_verify_locations` +-- reports success for a file holding only a key, which would leave the trust store silently +-- unchanged, so the count is checked explicitly. +def testMkRejectsCertlessCAFile (keyFile : String) : IO Unit := do + assertErrorMessage "CA file holding only a private key" + (malformedFileError keyFile "the CA file contains no certificates") + (discard <| Context.Client.mk keyFile true) + +def testMkFromPEMRejectsCertlessPEM : IO Unit := do + assertErrorMessage "CA string holding only a private key" + (malformedPEMError "the given CA PEM string contains no certificates") + (discard <| Context.Client.mkFromPEM testKeyPEM true) + +-- Non-certificate entries in a bundle are skipped rather than rejected. A *traditional* RSA key is +-- the case that matters: it yields a parsed entry carrying no certificate, unlike the PKCS#8 form +-- which is dropped before that point. +def testMkFromPEMSkipsTraditionalKey : IO Unit := do + let _clientCtx ← Context.Client.mkFromPEM (testTraditionalKeyPEM ++ testCertPEM) true + let _clientCtx2 ← Context.Client.mkFromPEM (testCertPEM ++ testTraditionalKeyPEM) true + +def testMkFromPEMRejectsTraditionalKeyOnly : IO Unit := do + assertErrorMessage "traditional RSA key with no certificate" + (malformedPEMError "the given CA PEM string contains no certificates") + (discard <| Context.Client.mkFromPEM testTraditionalKeyPEM true) + +/-! +`mkFromPEM` hands OpenSSL an explicit length rather than a C string, so a NUL is data and everything +after it is still parsed. Appending a NUL to a complete certificate would pass either way, so these +put material the parser must still reach *after* the NUL. +-/ + +def testMkFromPEMReadsPastNul : IO Unit := do + let _clientCtx ← Context.Client.mkFromPEM ("\x00\n" ++ testCertPEM) true + +def testMkFromPEMParsesPastNul : IO Unit := do + assertErrorMessage "corrupt certificate after a NUL byte" + (malformedPEMError "could not read PEM CA certificates from the given string") + (discard <| Context.Client.mkFromPEM (testCertPEM ++ "\x00\n" ++ testCorruptCertPEM) true) + +-- The whole chain is loaded, not just the leaf, so a corrupt certificate in a later position is +-- still rejected. This is the observable difference between `SSL_CTX_use_certificate_chain_file` +-- and `SSL_CTX_use_certificate_file`. +def testMkServerRejectsCorruptChainMember (chainFile keyFile : String) : IO Unit := do + assertErrorMessage "corrupt intermediate in the server chain" + (malformedFileError chainFile "could not read a PEM certificate chain") + (discard <| Context.Server.mk chainFile keyFile) + +-- Building a context parses certificates; it does not check their validity period. An expired +-- certificate is therefore accepted here and only rejected at handshake time. +def testAcceptsExpiredCert (expiredFile keyFile : String) : IO Unit := do + let _serverCtx ← Context.Server.mk expiredFile keyFile + let _clientCtx ← Context.Client.mkFromPEM testExpiredCertPEM true + +/-! +The path is reported with the failure whenever the `IO.Error` constructor has room for it. These +also pin the errno itself, which is what would catch a platform decoding an OS error code through +the wrong table. +-/ + +-- Skipped when the permission bits do not bite, which is the case for a privileged user. +def testMkRejectsUnreadableCAFile (unreadableFile : String) : IO Unit := do + if (← (IO.FS.readFile unreadableFile).toBaseIO).isOk then + return + + assertErrorMessage "CA file with no read permission" + s!"permission denied (error code: 13)\n file: {unreadableFile}" + (discard <| Context.Client.mk unreadableFile true) + +def testMkRejectsNonDirectoryParent (notADirPath : String) : IO Unit := do + assertErrorMessage "CA path whose parent is a regular file" + s!"inappropriate type (error code: 20, not a directory)\n file: {notADirPath}" + (discard <| Context.Client.mk notADirPath true) + #eval do let (certFile, keyFile) ← setupTestCerts testContextCreation certFile keyFile @@ -335,3 +464,39 @@ def testMkRejectsNulInCAFile : IO Unit := do testMkServerRejectsNulInCert keyFile testMkServerRejectsNulInKey certFile testMkRejectsNulInCAFile + +-- Encrypted PEM in all three constructors. A regression here does not fail loudly: it blocks on a +-- passphrase prompt, so keep these ahead of anything that would mask a hang. +#eval do + let (_, keyFile) ← setupTestCerts + let encCertFile ← setupEncryptedCert + + testMkServerRejectsEncryptedCert encCertFile keyFile + testMkRejectsEncryptedCertCAFile encCertFile + testMkFromPEMRejectsEncryptedCert + +-- A CA bundle must actually contain a certificate. +#eval do + let (_, keyFile) ← setupTestCerts + + testMkRejectsCertlessCAFile keyFile + testMkFromPEMRejectsCertlessPEM + testMkFromPEMSkipsTraditionalKey + testMkFromPEMRejectsTraditionalKeyOnly + +-- NUL is data, not a terminator. +#eval do + testMkFromPEMReadsPastNul + testMkFromPEMParsesPastNul + +#eval do + let (certFile, keyFile) ← setupTestCerts + + testMkServerRejectsCorruptChainMember (← setupCorruptChain) keyFile + testAcceptsExpiredCert (← setupExpiredCert) keyFile + testMkClientFromPEM certFile + +-- OS-level failures keep the path and the real errno. +#eval do + testMkRejectsUnreadableCAFile (← setupUnreadableFile) + testMkRejectsNonDirectoryParent (← setupNonDirectoryParent) diff --git a/tests/elab/openssl.lean b/tests/elab/openssl.lean index 312656942adb..84d4042587cc 100644 --- a/tests/elab/openssl.lean +++ b/tests/elab/openssl.lean @@ -1,6 +1,10 @@ import Lean.Runtime --- Non-emscripten build: expect the major version of OpenSSL (3) -/-- info: 3 -/ +/-! +Checks that Lean reports the version of the OpenSSL it is linked against. `find_package(OpenSSL 3)` +sets a floor rather than pinning a major version, so this asserts the floor holds. +-/ + +/-- info: true -/ #guard_msgs in -#eval if !System.Platform.isEmscripten then Lean.openSSLVersion >>> 28 else 3 +#eval System.Platform.isEmscripten || Lean.openSSLVersion >>> 28 >= 3 From b4b999757b1e32433019502e453fec4e39bfd415 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Tue, 18 Aug 2026 20:43:16 -0300 Subject: [PATCH 28/36] fix: add trust_store that caches the certificates for TLS --- src/Std/Internal/SSL/Context.lean | 42 ++- src/runtime/CMakeLists.txt | 1 + src/runtime/openssl/context.cpp | 402 ++++++++++-------------- src/runtime/openssl/trust_store.cpp | 331 +++++++++++++++++++ src/runtime/openssl/trust_store.h | 26 ++ tests/elab/async_ssl_certs/README.md | 16 +- tests/elab/async_ssl_certs/crl.pem | 10 + tests/elab/async_ssl_certs/weakcert.pem | 11 + tests/elab/async_ssl_context.lean | 211 ++++++++++++- weak512.pem | 11 + 10 files changed, 796 insertions(+), 265 deletions(-) create mode 100644 src/runtime/openssl/trust_store.cpp create mode 100644 src/runtime/openssl/trust_store.h create mode 100644 tests/elab/async_ssl_certs/crl.pem create mode 100644 tests/elab/async_ssl_certs/weakcert.pem create mode 100644 weak512.pem diff --git a/src/Std/Internal/SSL/Context.lean b/src/Std/Internal/SSL/Context.lean index d81c76db2487..d3786c096f6e 100644 --- a/src/Std/Internal/SSL/Context.lean +++ b/src/Std/Internal/SSL/Context.lean @@ -13,14 +13,19 @@ certificate/key, peer-verification mode, and protocol options shared across all from the same context. For every context, session tickets and TLS compression are disabled, renegotiation is refused, and -TLS 1.2 is the minimum version. Session resumption is therefore not supported. +TLS 1.2 is the minimum version. A server built here therefore offers no session resumption; a client +does not resume either, since resuming additionally requires selecting a session per connection, +which the session layer never does. A context settles who is trusted, not who is being talked to: nothing here checks that a peer certificate matches the host it came from. That check belongs to the session layer, which binds a hostname per connection. -Encrypted PEM material is rejected rather than prompted for, so no constructor can block on a -terminal. +The certificate, key and CA material passed to these constructors is refused outright when it is +encrypted, rather than prompted for, so no constructor can block on a terminal asking for a +passphrase. Material reached through `SSL_CERT_FILE` or `SSL_CERT_DIR` is read by OpenSSL with an +empty passphrase instead: it cannot prompt either, but an encrypted block whose passphrase happens +to be empty is decrypted and trusted there, where the same bytes in `caFile` would be rejected. -/ public section @@ -77,17 +82,29 @@ Trust-anchor semantics: - With `verifyPeer := true` (the default) the client trusts the platform default trust anchors (the system root store) and verifies the peer certificate, so connections to public HTTPS servers work out of the box. A non-empty `caFile` is trusted *in addition* to those system anchors, so public - servers keep working while a private or self-signed CA also becomes trusted. There is no way to - trust `caFile` alone, so this cannot be used to pin against a single CA. + servers keep working while a private CA also becomes trusted. That CA has to be self-signed: a + chain is only accepted once it reaches a self-signed certificate, so trusting an intermediate + alone loads without complaint and then fails every handshake. There is no way to trust `caFile` + alone, so this cannot be used to pin against a single CA. - An empty `caFile` with `verifyPeer := true` uses just the platform default trust anchors. Which - anchors those are is platform-specific: the Keychain system roots on macOS, the `ROOT` store on - Windows, OpenSSL's configured paths elsewhere. `SSL_CERT_FILE` and `SSL_CERT_DIR` are honoured on - every platform, but user-added or explicitly distrusted keychain entries are not consulted. + anchors those are is platform-specific: the Keychain on macOS, the `ROOT` store on Windows, + OpenSSL's configured paths elsewhere. `SSL_CERT_FILE` and `SSL_CERT_DIR` are honoured on every + platform, and are consulted afresh for every context. On macOS the Keychain is read once per + process, since doing so costs around a tenth of a second, so a root added to it after the first + context is built is not picked up until the process restarts. The per-certificate trust settings + decide, so a root added locally (as `mkcert` and `security add-trusted-cert` do) is trusted and + one explicitly denied is not; a + setting that applies only to a named host, key usage, or application grants no trust, since an + anchor cannot carry that restriction. OpenSSL's own bundle is not merged on top of the Keychain, + as it would reinstate the roots those settings turned away; it is read only when the Keychain + yields no anchor at all. `SSL_CERT_FILE` and `SSL_CERT_DIR` name locations of their own, which are + read in addition to the Keychain and do not drag OpenSSL's bundle in with them. - `verifyPeer := false` disables peer verification entirely and the CA file is not parsed. This cannot be undone: a context built this way can never be made to verify. `caFile` must be a path without embedded NUL bytes, which is checked before `verifyPeer` is -consulted. A file containing no certificates is rejected. +consulted. Where the file is read, private key and CRL entries are ignored — no revocation checking +is performed — and a file yielding no certificate at all is rejected. Verifying the peer proves the certificate chains to a trusted anchor; it does **not** prove the certificate belongs to the host being connected to. Binding a hostname is the session layer's job. @@ -108,7 +125,12 @@ hostname verification is left to the session layer: - `verifyPeer := false` disables peer verification entirely (the PEM is not parsed). Unlike `mk`, which takes a path and so rejects embedded NUL bytes, this reads `caPEM` as bytes with -an explicit length: a NUL is ordinary data and the certificates around it are still parsed. +an explicit length, so a NUL does not truncate it. It is still an ordinary junk byte to the PEM +parser, and where it lands decides what happens. A block is recognised only when its line begins with +`-----BEGIN ` and ends with `-----`, so a NUL breaking either of those fixed parts leaves a line that +no longer opens a block and that certificate is dropped without a word. A NUL that leaves the block +open but spoils it — in the type name, in the base64 body, or anywhere in the `-----END` line — +rejects the whole string, valid certificates alongside it included. Outside any block it is harmless. Use this when the CA certificate is embedded in the binary rather than on disk. -/ diff --git a/src/runtime/CMakeLists.txt b/src/runtime/CMakeLists.txt index 06639f199227..f20a813ecb65 100644 --- a/src/runtime/CMakeLists.txt +++ b/src/runtime/CMakeLists.txt @@ -35,6 +35,7 @@ set( uv/signal.cpp openssl.cpp openssl/context.cpp + openssl/trust_store.cpp ) if(USE_MIMALLOC) list(APPEND RUNTIME_OBJS ${LEAN_BINARY_DIR}/../mimalloc/src/mimalloc/src/static.c) diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 0fec1ebf13fb..9f392fbe0477 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -5,6 +5,7 @@ Author: Sofia Rodrigues */ #include "runtime/openssl/context.h" +#include "runtime/openssl/trust_store.h" #ifndef LEAN_EMSCRIPTEN @@ -17,12 +18,9 @@ Author: Sofia Rodrigues #include #include #include +#include #include - -#if defined(__APPLE__) -#include -#include -#endif +#include #endif @@ -32,50 +30,74 @@ lean_external_class * g_ssl_context_external_class = nullptr; #ifndef LEAN_EMSCRIPTEN +static lean_obj_res reject_embedded_nul(b_obj_arg path) { + return strlen(lean_string_cstr(path)) == lean_string_size(path) - 1 + ? nullptr + : mk_embedded_nul_error(path); +} + +// Reports a failure against a path, as an errno-derived IO error where the errno is meaningful. static lean_obj_res mk_ssl_file_error(b_obj_arg file, char const * msg) { ERR_clear_error(); + char const * path = lean_string_cstr(file); int errnum = 0; - FILE * probe = fopen(lean_string_cstr(file), "rb"); - - if (probe == nullptr) errnum = errno; else fclose(probe); + std::string detail(msg); + struct stat st; + + if (stat(path, &st) != 0) { + errnum = errno; + } else if (S_ISREG(st.st_mode)) { + FILE * probe = fopen(path, "rb"); + if (probe == nullptr) errnum = errno; else fclose(probe); + } else { + detail += " (the path is not a regular file)"; + } - if (errnum == ENOENT || errnum == EACCES || errnum == EPERM || errnum == EISDIR || - errnum == ENOTDIR || errnum == ELOOP || errnum == ENAMETOOLONG || errnum == EMFILE || - errnum == ENFILE || errnum == ENOMEM) { + if (errnum == ENOENT || errnum == EACCES || errnum == EPERM || errnum == ENOTDIR || + errnum == ELOOP || errnum == ENAMETOOLONG || errnum == EMFILE || errnum == ENFILE || + errnum == ENOMEM) { return lean_io_result_mk_error(decode_io_error(errnum, file)); } lean_inc(file); return lean_io_result_mk_error(lean_mk_io_error_invalid_argument_file( - file, errnum != 0 ? errnum : EINVAL, mk_string(msg))); + file, errnum != 0 ? errnum : EINVAL, mk_string(detail))); } static int reject_encrypted_pem(char *, int, int, void *) { return -1; } -// Reports a failure that has no errno behind it. The OpenSSL error queue is discarded rather than -// appended, so its entries cannot leak into a later, unrelated diagnosis. +// Reports a failure with no errno behind it, discarding the queue so it cannot taint a later one. static lean_obj_res mk_ssl_invalid_argument(char const * msg) { ERR_clear_error(); return lean_io_result_mk_error(lean_mk_io_error_invalid_argument(EINVAL, mk_string(msg))); } +// Whether a certificate was turned away on policy grounds rather than being unreadable as PEM. +static bool rejected_by_security_level() { + unsigned long err = ERR_peek_last_error(); + + if (ERR_GET_LIB(err) != ERR_LIB_SSL) return false; + + int reason = ERR_GET_REASON(err); + return reason == SSL_R_EE_KEY_TOO_SMALL || reason == SSL_R_CA_KEY_TOO_SMALL || + reason == SSL_R_CA_MD_TOO_WEAK; +} + lean_object * mk_openssl_error(char const * where, int ssl_err) { std::string msg(where); if (ssl_err != 0) msg += " (ssl_error=" + std::to_string(ssl_err) + ")"; - // Drains up to 10 entries from the OpenSSL error queue; marks with "(truncated)" if more remain. - unsigned long err; - bool first = true; - int cap = 10; + for (int i = 0; i < 10; i++) { + unsigned long err = ERR_get_error(); + if (err == 0) break; - while (cap-- > 0 && (err = ERR_get_error()) != 0) { char err_buf[256]; ERR_error_string_n(err, err_buf, sizeof(err_buf)); - msg += first ? ": " : "; "; + + msg += i == 0 ? ": " : "; "; msg += err_buf; - first = false; } if (ERR_peek_error() != 0) { @@ -86,147 +108,73 @@ lean_object * mk_openssl_error(char const * where, int ssl_err) { return lean_mk_io_user_error(mk_string(msg)); } -static void lean_ssl_context_finalizer(void * ptr) { - SSL_CTX_free((SSL_CTX*)ptr); -} +struct ssl_ctx_deleter { void operator()(SSL_CTX * ctx) const { SSL_CTX_free(ctx); } }; + +// Owns a context while it is still being built, so no error path has to remember to free it. +using ssl_ctx_ptr = std::unique_ptr; void initialize_openssl_context() { - g_ssl_context_external_class = lean_register_external_class(lean_ssl_context_finalizer, [](void *, lean_object *) {}); + g_ssl_context_external_class = lean_register_external_class( + [](void * ptr) { SSL_CTX_free((SSL_CTX*)ptr); }, [](void *, lean_object *) {}); } -static bool configure_ctx_options(SSL_CTX * ctx) { +// Applies the hardened options every context shares. The minimum protocol version is left to the +// caller, since it is the only one whose failure is worth reporting. +static void configure_ctx_options(SSL_CTX * ctx) { SSL_CTX_set_options(ctx, - // Disables TLS 1.2 renegotiation (SSL_OP_NO_RENEGOTIATION has no effect on - // TLS 1.3, which replaced renegotiation with key updates). + // No effect on TLS 1.3, which replaced renegotiation with key updates. SSL_OP_NO_RENEGOTIATION | - // Disables TLS compression. Mitigates the CRIME attack (compression leaks - // secret bytes via ciphertext length). Already off by default in OpenSSL 1.1+ - // but set explicitly so the intent is clear. + // Mitigates CRIME, where compression leaks secret bytes via ciphertext length. Already the + // default since OpenSSL 1.1, but set explicitly so the intent is clear. SSL_OP_NO_COMPRESSION | - // Disables RFC 5077 session tickets in TLS 1.2. It does not switch them off in TLS 1.3, - // where it only downgrades them to the stateful form; SSL_CTX_set_num_tickets below is what - // stops those being sent. + // Disables RFC 5077 session tickets in TLS 1.2. In TLS 1.3 it only downgrades them to the + // stateful form; the call below is what stops those being sent. SSL_OP_NO_TICKET ); - // Sends no NewSessionTicket at all in TLS 1.3. Without this a server still puts two of them on - // the wire per connection, useless against the disabled cache below but not free. + // Without this a TLS 1.3 server still puts two NewSessionTickets on the wire per connection. + // Read only by the server state machine. SSL_CTX_set_num_tickets(ctx, 0); - // Installed before any PEM is read, so it covers the certificate chain and the CA bundle as well - // as the private key. + // Covers the certificate chain and the private key. A CA bundle is read through a bare BIO + // rather than the context, so `load_ca_bundle` has to pass the same callback itself. SSL_CTX_set_default_passwd_cb(ctx, reject_encrypted_pem); - // Backs the flags above. A TLS 1.2 server still offers session-ID resumption through this cache - // (which defaults to SSL_SESS_CACHE_SERVER), so turning it off is what makes "no session - // resumption" hold for both protocol versions. + // Backs the flags above: a TLS 1.2 server still offers session-ID resumption through this cache, + // which defaults to SSL_SESS_CACHE_SERVER. The client half of the mask is already off there. SSL_CTX_set_session_cache_mode(ctx, SSL_SESS_CACHE_OFF); - // Reject TLS 1.0 and 1.1. Both are deprecated (RFC 8996) and have known - // protocol-level weaknesses (BEAST, POODLE). TLS 1.2 is the minimum acceptable - // version; TLS 1.3 is preferred and used automatically when both peers support it. - if (SSL_CTX_set_min_proto_version(ctx, TLS1_2_VERSION) != 1) return false; - - // Permit retrying SSL_write() after WANT_READ/WANT_WRITE with the payload at a moved buffer - // address (its contents must stay identical). This lets a session layer relocate a buffered - // write between retries without tripping OpenSSL's buffer-stability check. + // Lets a session layer relocate a buffered write between SSL_write() retries, as long as its + // contents stay identical, without tripping OpenSSL's buffer-stability check. SSL_CTX_set_mode(ctx, SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER); - // Secure hostname-matching default, inherited by every session (SSL) created from this context. - // It is inert until a peer hostname is bound per-connection via SSL_set1_host in the session - // layer; recording it here ensures that check, once wired, rejects partial wildcards such as - // `f*.example.com` (disallowed by RFC 6125 §6.4.3). + // Inherited by every session, and inert until the session layer binds a peer hostname with + // SSL_set1_host; that check then rejects partial wildcards like `f*.example.com` (RFC 9525 + // §6.3, which obsoletes RFC 6125 — the latter still permitted them). X509_VERIFY_PARAM_set_hostflags(SSL_CTX_get0_param(ctx), X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS); - return true; } -// Loads the platform's system root certificates into the context's trust store so clients verify -// public servers out of the box (like a browser). Success does not promise a non-empty trust store: -// only the Apple branch loads anchors eagerly and can count them. -static bool load_system_trust_store(SSL_CTX * ctx) { -#if defined(__APPLE__) - // OpenSSL's default paths don't reach the Keychain, so the anchors are pulled from the Security - // framework as well. This yields the built-in system roots only: certificates a user or an - // administrator added to a keychain are not included, and per-certificate trust settings are - // not consulted, so a root the user explicitly distrusted is still added here. - X509_STORE * store = SSL_CTX_get_cert_store(ctx); - - CFArrayRef anchors = nullptr; - OSStatus status = SecTrustCopyAnchorCertificates(&anchors); - - if (status != errSecSuccess || anchors == nullptr) { - if (anchors != nullptr) CFRelease(anchors); - return false; - } - - int added = 0; - - for (CFIndex i = 0, n = CFArrayGetCount(anchors); i < n; i++) { - SecCertificateRef cert = (SecCertificateRef)CFArrayGetValueAtIndex(anchors, i); - if (cert == nullptr) continue; - - CFDataRef der = SecCertificateCopyData(cert); - if (der == nullptr) continue; - - const unsigned char * data = CFDataGetBytePtr(der); - X509 * x509 = d2i_X509(nullptr, &data, CFDataGetLength(der)); - CFRelease(der); - if (x509 == nullptr) continue; - - // X509_STORE_add_cert bumps the certificate's refcount, so drop our own reference after. - // An anchor already in the store is reported as success and counted like any other. - if (X509_STORE_add_cert(store, x509) == 1) added++; - X509_free(x509); - } - - CFRelease(anchors); - - int paths = SSL_CTX_set_default_verify_paths(ctx); +// Creates a configured SSL_CTX, or returns nullptr with an IO error stored in `*err`. +static ssl_ctx_ptr mk_ssl_ctx_base(const SSL_METHOD * method, lean_obj_res * err) { ERR_clear_error(); - return added > 0 || paths == 1; -#elif defined(LEAN_WINDOWS) - // The Windows ROOT store is reachable only through OpenSSL's winstore provider, which - // `SSL_CTX_set_default_verify_paths` does not consult, so it has to be named explicitly. The - // default paths are still added on top, and a build configured with `no-winstore` falls back to - // them alone. - int winstore = SSL_CTX_load_verify_store(ctx, "org.openssl.winstore://"); - int paths = SSL_CTX_set_default_verify_paths(ctx); - - if (winstore != 1 && paths != 1) return false; - - // Entries a failed load left behind would otherwise be picked up by a later diagnosis in this - // call as its own. - ERR_clear_error(); - return true; -#else - return SSL_CTX_set_default_verify_paths(ctx) == 1; -#endif -} - -// Creates an SSL_CTX with the hardened options shared by all contexts. Returns nullptr and stores -// an IO error in *err on failure. -static SSL_CTX * mk_ssl_ctx_base(const SSL_METHOD * method, lean_obj_res * err) { if (!ensure_openssl_initialized()) { *err = mk_openssl_io_error("OPENSSL_init_ssl failed"); return nullptr; } - ERR_clear_error(); - - SSL_CTX * ctx = SSL_CTX_new(method); + ssl_ctx_ptr ctx(SSL_CTX_new(method)); if (ctx == nullptr) { *err = mk_openssl_io_error("SSL_CTX_new failed"); return nullptr; } - if (!configure_ctx_options(ctx)) { - SSL_CTX_free(ctx); - // SSL_CTX_set_min_proto_version is the only way to get here, and it reports failure without - // pushing anything onto the OpenSSL error queue, so this message has to stand on its own. + configure_ctx_options(ctx.get()); +. + if (SSL_CTX_set_min_proto_version(ctx.get(), TLS1_2_VERSION) != 1) { *err = mk_openssl_io_error("SSL_CTX_set_min_proto_version failed"); return nullptr; } @@ -234,158 +182,137 @@ static SSL_CTX * mk_ssl_ctx_base(const SSL_METHOD * method, lean_obj_res * err) return ctx; } -// Wraps a fully configured SSL_CTX into a Lean external object, taking ownership of ctx. -static lean_obj_res wrap_ssl_context(SSL_CTX * ctx) { - lean_object * obj = lean_ssl_context_new(ctx); +// Wraps a fully configured SSL_CTX into a Lean external object, taking ownership of it. +static lean_obj_res wrap_ssl_context(ssl_ctx_ptr ctx) { + lean_object * obj = lean_ssl_context_new(ctx.release()); lean_mark_mt(obj); return lean_io_result_mk_ok(obj); } -/* Std.Internal.SSL.Context.Server.mk (certFile keyFile : @& String) : IO Context.Server */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, b_obj_arg key_file) { - const char * cert = lean_string_cstr(cert_file); - if (strlen(cert) != lean_string_size(cert_file) - 1) return mk_embedded_nul_error(cert_file); - - const char * key = lean_string_cstr(key_file); - if (strlen(key) != lean_string_size(key_file) - 1) return mk_embedded_nul_error(key_file); - - lean_obj_res err = nullptr; - // The server presents its certificate but never authenticates the client (no mutual TLS). - SSL_CTX * ctx = mk_ssl_ctx_base(TLS_server_method(), &err); - if (ctx == nullptr) return err; +// Loads the certificate chain the server presents and the key it signs with, from paths the caller +// has passed through `reject_embedded_nul`. +static lean_obj_res load_server_credentials(SSL_CTX * ctx, b_obj_arg cert_file, b_obj_arg key_file) { + ERR_clear_error(); - // Load the leaf certificate plus any intermediates from the PEM file (unlike - // SSL_CTX_use_certificate_file, which loads only the leaf), so the server presents the full - // chain and clients can build a path to a trusted root. - if (SSL_CTX_use_certificate_chain_file(ctx, cert) <= 0) { - SSL_CTX_free(ctx); - return mk_ssl_file_error(cert_file, "could not read a PEM certificate chain"); + if (SSL_CTX_use_certificate_chain_file(ctx, lean_string_cstr(cert_file)) <= 0) { + return mk_ssl_file_error(cert_file, rejected_by_security_level() + ? "the certificate is rejected by the TLS security level (key too small or signature " + "digest too weak)" + : "could not read a PEM certificate chain"); } - // Both key calls below are diagnosed from the error queue, so each must see only its own - // entries. ERR_clear_error(); - // A key of the same algorithm as the certificate is compared against it here. The only errors - // this raises from ERR_LIB_X509 come from that comparison, so they distinguish a key that does - // not belong to the certificate from one that could not be read at all. - if (SSL_CTX_use_PrivateKey_file(ctx, key, SSL_FILETYPE_PEM) <= 0) { - bool mismatch = ERR_GET_LIB(ERR_peek_last_error()) == ERR_LIB_X509; + char const * mismatch = "the private key does not match the certificate"; - SSL_CTX_free(ctx); - return mk_ssl_file_error(key_file, mismatch - ? "the private key does not match the certificate" + if (SSL_CTX_use_PrivateKey_file(ctx, lean_string_cstr(key_file), SSL_FILETYPE_PEM) <= 0) { + return mk_ssl_file_error(key_file, ERR_GET_LIB(ERR_peek_last_error()) == ERR_LIB_X509 + ? mismatch : "could not read an unencrypted PEM private key"); } ERR_clear_error(); - // A key whose algorithm differs from the certificate's occupies a different slot in the context - // and is never compared above, so it is accepted there and only caught here. Without this the - // context would be built with no usable certificate and fail at handshake time instead. - if (SSL_CTX_check_private_key(ctx) != 1) { - SSL_CTX_free(ctx); - return mk_ssl_file_error(key_file, "the private key does not match the certificate"); - } + if (SSL_CTX_check_private_key(ctx) != 1) return mk_ssl_file_error(key_file, mismatch); - return wrap_ssl_context(ctx); + return nullptr; } -// Shared skeleton of the client constructors. With verification off the CA material is never -// consulted, so `load_ca` is skipped entirely; otherwise the platform's trust anchors are loaded -// first and `load_ca` adds the caller's own CAs on top of them, additively. `load_ca` returns -// nullptr on success, or an IO error to propagate. +/* Std.Internal.SSL.Context.Server.mk (certFile keyFile : @& String) : IO Context.Server */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, b_obj_arg key_file) { + if (lean_obj_res err = reject_embedded_nul(cert_file)) return err; + if (lean_obj_res err = reject_embedded_nul(key_file)) return err; + + lean_obj_res base_err = nullptr; + ssl_ctx_ptr ctx = mk_ssl_ctx_base(TLS_server_method(), &base_err); + if (ctx == nullptr) return base_err; + + // The server presents its certificate but never authenticates the client (no mutual TLS). + SSL_CTX_set_verify(ctx.get(), SSL_VERIFY_NONE, nullptr); + + if (lean_obj_res err = load_server_credentials(ctx.get(), cert_file, key_file)) return err; + + return wrap_ssl_context(std::move(ctx)); +} + +// Shared skeleton of the client constructors; `load_ca` returns nullptr or an IO error to propagate. template static lean_obj_res mk_client_ctx(uint8_t verify_peer, LoadCA load_ca) { lean_obj_res err = nullptr; - SSL_CTX * ctx = mk_ssl_ctx_base(TLS_client_method(), &err); + ssl_ctx_ptr ctx = mk_ssl_ctx_base(TLS_client_method(), &err); if (ctx == nullptr) return err; + // With verification off the CA material is never consulted. if (!verify_peer) { - SSL_CTX_set_verify(ctx, SSL_VERIFY_NONE, nullptr); - return wrap_ssl_context(ctx); + SSL_CTX_set_verify(ctx.get(), SSL_VERIFY_NONE, nullptr); + return wrap_ssl_context(std::move(ctx)); } - if (!load_system_trust_store(ctx)) { - SSL_CTX_free(ctx); - return mk_openssl_io_error("failed to load system trust store"); - } + std::string detail; - if (lean_obj_res ca_err = load_ca(ctx)) { - SSL_CTX_free(ctx); - return ca_err; + if (!load_system_trust_store(ctx.get(), &detail)) { + std::string msg("failed to load system trust store"); + if (!detail.empty()) msg += ": " + detail; + + return lean_io_result_mk_error(mk_openssl_error(msg.c_str())); } - SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER, nullptr); - return wrap_ssl_context(ctx); + // The caller's own CAs are added on top of the platform anchors, not in place of them. + if (lean_obj_res ca_err = load_ca(ctx.get())) return ca_err; + + SSL_CTX_set_verify(ctx.get(), SSL_VERIFY_PEER, nullptr); + return wrap_ssl_context(std::move(ctx)); } -// Adds every certificate the BIO yields to the context's trust store, on top of the system anchors -// already there. Returns 0 if the PEM could not be read at all, otherwise the number of -// certificates found; `*err` is set only for a hard failure. Non-certificate entries (private keys, -// CRLs) are skipped, matching what a CA bundle file is allowed to contain. -// -// Both client constructors share this, so an in-memory bundle and a bundle on disk are accepted and -// rejected on exactly the same terms. -static int add_ca_certificates(SSL_CTX * ctx, BIO * bio, bool * read_failed, lean_obj_res * err) { - STACK_OF(X509_INFO) * infos = PEM_X509_INFO_read_bio(bio, nullptr, reject_encrypted_pem, nullptr); +// Adds every certificate `bio` yields to the trust store, on top of the system anchors already there, +// and frees `bio`. +template +static lean_obj_res load_ca_bundle(SSL_CTX * ctx, BIO * bio, char const * unreadable, char const * no_certs, MkErr mk_err) { + if (bio == nullptr) return mk_err(unreadable); - if (infos == nullptr) { - *read_failed = true; - return 0; - } + STACK_OF(X509_INFO) * infos = PEM_X509_INFO_read_bio(bio, nullptr, reject_encrypted_pem, nullptr); + BIO_free(bio); - *read_failed = false; + if (infos == nullptr) return mk_err(unreadable); X509_STORE * store = SSL_CTX_get_cert_store(ctx); + lean_obj_res err = nullptr; int cert_count = 0; - for (int i = 0; i < sk_X509_INFO_num(infos); i++) { - X509_INFO * info = sk_X509_INFO_value(infos, i); - if (info->x509 == nullptr) continue; + for (int i = 0, n = sk_X509_INFO_num(infos); i < n; i++) { + X509 * cert = sk_X509_INFO_value(infos, i)->x509; + + if (cert == nullptr) continue; cert_count++; -. - if (X509_STORE_add_cert(store, info->x509) != 1) { - sk_X509_INFO_pop_free(infos, X509_INFO_free); - *err = mk_openssl_io_error("X509_STORE_add_cert failed"); - return 0; + + if (X509_STORE_add_cert(store, cert) != 1) { + err = mk_openssl_io_error("X509_STORE_add_cert failed"); + break; } } sk_X509_INFO_pop_free(infos, X509_INFO_free); - return cert_count; + + if (err != nullptr) return err; + if (cert_count == 0) return mk_err(no_certs); + + return nullptr; } -/* Std.Internal.SSL.Context.Client.mk (caFile : @& String) (verifyPeer : Bool) : IO Context.Client */ +/* Std.Internal.SSL.Context.Client.mkImpl (caFile : @& String) (verifyPeer : Bool) : IO Context.Client */ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, uint8_t verify_peer) { - const char * ca = lean_string_cstr(ca_file); - if (strlen(ca) != lean_string_size(ca_file) - 1) return mk_embedded_nul_error(ca_file); + if (lean_obj_res err = reject_embedded_nul(ca_file)) return err; return mk_client_ctx(verify_peer, [&](SSL_CTX * ctx) -> lean_obj_res { + const char * ca = lean_string_cstr(ca_file); + // An empty CA path leaves the client with just the system trust anchors. if (ca[0] == '\0') return nullptr; - BIO * bio = BIO_new_file(ca, "r"); - if (bio == nullptr) return mk_ssl_file_error(ca_file, "could not read PEM CA certificates"); - - bool read_failed = false; - lean_obj_res err = nullptr; - int cert_count = add_ca_certificates(ctx, bio, &read_failed, &err); - - BIO_free(bio); - - if (err != nullptr) return err; - if (read_failed) return mk_ssl_file_error(ca_file, "could not read PEM CA certificates"); - - // `SSL_CTX_load_verify_locations` reports success for a file holding no certificates at all - // (a lone CRL, or a private key), which silently leaves the trust store unchanged. Counting - // is what turns that misconfiguration into an error. - if (cert_count == 0) { - return mk_ssl_file_error(ca_file, "the CA file contains no certificates"); - } - - return nullptr; + return load_ca_bundle(ctx, BIO_new_file(ca, "r"), + "could not read PEM CA certificates", "the CA file contains no certificates", + [&](char const * msg) { return mk_ssl_file_error(ca_file, msg); }); }); } @@ -395,26 +322,13 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca const char * pem = lean_string_cstr(ca_pem); size_t pem_size = lean_string_size(ca_pem) - 1; - // An empty PEM leaves the client with just the system trust anchors. if (pem_size == 0) return nullptr; - if (pem_size > INT_MAX) return mk_ssl_invalid_argument("the CA PEM string is too large"); - BIO * bio = BIO_new_mem_buf(pem, (int)pem_size); - if (bio == nullptr) return mk_openssl_io_error("BIO_new_mem_buf failed"); - - bool read_failed = false; - lean_obj_res err = nullptr; - int cert_count = add_ca_certificates(ctx, bio, &read_failed, &err); - - BIO_free(bio); - - if (err != nullptr) return err; - if (read_failed) return mk_ssl_invalid_argument("could not read PEM CA certificates from the given string"); - - if (cert_count == 0) return mk_ssl_invalid_argument("the given CA PEM string contains no certificates"); - - return nullptr; + return load_ca_bundle(ctx, BIO_new_mem_buf(pem, (int)pem_size), + "could not read PEM CA certificates from the given string", + "the given CA PEM string contains no certificates", + mk_ssl_invalid_argument); }); } diff --git a/src/runtime/openssl/trust_store.cpp b/src/runtime/openssl/trust_store.cpp new file mode 100644 index 000000000000..ac580672e8df --- /dev/null +++ b/src/runtime/openssl/trust_store.cpp @@ -0,0 +1,331 @@ +/* +Copyright (c) 2026 Lean FRO, LLC. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Sofia Rodrigues +*/ + +#include "runtime/openssl/trust_store.h" + +#ifndef LEAN_EMSCRIPTEN + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#if defined(__APPLE__) +#include +#include +#endif + +namespace lean { + +// Every anchor the Keychain offers for TLS, or null if even the empty list could not be built. +static STACK_OF(X509) * g_keychain_anchors = nullptr; +static std::once_flag g_keychain_anchors_once; + +#if defined(__APPLE__) || defined(LEAN_WINDOWS) + +// A variable set to the empty string names no path, so it is reported as unset. OpenSSL's own check is +// a bare non-NULL test, which takes the empty string for a path, finds nothing, and quietly leaves the +// store without those anchors. +static char const * getenv_or_null_if_empty(char const * name) { + char const * value = getenv(name); + return value != nullptr && value[0] != '\0' ? value : nullptr; +} + +// Whether the store demonstrably holds no trust anchor. +static bool trust_store_has_no_certs(X509_STORE * store) { + if (char const * dir = getenv_or_null_if_empty(X509_get_default_cert_dir_env())) { +#if defined(LEAN_WINDOWS) + char const sep = ';'; +#else + char const sep = ':'; +#endif + std::string list(dir); + + for (size_t p = 0; p <= list.size(); ) { + size_t end = std::min(list.find(sep, p), list.size()); + std::string entry = list.substr(p, end - p); + struct stat st; + + if (!entry.empty() && stat(entry.c_str(), &st) == 0 && S_ISDIR(st.st_mode)) return false; + p = end + 1; + } + } + + STACK_OF(X509) * certs = X509_STORE_get1_all_certs(store); + if (certs == nullptr) return true; + + bool empty = sk_X509_num(certs) == 0; + sk_X509_pop_free(certs, X509_free); + + return empty; +} +#endif + +#if defined(__APPLE__) + +static bool cf_is(CFTypeRef value, CFTypeID type) { + return value != nullptr && CFGetTypeID(value) == type; +} + +static bool cf_array_contains(CFArrayRef array, CFTypeRef value) { + return array != nullptr && CFArrayContainsValue(array, CFRangeMake(0, CFArrayGetCount(array)), value); +} + +static bool as_number(CFTypeRef value, int64_t * out) { + return cf_is(value, CFNumberGetTypeID()) && CFNumberGetValue((CFNumberRef)value, kCFNumberSInt64Type, out); +} + +// Whether a trust setting's policy governs TLS at all (there are other types of things that the policy +// can deal with). +static bool policy_covers_tls(SecPolicyRef policy) { + CFDictionaryRef props = SecPolicyCopyProperties(policy); + if (props == nullptr) return false; + + CFTypeRef oid = CFDictionaryGetValue(props, kSecPolicyOid); + CFTypeRef client = CFDictionaryGetValue(props, kSecPolicyClient); + + bool tls = cf_is(oid, CFStringGetTypeID()) && CFEqual(oid, kSecPolicyAppleSSL) && + !(cf_is(client, CFBooleanGetTypeID()) && CFBooleanGetValue((CFBooleanRef)client)); + + CFRelease(props); + return tls; +} + +static bool rule_names_client_policy(CFDictionaryRef rule) { + CFTypeRef name = CFDictionaryGetValue(rule, CFSTR("kSecTrustSettingsPolicyName")); + return cf_is(name, CFStringGetTypeID()) && CFEqual(name, CFSTR("sslClient")); +} + +// Whether a rule carries a usage constraint beyond its policy that a trust store cannot record. +static bool constrained_beyond_policy(CFDictionaryRef rule) { + // A host name for the TLS policy, and the application performing the verification. + if (CFDictionaryGetValue(rule, kSecTrustSettingsPolicyString) != nullptr || + CFDictionaryGetValue(rule, kSecTrustSettingsApplication) != nullptr) { + return true; + } + + CFTypeRef usage = CFDictionaryGetValue(rule, kSecTrustSettingsKeyUsage); + if (usage == nullptr) return false; + + int64_t bits = 0; + return !as_number(usage, &bits) || (bits & kSecTrustSettingsKeyUseSignCert) == 0; +} + +enum class trust_setting { unspecified, trusted, denied }; + +// What one domain's trust settings say about using `cert` as a TLS anchor. +static trust_setting tls_trust_setting(SecCertificateRef cert, SecTrustSettingsDomain domain) { + CFArrayRef settings = nullptr; + + if (SecTrustSettingsCopyTrustSettings(cert, domain, &settings) != errSecSuccess || settings == nullptr) { + return trust_setting::unspecified; + } + + // An empty settings array is how Apple encodes unconditional trust. + CFIndex count = CFArrayGetCount(settings); + trust_setting result = count == 0 ? trust_setting::trusted : trust_setting::unspecified; + + for (CFIndex i = 0; i < count; i++) { + CFTypeRef entry = CFArrayGetValueAtIndex(settings, i); + if (!cf_is(entry, CFDictionaryGetTypeID())) continue; + + CFDictionaryRef rule = (CFDictionaryRef)entry; + + if (rule_names_client_policy(rule)) continue; + + CFTypeRef policy = CFDictionaryGetValue(rule, kSecTrustSettingsPolicy); + if (policy != nullptr && + !(cf_is(policy, SecPolicyGetTypeID()) && policy_covers_tls((SecPolicyRef)policy))) { + continue; + } + + CFTypeRef result_value = CFDictionaryGetValue(rule, kSecTrustSettingsResult); + int64_t verdict = kSecTrustSettingsResultTrustRoot; + if (result_value != nullptr && !as_number(result_value, &verdict)) continue; + + if (verdict == kSecTrustSettingsResultDeny) { + result = trust_setting::denied; + break; + } + + if ((verdict == kSecTrustSettingsResultTrustRoot || + verdict == kSecTrustSettingsResultTrustAsRoot) && !constrained_beyond_policy(rule)) { + result = trust_setting::trusted; + } + } + + CFRelease(settings); + return result; +} + +static const SecTrustSettingsDomain g_trust_domains[] = { + kSecTrustSettingsDomainUser, + kSecTrustSettingsDomainAdmin, + kSecTrustSettingsDomainSystem, +}; + +static constexpr size_t g_trust_domain_count = std::size(g_trust_domains); + +// The highest-ranked domain with an opinion about `cert` is the one that decides. +static bool trusted_as_tls_anchor(SecCertificateRef cert, CFArrayRef const * listed, + bool const * unknown, size_t found_in) { + for (size_t d = 0; d < g_trust_domain_count; d++) { + if (d != found_in && !unknown[d] && !cf_array_contains(listed[d], cert)) continue; + + switch (tls_trust_setting(cert, g_trust_domains[d])) { + case trust_setting::trusted: return true; + case trust_setting::denied: return false; + case trust_setting::unspecified: break; + } + } + + return false; +} + +static void collect_keychain_anchors() { + g_keychain_anchors = sk_X509_new_null(); + if (g_keychain_anchors == nullptr) return; + + CFArrayRef listed[g_trust_domain_count] = {}; + bool unknown[g_trust_domain_count] = {}; + + for (size_t d = 0; d < g_trust_domain_count; d++) { + OSStatus status = SecTrustSettingsCopyCertificates(g_trust_domains[d], &listed[d]); + + if (status != errSecSuccess) { + if (listed[d] != nullptr) CFRelease(listed[d]); + listed[d] = nullptr; + + // `errSecNoTrustSettings` is the domain reporting that it holds none, which is the + // ordinary state of the user and administrator domains. Any other failure leaves its + // contents unknown, and a domain that could not be listed still has to be asked about + // every certificate, or a verdict it holds — a deny above all — is skipped unseen. + unknown[d] = status != errSecNoTrustSettings; + } + } + + for (size_t d = 0; d < g_trust_domain_count; d++) { + if (listed[d] == nullptr) continue; + + for (CFIndex i = 0, n = CFArrayGetCount(listed[d]); i < n; i++) { + CFTypeRef entry = CFArrayGetValueAtIndex(listed[d], i); + if (!cf_is(entry, SecCertificateGetTypeID())) continue; + + SecCertificateRef cert = (SecCertificateRef)entry; + if (!trusted_as_tls_anchor(cert, listed, unknown, d)) continue; + + CFDataRef der = SecCertificateCopyData(cert); + if (der == nullptr) continue; + + const unsigned char * data = CFDataGetBytePtr(der); + X509 * x509 = d2i_X509(nullptr, &data, CFDataGetLength(der)); + CFRelease(der); + if (x509 == nullptr) continue; + + // These certificates are shared by every context, so they are read concurrently. OpenSSL + // fills a certificate's extension cache on its first use in a verification, under the + // certificate's own lock; filling it here instead keeps that write on this thread, and so + // does not rest on how the linked OpenSSL orders it. + X509_check_purpose(x509, -1, -1); + + if (sk_X509_push(g_keychain_anchors, x509) == 0) X509_free(x509); + } + } + + for (size_t d = 0; d < g_trust_domain_count; d++) { + if (listed[d] != nullptr) CFRelease(listed[d]); + } +} +#endif + +bool load_system_trust_store(SSL_CTX * ctx, std::string * detail) { +#if defined(__APPLE__) + std::call_once(g_keychain_anchors_once, collect_keychain_anchors); + + X509_STORE * store = SSL_CTX_get_cert_store(ctx); + int anchor_count = g_keychain_anchors != nullptr ? sk_X509_num(g_keychain_anchors) : 0; + bool any_anchor = false; + + // The store takes a reference to each anchor. A certificate listed by more than one domain is + // deduplicated and reported as success. + for (int i = 0; i < anchor_count; i++) { + if (X509_STORE_add_cert(store, sk_X509_value(g_keychain_anchors, i)) == 1) any_anchor = true; + } + + // The env-named locations are loaded on their own because `SSL_CTX_set_default_verify_paths` would + // also arm the compiled-in sibling of whichever variable is unset, and OpenSSL's bundle is read + // whole: merging it would put back every anchor the trust settings above turned away, and nothing + // can take an anchor out of the store again. It is left to the `!any_anchor` fallback below, where + // there is no verdict left to contradict. + char const * env_file = getenv_or_null_if_empty(X509_get_default_cert_file_env()); + char const * env_dir = getenv_or_null_if_empty(X509_get_default_cert_dir_env()); + + // Naming a bundle that cannot be read is a configuration error, and the only one of these loads + // whose failure can be diagnosed: a hash directory resolves lazily, and the default-paths call + // discards its result. Unreported it resurfaces much later, as a verification failure against + // the anchor that never loaded. + if (env_file != nullptr && X509_STORE_load_file(store, env_file) != 1) { + *detail = std::string(X509_get_default_cert_file_env()) + + " names a file holding no readable certificate"; + return false; + } + + if (env_dir != nullptr) X509_STORE_load_path(store, env_dir); + + if (!any_anchor) { + SSL_CTX_set_default_verify_paths(ctx); + + if (trust_store_has_no_certs(store)) { + *detail = "the Keychain yielded no anchor trusted for TLS and OpenSSL's default paths " + "hold no certificate either"; + return false; + } + } + + // Entries left by a certificate the loop skipped, or by a configured path that does not exist, + // would otherwise be picked up by a later, unrelated diagnosis as its own. + ERR_clear_error(); + return true; +#elif defined(LEAN_WINDOWS) + // The Windows ROOT store is reachable only through OpenSSL's winstore loader (added in OpenSSL + // 3.2), which `SSL_CTX_set_default_verify_paths` does not consult, so it has to be named explicitly. + int winstore = SSL_CTX_load_verify_store(ctx, "org.openssl.winstore://"); + + // The fallback for builds without that loader. + SSL_CTX_set_default_verify_paths(ctx); + + // A successful winstore load resolves lazily and is invisible to the count, so the count is + // consulted only once winstore is out of the picture. What can still rescue that case is an + // `SSL_CERT_FILE` bundle, which is read on the spot, or an `SSL_CERT_DIR` that exists. + if (winstore != 1 && trust_store_has_no_certs(SSL_CTX_get_cert_store(ctx))) { + *detail = "the Windows ROOT store is unavailable (it needs OpenSSL 3.2 or later) and no CA file was configured"; + return false; + } + + ERR_clear_error(); + return true; +#else + // Only registering the lookups can fail here; whether they resolve to any certificate is not + // reported, so an installation with no CA material at all passes and fails at handshake time. + if (SSL_CTX_set_default_verify_paths(ctx) != 1) { + *detail = "OpenSSL's default certificate paths could not be registered"; + return false; + } + + ERR_clear_error(); + return true; +#endif +} + +} + +#endif diff --git a/src/runtime/openssl/trust_store.h b/src/runtime/openssl/trust_store.h new file mode 100644 index 000000000000..0d6077adbcd7 --- /dev/null +++ b/src/runtime/openssl/trust_store.h @@ -0,0 +1,26 @@ +/* +Copyright (c) 2026 Lean FRO, LLC. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Author: Sofia Rodrigues +*/ +#pragma once + +#include + +#ifndef LEAN_EMSCRIPTEN +#include +#include +#endif + +namespace lean { + +#ifndef LEAN_EMSCRIPTEN + +// Loads the platform's root certificates into `ctx`'s store so clients verify public servers out of +// the box, setting `*detail` to the platform-level cause of a failure the OpenSSL error queue does +// not carry. The anchors are added to whatever the store already holds, never in place of it. +bool load_system_trust_store(SSL_CTX * ctx, std::string * detail); + +#endif + +} diff --git a/tests/elab/async_ssl_certs/README.md b/tests/elab/async_ssl_certs/README.md index 5bddba8d2df6..34bc82eace37 100644 --- a/tests/elab/async_ssl_certs/README.md +++ b/tests/elab/async_ssl_certs/README.md @@ -7,9 +7,10 @@ test time) so the tests neither shell out to the `openssl` CLI nor depend on it installed — subprocess spawning in these tests also produced spurious LeakSanitizer reports in the sanitizer CI build. -All certificates are signed by `key.pem` (RSA-2048) and are valid until 2126, except -`expired.pem`, whose validity window is entirely in 2020 (used to verify that expired -certificates are rejected). +All certificates are signed by `key.pem` (RSA-2048) and are valid until 2126, with two exceptions: +`expired.pem`, whose validity window is entirely in 2020 (used to verify that expired certificates +are rejected), and `weakcert.pem`, which is self-signed under a throwaway 512-bit key that is not +kept. | file | subject | notes | |---|---|---| @@ -25,6 +26,8 @@ certificates are rejected). | `multisan.pem` | `CN=alpha.test.local` | SAN: `DNS:alpha.test.local, DNS:beta.test.local` | | `expired.pem` | `CN=localhost` | valid 2020-01-01 → 2020-01-02 only | | `corrupt.pem` | | `cert.pem` with one bit flipped in the first DER byte (`SEQUENCE` tag → `SET`) | +| `weakcert.pem` | `CN=localhost` | self-signed under a 512-bit RSA key; parses perfectly but is below every security level a build may default to, so it is refused on policy grounds rather than as unreadable PEM | +| `crl.pem` | | a CRL issued by `cert.pem`; the non-certificate bundle entry that is *not* a private key, so it is what distinguishes "holds no certificates" from "could not be read" | `corrupt.pem` still has intact PEM armour and valid base64 — it differs from `cert.pem` by a single character — so it only fails once the certificate body is decoded, which exercises the @@ -48,6 +51,13 @@ openssl genpkey -algorithm EC -pkeyopt ec_paramgen_curve:P-256 -out eckey.pem openssl pkey -in key.pem -aes256 -passout pass:lean4 -out enckey.pem openssl pkey -in key.pem -aes256 -passout pass: -out emptypwkey.pem openssl rsa -in key.pem -traditional -out tradkey.pem +# 512-bit key kept only long enough to self-sign the certificate; nothing loads it. 1024 bits would +# sit exactly on security level 1's floor, making the test depend on which level the build defaults to. +openssl req -x509 -newkey rsa:512 -keyout weakkey.pem -out weakcert.pem -days 36500 -nodes \ + -subj "/CN=localhost" && rm weakkey.pem +mkdir -p ca/newcerts && touch ca/index.txt && echo 01 > ca/crlnumber +printf '[ca]\ndefault_ca=CA_default\n[CA_default]\ndatabase=./ca/index.txt\ncrlnumber=./ca/crlnumber\ndefault_md=sha256\ndefault_crl_days=36500\n' > ca/openssl.cnf +openssl ca -config ca/openssl.cnf -gencrl -cert cert.pem -keyfile key.pem -out crl.pem && rm -r ca python3 -c ' import base64, hashlib, subprocess, textwrap # Legacy RFC 1421 PEM encryption: key = EVP_BytesToKey(MD5, salt=IV, passphrase), 24 bytes for 3DES. diff --git a/tests/elab/async_ssl_certs/crl.pem b/tests/elab/async_ssl_certs/crl.pem new file mode 100644 index 000000000000..b2ea9cc7b710 --- /dev/null +++ b/tests/elab/async_ssl_certs/crl.pem @@ -0,0 +1,10 @@ +-----BEGIN X509 CRL----- +MIIBbjBYAgEBMA0GCSqGSIb3DQEBCwUAMBQxEjAQBgNVBAMMCWxvY2FsaG9zdBcN +MjYwODE3MTI0OTEwWhgPMjEyNjA3MjQxMjQ5MTBaoA4wDDAKBgNVHRQEAwIBATAN +BgkqhkiG9w0BAQsFAAOCAQEAYnbANtNZW0/FBkZQjNDa/mBqDNDYh4uAQWH0zkCm +kVGRjMNMB33J4XyaVlOJ7/I5TbrCQGzEAtFqzF5WlPFZEUNp/Ve/5CCSXUbrX94l +sst48shAoGlvApU1BEI//NppOJTr4PWxkfh8GhWMfU+EHnvghsnKIbAbFMnBV/hJ +dz+w64s6h43oAf5g3WpwhK9XHm6s3IljrDNwmtfEgvR+OHonZPMIOWu3YSZiftl0 +VytTNnLx5QuvEjasZVFXX33llsM6zkXrtLGSjkpdvWFmR6AtmJ0NZwccD/BBrCTw +8NudNxrvIwRUNvNa+OZTB49hfp4OVIvnDcr/R4ii80O/og== +-----END X509 CRL----- diff --git a/tests/elab/async_ssl_certs/weakcert.pem b/tests/elab/async_ssl_certs/weakcert.pem new file mode 100644 index 000000000000..87d59a1ff1fa --- /dev/null +++ b/tests/elab/async_ssl_certs/weakcert.pem @@ -0,0 +1,11 @@ +-----BEGIN CERTIFICATE----- +MIIBgTCCASugAwIBAgIUUh8zV3Ot1AzqtF6hLxvpOhb0e7AwDQYJKoZIhvcNAQEL +BQAwFDESMBAGA1UEAwwJbG9jYWxob3N0MCAXDTI2MDgxODE1MzIyNVoYDzIxMjYw +NzI1MTUzMjI1WjAUMRIwEAYDVQQDDAlsb2NhbGhvc3QwXDANBgkqhkiG9w0BAQEF +AANLADBIAkEA4D1MjlOXaLr8HamPDGwJLeoQ4JDFYdSkNB81DOAbBgvjDlVTwJeF +TU4cZyBSQYtMP191GRdMuGLWMnR/knQtZQIDAQABo1MwUTAdBgNVHQ4EFgQUAv+R +T286YKRTO5l4TNK2r4GyY6AwHwYDVR0jBBgwFoAUAv+RT286YKRTO5l4TNK2r4Gy +Y6AwDwYDVR0TAQH/BAUwAwEB/zANBgkqhkiG9w0BAQsFAANBAK+5wtqiMSn0mTBS +JTF7/1vdYd0K9Yu+MT8zO1WlegFr42LgmFb/4TAMAlytX74LsRWUaXGPPJW+Co3/ +0sTyEDg= +-----END CERTIFICATE----- diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index 9d556cc71c67..f24d91a78d16 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -49,6 +49,14 @@ def testEmptyPassphraseKeyPEM : String := include_cert% "async_ssl_certs/emptypw -- different path in every constructor. def testEncryptedCertPEM : String := include_cert% "async_ssl_certs/enccert.pem" +-- Self-signed under a 512-bit RSA key. It parses like any other certificate and is turned away by +-- the security level instead, which is a different failure from unreadable PEM. +def testWeakCertPEM : String := include_cert% "async_ssl_certs/weakcert.pem" + +-- A CRL: the non-certificate bundle entry that is not a private key. It is what separates "this +-- bundle holds no certificates" from "this bundle could not be read". +def testCRLPEM : String := include_cert% "async_ssl_certs/crl.pem" + -- Three distinct certificates in one file, the shape of a real CA bundle. def testBundlePEM : String := testCertPEM ++ testWildcardCertPEM ++ testMultiSANCertPEM @@ -69,7 +77,7 @@ def testContextCreation (certFile keyFile : String) : IO Unit := do let _clientCtx ← Context.Client.mk "" false -- Non-empty CA file with `verifyPeer := true` exercises the additive trust path: the system - -- roots plus the supplied CA (via `SSL_CTX_load_verify_locations`). + -- roots plus the supplied CA. let _clientCtx2 ← Context.Client.mk certFile true -- A non-empty CA path with `verifyPeer := false` is accepted, but the CA file is not parsed. @@ -110,6 +118,14 @@ def setupEncryptedCert : IO String := writeTempFile "enccert.pem" testEncryptedC def setupExpiredCert : IO String := writeTempFile "expired.pem" testExpiredCertPEM +def setupWeakCert : IO String := writeTempFile "weak.pem" testWeakCertPEM + +def setupCRL : IO String := writeTempFile "crl.pem" testCRLPEM + +def setupEmptyFile : IO String := writeTempFile "empty.pem" "" + +def setupDirectory : IO String := return toString (← IO.FS.createTempDir) + -- A valid leaf followed by a corrupt second certificate, i.e. a chain whose *intermediate* is bad. def setupCorruptChain : IO String := writeTempFile "chain.pem" (testCertPEM ++ testCorruptCertPEM) @@ -132,6 +148,17 @@ def assertErrorMessage (label expected : String) (act : IO Unit) : IO Unit := do unless actual == expected do throw <| IO.userError s!"{label}:\nexpected error: {expected}\nactual error: {actual}" +-- For a failure whose exact wording depends on the platform's C library or on OpenSSL's ambient +-- configuration. The set is spelled out so an unexpected *third* message still fails the test. +def assertErrorMessageOneOf (label : String) (expected : List String) (act : IO Unit) : IO Unit := do + match ← act.toBaseIO with + | .ok _ => throw <| IO.userError s!"{label}: expected failure, but it succeeded" + | .error e => + let actual := toString e + unless expected.contains actual do + throw <| IO.userError s!"{label}:\nexpected one of:\n\ + {String.intercalate "\n --- or ---\n" expected}\nactual error: {actual}" + -- A missing file reaches OpenSSL's error queue as an `ENOENT` entry, which is turned back into the -- corresponding `IO.Error` on the offending path. def missingFileError (path : String) : String := @@ -328,9 +355,9 @@ def testMkFromPEMRejectsEncryptedCert : IO Unit := do (malformedPEMError "could not read PEM CA certificates from the given string") (discard <| Context.Client.mkFromPEM testEncryptedCertPEM true) --- A CA bundle is required to contain at least one certificate. `SSL_CTX_load_verify_locations` --- reports success for a file holding only a key, which would leave the trust store silently --- unchanged, so the count is checked explicitly. +-- A CA bundle is required to contain at least one certificate. A file holding only a key parses +-- without complaint and would leave the trust store silently unchanged, so the count is checked +-- explicitly. def testMkRejectsCertlessCAFile (keyFile : String) : IO Unit := do assertErrorMessage "CA file holding only a private key" (malformedFileError keyFile "the CA file contains no certificates") @@ -354,11 +381,13 @@ def testMkFromPEMRejectsTraditionalKeyOnly : IO Unit := do (discard <| Context.Client.mkFromPEM testTraditionalKeyPEM true) /-! -`mkFromPEM` hands OpenSSL an explicit length rather than a C string, so a NUL is data and everything -after it is still parsed. Appending a NUL to a complete certificate would pass either way, so these -put material the parser must still reach *after* the NUL. +`mkFromPEM` hands OpenSSL an explicit length rather than a C string, so a NUL does not truncate the +input. It is still junk to the PEM parser, which needs `-----BEGIN` to start a line, so where the +NUL sits decides between three outcomes. Appending a NUL to a complete certificate would pass either +way, so these put material the parser must still reach *after* the NUL. -/ +-- Terminated by a newline the NUL is skipped like any other junk line. def testMkFromPEMReadsPastNul : IO Unit := do let _clientCtx ← Context.Client.mkFromPEM ("\x00\n" ++ testCertPEM) true @@ -367,6 +396,40 @@ def testMkFromPEMParsesPastNul : IO Unit := do (malformedPEMError "could not read PEM CA certificates from the given string") (discard <| Context.Client.mkFromPEM (testCertPEM ++ "\x00\n" ++ testCorruptCertPEM) true) +-- Sharing a line with the marker, the NUL hides it and that certificate is dropped without an error +-- of its own; only the empty bundle behind it is reported. +def testMkFromPEMDropsCertBehindNul : IO Unit := do + assertErrorMessage "certificate behind an unterminated NUL" + (malformedPEMError "the given CA PEM string contains no certificates") + (discard <| Context.Client.mkFromPEM ("\x00" ++ testCertPEM) true) + +-- Inside the body the NUL corrupts the block, which discards the whole bundle rather than just that +-- certificate. +def testMkFromPEMRejectsNulInsideCert : IO Unit := do + let split := 200 + assertErrorMessage "NUL inside a certificate body" + (malformedPEMError "could not read PEM CA certificates from the given string") + (discard <| Context.Client.mkFromPEM + ((testCertPEM.take split).toString ++ "\x00" ++ (testCertPEM.drop split).toString) true) + +-- Inside the marker's type name the line still opens a block, but the name no longer matches the one +-- on the `-----END` line, so the whole string is rejected instead of that certificate being skipped. +-- This is the boundary against `testMkFromPEMDropsCertBehindNul`, where the NUL lands in the fixed +-- `-----BEGIN ` prefix instead and stops the line opening a block at all. +def testMkFromPEMRejectsNulInMarkerName : IO Unit := do + assertErrorMessage "NUL inside a PEM marker's type name" + (malformedPEMError "could not read PEM CA certificates from the given string") + (discard <| Context.Client.mkFromPEM + (testCertPEM.replace "-----BEGIN CERTIFICATE-----" "-----BEGIN CERTI\x00FICATE-----") true) + +-- The block is already open by the time the `-----END` line is read, so a NUL anywhere in it leaves a +-- block that can never be closed and the whole string is rejected. +def testMkFromPEMRejectsNulInEndMarker : IO Unit := do + assertErrorMessage "NUL inside the END marker" + (malformedPEMError "could not read PEM CA certificates from the given string") + (discard <| Context.Client.mkFromPEM + (testCertPEM.replace "-----END CERTIFICATE-----" "-----END CERTI\x00FICATE-----") true) + -- The whole chain is loaded, not just the leaf, so a corrupt certificate in a later position is -- still rejected. This is the observable difference between `SSL_CTX_use_certificate_chain_file` -- and `SSL_CTX_use_certificate_file`. @@ -381,12 +444,118 @@ def testAcceptsExpiredCert (expiredFile keyFile : String) : IO Unit := do let _serverCtx ← Context.Server.mk expiredFile keyFile let _clientCtx ← Context.Client.mkFromPEM testExpiredCertPEM true +/-! +A certificate can be refused on policy grounds rather than because it could not be read: the TLS +security level turns away an RSA key that is too short. Reporting that as unparsable PEM sends the +reader after a problem their file does not have. The key is 512 bits so that every level a build may +default to rejects it — OpenSSL defaults to level 2 only since 3.2, and level 1 still admits 1024. + +The level is not ours to fix, though: a context inherits it from the ambient `openssl.cnf`, and a build +configured `DEFAULT@SECLEVEL=0` admits the certificate outright. `weakCertFile` is therefore paired with +an unrelated key, so the load fails either way and the two failures can be told apart. +-/ + +def testMkServerRejectsWeakCert (weakCertFile keyFile : String) : IO Unit := do + assertErrorMessageOneOf "512-bit server certificate" + [ malformedFileError weakCertFile + "the certificate is rejected by the TLS security level (key too small or signature digest too weak)", + malformedFileError keyFile "the private key does not match the certificate" ] + (discard <| Context.Server.mk weakCertFile keyFile) + +-- The security level governs the certificate a server presents, not the anchors a client trusts, so +-- the very file rejected above still loads as a CA. This is what pins the diagnosis to the security +-- level rather than to the certificate being malformed. +def testAcceptsWeakCertAsCA (weakCertFile : String) : IO Unit := do + let _clientCtx ← Context.Client.mkFromPEM testWeakCertPEM true + let _clientCtx2 ← Context.Client.mk weakCertFile true + +/-! +A bundle entry that is not a certificate is skipped, and a bundle of nothing but such entries is +rejected for holding no certificates. `tradkey.pem` covers the private-key form; a CRL is the other +one, and the only one the "a lone CRL" case in the loader is actually about. +-/ + +def testMkRejectsCRLOnlyCAFile (crlFile : String) : IO Unit := do + assertErrorMessage "CA file holding only a CRL" + (malformedFileError crlFile "the CA file contains no certificates") + (discard <| Context.Client.mk crlFile true) + +def testMkFromPEMRejectsCRLOnly : IO Unit := do + assertErrorMessage "CA string holding only a CRL" + (malformedPEMError "the given CA PEM string contains no certificates") + (discard <| Context.Client.mkFromPEM testCRLPEM true) + +def testMkFromPEMSkipsCRL : IO Unit := do + let _clientCtx ← Context.Client.mkFromPEM (testCRLPEM ++ testCertPEM) true + let _clientCtx2 ← Context.Client.mkFromPEM (testCertPEM ++ testCRLPEM) true + +-- A zero-byte file has no PEM armour to fail on, so it parses to an empty bundle and is reported as +-- holding no certificates rather than as unreadable. +def testMkRejectsEmptyCAFile (emptyFile : String) : IO Unit := do + assertErrorMessage "zero-byte CA file" + (malformedFileError emptyFile "the CA file contains no certificates") + (discard <| Context.Client.mk emptyFile true) + +-- Only the *CA* path treats "" as "use the platform anchors". The server has no such fallback, so an +-- empty path reaches the OS and fails there. +def testMkServerRejectsEmptyPaths (certFile keyFile : String) : IO Unit := do + assertErrorMessage "empty server cert path" + (missingFileError "") + (discard <| Context.Server.mk "" keyFile) + + assertErrorMessage "empty server key path" + (missingFileError "") + (discard <| Context.Server.mk certFile "") + /-! The path is reported with the failure whenever the `IO.Error` constructor has room for it. These also pin the errno itself, which is what would catch a platform decoding an OS error code through the wrong table. -/ +-- Anything that is not a regular file is classified from its mode rather than by opening it, because +-- opening is not a reliable test: POSIX `fopen` succeeds on a directory and fails only at the first +-- read, and a FIFO blocks until a writer appears. The note is *appended* to the failure OpenSSL +-- actually reported rather than replacing it, because the file type need not be what went wrong — +-- OpenSSL reads a FIFO or a `/dev/fd` entry as happily as a file on disk, so a mismatched key reached +-- through one still has to say so. +def testRejectsDirectoryPaths (dir certFile keyFile : String) : IO Unit := do + let note := " (the path is not a regular file)" + + assertErrorMessage "directory as server cert" + (malformedFileError dir ("could not read a PEM certificate chain" ++ note)) + (discard <| Context.Server.mk dir keyFile) + + assertErrorMessage "directory as server key" + (malformedFileError dir ("could not read an unencrypted PEM private key" ++ note)) + (discard <| Context.Server.mk certFile dir) + + -- Which failure this is depends on the C library. On POSIX `BIO_new_file` opens the directory and + -- the read that follows yields nothing, so the empty bundle is what gets reported; the Windows CRT + -- cannot open a directory as a stream at all, so the BIO is null and the path is unreadable instead. + -- Either way the note has to be appended rather than substituted, or which of the two it was is lost. + assertErrorMessageOneOf "directory as CA file" + [ malformedFileError dir ("the CA file contains no certificates" ++ note), + malformedFileError dir ("could not read PEM CA certificates" ++ note) ] + (discard <| Context.Client.mk dir true) + +-- A character device is the readable non-regular file: OpenSSL opens `/dev/null` and reads it to +-- completion, so the diagnosis is about what the empty read produced and the file type is only a +-- footnote. +def testAppendsNoteToReadableNonRegularFile (certFile : String) : IO Unit := do + if System.Platform.isWindows then + return + + assertErrorMessage "character device as CA file" + (malformedFileError "/dev/null" + "the CA file contains no certificates (the path is not a regular file)") + (discard <| Context.Client.mk "/dev/null" true) + + assertErrorMessage "character device as server key" + (malformedFileError "/dev/null" + "could not read an unencrypted PEM private key (the path is not a regular file)") + (discard <| Context.Server.mk certFile "/dev/null") + -- Skipped when the permission bits do not bite, which is the case for a privileged user. def testMkRejectsUnreadableCAFile (unreadableFile : String) : IO Unit := do if (← (IO.FS.readFile unreadableFile).toBaseIO).isOk then @@ -484,10 +653,14 @@ def testMkRejectsNonDirectoryParent (notADirPath : String) : IO Unit := do testMkFromPEMSkipsTraditionalKey testMkFromPEMRejectsTraditionalKeyOnly --- NUL is data, not a terminator. +-- NUL is data, not a terminator, but it is not invisible either. #eval do testMkFromPEMReadsPastNul testMkFromPEMParsesPastNul + testMkFromPEMDropsCertBehindNul + testMkFromPEMRejectsNulInsideCert + testMkFromPEMRejectsNulInMarkerName + testMkFromPEMRejectsNulInEndMarker #eval do let (certFile, keyFile) ← setupTestCerts @@ -496,7 +669,29 @@ def testMkRejectsNonDirectoryParent (notADirPath : String) : IO Unit := do testAcceptsExpiredCert (← setupExpiredCert) keyFile testMkClientFromPEM certFile +-- Rejected on policy, not for being unreadable. +#eval do + let (_, keyFile) ← setupTestCerts + let weakCertFile ← setupWeakCert + + testMkServerRejectsWeakCert weakCertFile keyFile + testAcceptsWeakCertAsCA weakCertFile + +-- A bundle must hold a certificate, and a CRL is not one. +#eval do + let crlFile ← setupCRL + + testMkRejectsCRLOnlyCAFile crlFile + testMkFromPEMRejectsCRLOnly + testMkFromPEMSkipsCRL + testMkRejectsEmptyCAFile (← setupEmptyFile) + -- OS-level failures keep the path and the real errno. #eval do + let (certFile, keyFile) ← setupTestCerts + testMkRejectsUnreadableCAFile (← setupUnreadableFile) testMkRejectsNonDirectoryParent (← setupNonDirectoryParent) + testMkServerRejectsEmptyPaths certFile keyFile + testRejectsDirectoryPaths (← setupDirectory) certFile keyFile + testAppendsNoteToReadableNonRegularFile certFile diff --git a/weak512.pem b/weak512.pem new file mode 100644 index 000000000000..ec2981995eb9 --- /dev/null +++ b/weak512.pem @@ -0,0 +1,11 @@ +-----BEGIN CERTIFICATE----- +MIIBfzCCASmgAwIBAgIUflcn2SjTlAgcKZCiuMkPMeKJoRUwDQYJKoZIhvcNAQEL +BQAwFDESMBAGA1UEAwwJbG9jYWxob3N0MB4XDTI2MDgxODE0MjMzMloXDTI3MDgx +ODE0MjMzMlowFDESMBAGA1UEAwwJbG9jYWxob3N0MFwwDQYJKoZIhvcNAQEBBQAD +SwAwSAJBAM1klSQp5sg3QW9FIFYc1et138wboIQ+xaD7VQA4v9kHsQlMFdAQBqpr ++GE9zb0oyLfkd3zuZdLfw87Ix00kQ0UCAwEAAaNTMFEwHQYDVR0OBBYEFGlJ9XJJ +Da5Yf6KOQ5stS2wtnjzRMB8GA1UdIwQYMBaAFGlJ9XJJDa5Yf6KOQ5stS2wtnjzR +MA8GA1UdEwEB/wQFMAMBAf8wDQYJKoZIhvcNAQELBQADQQAi/3ckqFqw//pvAPEK +4GnmRJYblA1kgJifMM0NOysi71UEwfnnnQG2e9dKIYLZzxh/FMi4v5/8OS+NK/OX +LVaJ +-----END CERTIFICATE----- From 15938070cdbd535a7e22774e82ac1d2724f8083c Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Tue, 18 Aug 2026 21:43:44 -0300 Subject: [PATCH 29/36] fix: remove dot --- src/runtime/openssl/context.cpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 9f392fbe0477..8daea283cd07 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -173,7 +173,7 @@ static ssl_ctx_ptr mk_ssl_ctx_base(const SSL_METHOD * method, lean_obj_res * err } configure_ctx_options(ctx.get()); -. + if (SSL_CTX_set_min_proto_version(ctx.get(), TLS1_2_VERSION) != 1) { *err = mk_openssl_io_error("SSL_CTX_set_min_proto_version failed"); return nullptr; From 7f2ca157a9702326a6155083c304f6933357a820 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Thu, 20 Aug 2026 17:35:36 -0300 Subject: [PATCH 30/36] fix: change call_once --- src/runtime/openssl.cpp | 20 +++++++------------- 1 file changed, 7 insertions(+), 13 deletions(-) diff --git a/src/runtime/openssl.cpp b/src/runtime/openssl.cpp index 1046deaa0892..b28e697bfbbd 100644 --- a/src/runtime/openssl.cpp +++ b/src/runtime/openssl.cpp @@ -10,7 +10,6 @@ Author: Sofia Rodrigues #include #include #include -#include namespace lean { @@ -20,18 +19,13 @@ void initialize_openssl() { void finalize_openssl() {} bool ensure_openssl_initialized() { - static bool ok = false; - static std::once_flag once; - - std::call_once(once, []() { - // `OPENSSL_INIT_NO_ATEXIT` is the load-bearing flag. By default OpenSSL registers - // `atexit(OPENSSL_cleanup)`, which tears down global state — among it the ENGINE lock that - // `SSL_CTX_new` reads — while other threads may still be inside OpenSSL, dereferencing the - // freed lock. Lean hands work to a thread pool that can outlive `main`, so that handler - // must not be installed. Nothing then frees OpenSSL's globals, which is intended: they stay - // reachable from static storage for the life of the process. - ok = OPENSSL_init_ssl(OPENSSL_INIT_NO_ATEXIT, nullptr) == 1; - }); + // `OPENSSL_INIT_NO_ATEXIT` is the load-bearing flag. By default OpenSSL registers + // `atexit(OPENSSL_cleanup)`, which tears down global state — among it the ENGINE lock that + // `SSL_CTX_new` reads — while other threads may still be inside OpenSSL, dereferencing the + // freed lock. Lean hands work to a thread pool that can outlive `main`, so that handler + // must not be installed. Nothing then frees OpenSSL's globals, which is intended: they stay + // reachable from static storage for the life of the process. + static const bool ok = OPENSSL_init_ssl(OPENSSL_INIT_NO_ATEXIT, nullptr) == 1; return ok; } From acab1608d87cdd6ba113b653dfa6f149fe560430 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Thu, 20 Aug 2026 18:38:37 -0300 Subject: [PATCH 31/36] fix: remove unexistent import --- src/Std/Internal.lean | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Std/Internal.lean b/src/Std/Internal.lean index af7c8b5fc6a5..24a16ec42e9a 100644 --- a/src/Std/Internal.lean +++ b/src/Std/Internal.lean @@ -11,7 +11,6 @@ public import Std.Http public import Std.Internal.ForIn public import Std.Internal.Parsec public import Std.Internal.UV -public import Std.Internal.Do public import Std.Internal.SSL @[expose] public section From 6829a53d229805bd3e769e18522146a1354e5343 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Sun, 23 Aug 2026 10:15:51 -0300 Subject: [PATCH 32/36] fix: move keychain anchor globals into the Apple branch Co-Authored-By: Claude Opus 5 (1M context) --- src/runtime/openssl/trust_store.cpp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/runtime/openssl/trust_store.cpp b/src/runtime/openssl/trust_store.cpp index ac580672e8df..76fbe0b26349 100644 --- a/src/runtime/openssl/trust_store.cpp +++ b/src/runtime/openssl/trust_store.cpp @@ -26,10 +26,6 @@ Author: Sofia Rodrigues namespace lean { -// Every anchor the Keychain offers for TLS, or null if even the empty list could not be built. -static STACK_OF(X509) * g_keychain_anchors = nullptr; -static std::once_flag g_keychain_anchors_once; - #if defined(__APPLE__) || defined(LEAN_WINDOWS) // A variable set to the empty string names no path, so it is reported as unset. OpenSSL's own check is @@ -72,6 +68,10 @@ static bool trust_store_has_no_certs(X509_STORE * store) { #if defined(__APPLE__) +// Every anchor the Keychain offers for TLS, or null if even the empty list could not be built. +static STACK_OF(X509) * g_keychain_anchors = nullptr; +static std::once_flag g_keychain_anchors_once; + static bool cf_is(CFTypeRef value, CFTypeID type) { return value != nullptr && CFGetTypeID(value) == type; } From 076f69402ebaef2d5eedfc66fd7689922e184cdc Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Mon, 31 Aug 2026 18:08:12 -0300 Subject: [PATCH 33/36] fix: remove stray test --- weak512.pem | 11 ----------- 1 file changed, 11 deletions(-) delete mode 100644 weak512.pem diff --git a/weak512.pem b/weak512.pem deleted file mode 100644 index ec2981995eb9..000000000000 --- a/weak512.pem +++ /dev/null @@ -1,11 +0,0 @@ ------BEGIN CERTIFICATE----- -MIIBfzCCASmgAwIBAgIUflcn2SjTlAgcKZCiuMkPMeKJoRUwDQYJKoZIhvcNAQEL -BQAwFDESMBAGA1UEAwwJbG9jYWxob3N0MB4XDTI2MDgxODE0MjMzMloXDTI3MDgx -ODE0MjMzMlowFDESMBAGA1UEAwwJbG9jYWxob3N0MFwwDQYJKoZIhvcNAQEBBQAD -SwAwSAJBAM1klSQp5sg3QW9FIFYc1et138wboIQ+xaD7VQA4v9kHsQlMFdAQBqpr -+GE9zb0oyLfkd3zuZdLfw87Ix00kQ0UCAwEAAaNTMFEwHQYDVR0OBBYEFGlJ9XJJ -Da5Yf6KOQ5stS2wtnjzRMB8GA1UdIwQYMBaAFGlJ9XJJDa5Yf6KOQ5stS2wtnjzR -MA8GA1UdEwEB/wQFMAMBAf8wDQYJKoZIhvcNAQELBQADQQAi/3ckqFqw//pvAPEK -4GnmRJYblA1kgJifMM0NOysi71UEwfnnnQG2e9dKIYLZzxh/FMi4v5/8OS+NK/OX -LVaJ ------END CERTIFICATE----- From 51ec8eeca7b26ae6a59f1ad2a92a9500988a9182 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Mon, 31 Aug 2026 18:28:13 -0300 Subject: [PATCH 34/36] fix: trust system roots while loading ca --- src/Std/Internal/SSL/Context.lean | 52 +++++++++++++++++---------- src/runtime/openssl/context.cpp | 55 +++++++++++++++++++---------- src/runtime/openssl/context.h | 4 +-- tests/elab/async_ssl_context.lean | 58 +++++++++++++++++++++++++++++++ 4 files changed, 130 insertions(+), 39 deletions(-) diff --git a/src/Std/Internal/SSL/Context.lean b/src/Std/Internal/SSL/Context.lean index d3786c096f6e..0c95ba4e95ae 100644 --- a/src/Std/Internal/SSL/Context.lean +++ b/src/Std/Internal/SSL/Context.lean @@ -73,19 +73,26 @@ takes `caFile` explicitly and the public wrapper below carries the default. Only carrying the default is affected, which is why `mkFromPEM` needs no such wrapper. -/ @[extern "lean_ssl_ctx_mk_client"] -private opaque mkImpl (caFile : @& String) (verifyPeer : Bool) : IO Context.Client +private opaque mkImpl (caFile : @& String) (verifyPeer : Bool) (trustSystemRoots : Bool) : + IO Context.Client /-- Creates a client-side TLS context, reading CA trust anchors from a PEM bundle file. Trust-anchor semantics: -- With `verifyPeer := true` (the default) the client trusts the platform default trust anchors (the - system root store) and verifies the peer certificate, so connections to public HTTPS servers work - out of the box. A non-empty `caFile` is trusted *in addition* to those system anchors, so public - servers keep working while a private CA also becomes trusted. That CA has to be self-signed: a - chain is only accepted once it reaches a self-signed certificate, so trusting an intermediate - alone loads without complaint and then fails every handshake. There is no way to trust `caFile` - alone, so this cannot be used to pin against a single CA. +- With `verifyPeer := true` (the default) the client verifies the peer certificate against the + anchors selected below. +- With `trustSystemRoots := true` (the default) the platform default trust anchors (the system root + store) are trusted, so connections to public HTTPS servers work out of the box. A non-empty + `caFile` is then trusted *in addition* to those system anchors, so public servers keep working + while a private CA also becomes trusted. +- With `trustSystemRoots := false` only `caFile` is trusted, which is how to pin against a specific + CA: a certificate issued by any other authority, public roots included, is rejected. `caFile` must + then name at least one certificate, since a verifying context with no anchor at all could never + complete a handshake; that combination is refused here rather than at connection time. +- A trusted CA has to be self-signed: a chain is only accepted once it reaches a self-signed + certificate, so trusting an intermediate alone loads without complaint and then fails every + handshake. - An empty `caFile` with `verifyPeer := true` uses just the platform default trust anchors. Which anchors those are is platform-specific: the Keychain on macOS, the `ROOT` store on Windows, OpenSSL's configured paths elsewhere. `SSL_CERT_FILE` and `SSL_CERT_DIR` are honoured on every @@ -98,9 +105,11 @@ Trust-anchor semantics: anchor cannot carry that restriction. OpenSSL's own bundle is not merged on top of the Keychain, as it would reinstate the roots those settings turned away; it is read only when the Keychain yields no anchor at all. `SSL_CERT_FILE` and `SSL_CERT_DIR` name locations of their own, which are - read in addition to the Keychain and do not drag OpenSSL's bundle in with them. -- `verifyPeer := false` disables peer verification entirely and the CA file is not parsed. This - cannot be undone: a context built this way can never be made to verify. + read in addition to the Keychain and do not drag OpenSSL's bundle in with them. All of this is + skipped entirely when `trustSystemRoots := false`, environment variables included. +- `verifyPeer := false` disables peer verification entirely; neither the CA file nor the system + anchors are consulted, and `trustSystemRoots` is therefore ignored. This cannot be undone: a + context built this way can never be made to verify. `caFile` must be a path without embedded NUL bytes, which is checked before `verifyPeer` is consulted. Where the file is read, private key and CRL entries are ignored — no revocation checking @@ -109,20 +118,24 @@ is performed — and a file yielding no certificate at all is rejected. Verifying the peer proves the certificate chains to a trusted anchor; it does **not** prove the certificate belongs to the host being connected to. Binding a hostname is the session layer's job. -/ -@[inline] def mk (caFile : String := "") (verifyPeer : Bool := true) : IO Context.Client := - mkImpl caFile verifyPeer +@[inline] def mk (caFile : String := "") (verifyPeer : Bool := true) + (trustSystemRoots : Bool := true) : IO Context.Client := + mkImpl caFile verifyPeer trustSystemRoots /-- Creates a client-side TLS context with CA trust anchors from an in-memory PEM string instead of a file path. Accepts one or more PEM-encoded certificates (same format as a CA bundle file); private key and CRL entries are ignored, and a string yielding no certificates at all is rejected. -Trust-anchor semantics match `mk`, including that the platform anchors cannot be excluded and that -hostname verification is left to the session layer: -- With `verifyPeer := true` the client always trusts the platform default trust anchors; a non-empty - `caPEM` is trusted *in addition* to them. +Trust-anchor semantics match `mk`, hostname verification included — that is the session layer's job: +- With `verifyPeer := true` and `trustSystemRoots := true` (both the default) the client trusts the + platform default trust anchors, and a non-empty `caPEM` is trusted *in addition* to them. +- With `trustSystemRoots := false` only `caPEM` is trusted, which is how to pin against a specific + CA. It must then yield at least one certificate; an empty `caPEM` is refused, since the context + would have no anchor to verify against. - An empty `caPEM` with `verifyPeer := true` uses just the platform default trust anchors. -- `verifyPeer := false` disables peer verification entirely (the PEM is not parsed). +- `verifyPeer := false` disables peer verification entirely (the PEM is not parsed, and + `trustSystemRoots` is ignored). Unlike `mk`, which takes a path and so rejects embedded NUL bytes, this reads `caPEM` as bytes with an explicit length, so a NUL does not truncate it. It is still an ordinary junk byte to the PEM @@ -135,7 +148,8 @@ rejects the whole string, valid certificates alongside it included. Outside any Use this when the CA certificate is embedded in the binary rather than on disk. -/ @[extern "lean_ssl_ctx_mk_client_from_pem"] -opaque mkFromPEM (caPEM : @& String) (verifyPeer : Bool := true) : IO Context.Client +opaque mkFromPEM (caPEM : @& String) (verifyPeer : Bool := true) + (trustSystemRoots : Bool := true) : IO Context.Client end Client end Context diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 8daea283cd07..9dd0886e6089 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -237,8 +237,18 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, } // Shared skeleton of the client constructors; `load_ca` returns nullptr or an IO error to propagate. +// `has_ca` says whether the caller supplied CA material at all, which decides whether dropping the +// platform anchors would leave nothing behind. `load_ca` is what enforces that supplied material +// actually yields a certificate, so the two together guarantee a verifying context has an anchor. template -static lean_obj_res mk_client_ctx(uint8_t verify_peer, LoadCA load_ca) { +static lean_obj_res mk_client_ctx(uint8_t verify_peer, uint8_t trust_system_roots, bool has_ca, + LoadCA load_ca) { + if (verify_peer && !trust_system_roots && !has_ca) { + return mk_ssl_invalid_argument( + "no trust anchors: peer verification is on, the platform trust anchors are excluded, " + "and no CA certificate was given"); + } + lean_obj_res err = nullptr; ssl_ctx_ptr ctx = mk_ssl_ctx_base(TLS_client_method(), &err); if (ctx == nullptr) return err; @@ -249,16 +259,19 @@ static lean_obj_res mk_client_ctx(uint8_t verify_peer, LoadCA load_ca) { return wrap_ssl_context(std::move(ctx)); } - std::string detail; + if (trust_system_roots) { + std::string detail; - if (!load_system_trust_store(ctx.get(), &detail)) { - std::string msg("failed to load system trust store"); - if (!detail.empty()) msg += ": " + detail; + if (!load_system_trust_store(ctx.get(), &detail)) { + std::string msg("failed to load system trust store"); + if (!detail.empty()) msg += ": " + detail; - return lean_io_result_mk_error(mk_openssl_error(msg.c_str())); + return lean_io_result_mk_error(mk_openssl_error(msg.c_str())); + } } - // The caller's own CAs are added on top of the platform anchors, not in place of them. + // The caller's own CAs are added to whatever the store already holds: on top of the platform + // anchors, or into an otherwise empty store when those were excluded. if (lean_obj_res ca_err = load_ca(ctx.get())) return ca_err; SSL_CTX_set_verify(ctx.get(), SSL_VERIFY_PEER, nullptr); @@ -300,13 +313,15 @@ static lean_obj_res load_ca_bundle(SSL_CTX * ctx, BIO * bio, char const * unread return nullptr; } -/* Std.Internal.SSL.Context.Client.mkImpl (caFile : @& String) (verifyPeer : Bool) : IO Context.Client */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, uint8_t verify_peer) { +/* Std.Internal.SSL.Context.Client.mkImpl (caFile : @& String) (verifyPeer trustSystemRoots : Bool) : IO Context.Client */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, uint8_t verify_peer, + uint8_t trust_system_roots) { if (lean_obj_res err = reject_embedded_nul(ca_file)) return err; - return mk_client_ctx(verify_peer, [&](SSL_CTX * ctx) -> lean_obj_res { - const char * ca = lean_string_cstr(ca_file); + const char * ca = lean_string_cstr(ca_file); + return mk_client_ctx(verify_peer, trust_system_roots, ca[0] != '\0', + [&](SSL_CTX * ctx) -> lean_obj_res { // An empty CA path leaves the client with just the system trust anchors. if (ca[0] == '\0') return nullptr; @@ -316,12 +331,14 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, ui }); } -/* Std.Internal.SSL.Context.Client.mkFromPEM (caPEM : @& String) (verifyPeer : Bool) : IO Context.Client */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca_pem, uint8_t verify_peer) { - return mk_client_ctx(verify_peer, [&](SSL_CTX * ctx) -> lean_obj_res { - const char * pem = lean_string_cstr(ca_pem); - size_t pem_size = lean_string_size(ca_pem) - 1; +/* Std.Internal.SSL.Context.Client.mkFromPEM (caPEM : @& String) (verifyPeer trustSystemRoots : Bool) : IO Context.Client */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca_pem, uint8_t verify_peer, + uint8_t trust_system_roots) { + const char * pem = lean_string_cstr(ca_pem); + size_t pem_size = lean_string_size(ca_pem) - 1; + return mk_client_ctx(verify_peer, trust_system_roots, pem_size != 0, + [&](SSL_CTX * ctx) -> lean_obj_res { if (pem_size == 0) return nullptr; if (pem_size > INT_MAX) return mk_ssl_invalid_argument("the CA PEM string is too large"); @@ -340,11 +357,13 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg /*cert_file lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); } -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg /*ca_file*/, uint8_t /*verify_peer*/) { +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg /*ca_file*/, + uint8_t /*verify_peer*/, uint8_t /*trust_system_roots*/) { lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); } -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg /*ca_pem*/, uint8_t /*verify_peer*/) { +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg /*ca_pem*/, + uint8_t /*verify_peer*/, uint8_t /*trust_system_roots*/) { lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); } diff --git a/src/runtime/openssl/context.h b/src/runtime/openssl/context.h index 81f1fba3d0a9..af35a1bf19ed 100644 --- a/src/runtime/openssl/context.h +++ b/src/runtime/openssl/context.h @@ -32,7 +32,7 @@ inline SSL_CTX * lean_to_ssl_context(lean_object * o) { return (SSL_CTX*)lean_ge // Context Operations extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, b_obj_arg key_file); -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, uint8_t verify_peer); -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca_pem, uint8_t verify_peer); +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, uint8_t verify_peer, uint8_t trust_system_roots); +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca_pem, uint8_t verify_peer, uint8_t trust_system_roots); } diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index f24d91a78d16..4c2a89dca9fa 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -181,6 +181,54 @@ def malformedPEMError (detail : String) : String := def testMkFromPEMEmptyFallsBack : IO Unit := do let _clientCtx ← Context.Client.mkFromPEM "" true +/-! +`trustSystemRoots := false` narrows the store to the supplied CA, which is what pinning against a +private authority needs. The store a context starts with is empty, so excluding the platform anchors +without naming a CA would leave nothing to verify against — a context that could never complete a +handshake. That is refused at construction instead of at connection time. +-/ + +def noAnchorsError : String := + malformedPEMError "no trust anchors: peer verification is on, the platform trust anchors are \ + excluded, and no CA certificate was given" + +def testPinnedToSuppliedCA (certFile : String) : IO Unit := do + let _clientCtx ← Context.Client.mk certFile true false + let _clientCtx2 ← Context.Client.mkFromPEM testCertPEM true false + let _clientCtx3 ← Context.Client.mkFromPEM testBundlePEM true false + +def testPinningRejectsEmptyCA : IO Unit := do + assertErrorMessage "pinned with no CA path" noAnchorsError + (discard <| Context.Client.mk "" true false) + + assertErrorMessage "pinned with no CA PEM" noAnchorsError + (discard <| Context.Client.mkFromPEM "" true false) + +-- With verification off there is no store to be empty, so excluding the platform anchors is not a +-- contradiction and `trustSystemRoots` is simply ignored. +def testPinningIgnoredWithoutVerification : IO Unit := do + let _clientCtx ← Context.Client.mk "" false false + let _clientCtx2 ← Context.Client.mkFromPEM "" false false + +-- Supplied CA material still has to yield a certificate. These reach the ordinary bundle-loading +-- failures rather than the "no trust anchors" one, which is what pins the check to the *absence* of +-- CA material rather than to it being unusable. +def testPinningStillValidatesCA (junkFile : String) : IO Unit := do + assertErrorMessage "pinned to a malformed CA file" + (malformedFileError junkFile "the CA file contains no certificates") + (discard <| Context.Client.mk junkFile true false) + + assertErrorMessage "pinned to a CA string with no certificates" + (malformedPEMError "the given CA PEM string contains no certificates") + (discard <| Context.Client.mkFromPEM "not a certificate at all" true false) + +-- An unusable path is still rejected as a path, before the anchor bookkeeping is consulted. +def testPinningRejectsNulInCAFile : IO Unit := do + let caPath := "ca\x00.pem" + + assertErrorMessage "NUL byte in a pinned CA path" (nulByteError caPath) + (discard <| Context.Client.mk caPath true false) + -- `verifyPeer := false` succeeds without parsing the CA material, even for a real bundle. def testMkFromPEMNoVerify (certFile : String) : IO Unit := do let caPEM ← IO.FS.readFile certFile @@ -580,6 +628,16 @@ def testMkRejectsNonDirectoryParent (notADirPath : String) : IO Unit := do #eval testMkFromPEMEmptyFallsBack +-- Pinning: the supplied CA replaces the platform anchors rather than joining them. +#eval do + let (certFile, _) ← setupTestCerts + + testPinnedToSuppliedCA certFile + testPinningRejectsEmptyCA + testPinningIgnoredWithoutVerification + testPinningStillValidatesCA (← setupMalformedFile) + testPinningRejectsNulInCAFile + #eval do let (certFile, _) ← setupTestCerts testMkFromPEMNoVerify certFile From 2e839672aaf849f7a69139a3a1ac5cb0ca76605c Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Mon, 31 Aug 2026 19:06:15 -0300 Subject: [PATCH 35/36] fix: load certificate from path or text --- src/Std/Internal/SSL/Context.lean | 188 +++++++++++--------- src/runtime/openssl/context.cpp | 279 +++++++++++++++++++----------- src/runtime/openssl/context.h | 7 +- tests/elab/async_ssl_context.lean | 259 +++++++++++++++++---------- 4 files changed, 463 insertions(+), 270 deletions(-) diff --git a/src/Std/Internal/SSL/Context.lean b/src/Std/Internal/SSL/Context.lean index 0c95ba4e95ae..3188ceec53e7 100644 --- a/src/Std/Internal/SSL/Context.lean +++ b/src/Std/Internal/SSL/Context.lean @@ -25,13 +25,44 @@ The certificate, key and CA material passed to these constructors is refused out encrypted, rather than prompted for, so no constructor can block on a terminal asking for a passphrase. Material reached through `SSL_CERT_FILE` or `SSL_CERT_DIR` is read by OpenSSL with an empty passphrase instead: it cannot prompt either, but an encrypted block whose passphrase happens -to be empty is decrypted and trusted there, where the same bytes in `caFile` would be rejected. +to be empty is decrypted and trusted there, where the same bytes in a `PEM.file` would be rejected. -/ public section namespace Std.Internal.SSL +/-- +PEM-encoded material, named either by the path of a file holding it or by its bytes directly. + +The two differ in how a NUL byte is treated. A path is passed to the OS as a C string, so an +embedded NUL is rejected outright; `PEM.text` is read with an explicit length, so a NUL is ordinary +input the PEM parser then has to make sense of. +-/ +inductive PEM where + + /-- + Read the PEM from the file at `path`. + -/ + | file (path : String) + + /-- + Take `contents` as the PEM bytes themselves. + -/ + | text (contents : String) + +namespace PEM + +@[inline] private def bytes : PEM → String + | .file path => path + | .text contents => contents + +@[inline] private def isFile : PEM → Bool + | .file _ => true + | .text _ => false + +end PEM + private opaque ContextServerImpl : NonemptyType.{0} /-- @@ -53,103 +84,98 @@ instance : Nonempty Context.Client := ContextClientImpl.property namespace Context.Server /-- -Creates a server-side TLS context, loading the PEM certificate chain and private key from the given -files. The server presents its certificate but does not authenticate the client (no mutual TLS). - -`certFile` holds the leaf certificate followed by any intermediates; the whole chain is sent so -clients can build a path to a trusted root. `keyFile` must be an unencrypted key matching that leaf. +The credentials a server presents. Both fields are required: a server that cannot prove who it is +has nothing to offer a client. -/ +structure Config where + /-- + The leaf certificate followed by any intermediates. The whole chain is sent, so clients can build + a path to a trusted root. + -/ + cert : PEM + /-- An unencrypted private key matching the leaf in `cert`. -/ + key : PEM + @[extern "lean_ssl_ctx_mk_server"] -opaque mk (certFile : @& String) (keyFile : @& String) : IO Context.Server +private opaque mkImpl (cert : @& String) (certIsFile : Bool) (key : @& String) (keyIsFile : Bool) : + IO Context.Server + +/-- +Creates a server-side TLS context from the given certificate chain and private key. The server +presents its certificate but does not authenticate the client (no mutual TLS). + +The certificate is parsed but not validated against the clock: an expired certificate loads here and +is rejected by the peer at handshake time. A key that does not match the leaf certificate is +rejected, as is an encrypted key — decrypting one would mean asking for a passphrase. +-/ +def mk (cfg : Config) : IO Context.Server := + mkImpl cfg.cert.bytes cfg.cert.isFile cfg.key.bytes cfg.key.isFile end Server namespace Client -/- -A default value on a borrowed parameter wraps its type in `optParam`, which hides the `@&` marker -from the compiler: that parameter is then treated as owned and every argument leaks. So the extern -takes `caFile` explicitly and the public wrapper below carries the default. Only the parameter -carrying the default is affected, which is why `mkFromPEM` needs no such wrapper. --/ -@[extern "lean_ssl_ctx_mk_client"] -private opaque mkImpl (caFile : @& String) (verifyPeer : Bool) (trustSystemRoots : Bool) : - IO Context.Client - /-- -Creates a client-side TLS context, reading CA trust anchors from a PEM bundle file. - -Trust-anchor semantics: -- With `verifyPeer := true` (the default) the client verifies the peer certificate against the - anchors selected below. -- With `trustSystemRoots := true` (the default) the platform default trust anchors (the system root - store) are trusted, so connections to public HTTPS servers work out of the box. A non-empty - `caFile` is then trusted *in addition* to those system anchors, so public servers keep working - while a private CA also becomes trusted. -- With `trustSystemRoots := false` only `caFile` is trusted, which is how to pin against a specific - CA: a certificate issued by any other authority, public roots included, is rejected. `caFile` must - then name at least one certificate, since a verifying context with no anchor at all could never - complete a handshake; that combination is refused here rather than at connection time. -- A trusted CA has to be self-signed: a chain is only accepted once it reaches a self-signed - certificate, so trusting an intermediate alone loads without complaint and then fails every - handshake. -- An empty `caFile` with `verifyPeer := true` uses just the platform default trust anchors. Which - anchors those are is platform-specific: the Keychain on macOS, the `ROOT` store on Windows, - OpenSSL's configured paths elsewhere. `SSL_CERT_FILE` and `SSL_CERT_DIR` are honoured on every - platform, and are consulted afresh for every context. On macOS the Keychain is read once per - process, since doing so costs around a tenth of a second, so a root added to it after the first - context is built is not picked up until the process restarts. The per-certificate trust settings - decide, so a root added locally (as `mkcert` and `security add-trusted-cert` do) is trusted and - one explicitly denied is not; a +Which anchors a client trusts, and whether it checks the peer against them at all. +-/ +structure Config where + /-- + Trust anchors supplied by the caller, trusted in addition to the platform anchors or — with + `trustSystemRoots := false` — instead of them. `none` supplies no anchors of its own. + + Private key and CRL entries in the material are ignored, so a bundle may hold them; no revocation + checking is performed. Material yielding no certificate at all is rejected. + -/ + ca : Option PEM := none + /-- + Whether to verify that the peer certificate chains to a trusted anchor. `false` disables + verification entirely, and neither `ca` nor the platform anchors are then consulted. This cannot + be undone: a context built this way can never be made to verify. + -/ + verifyPeer : Bool := true + /-- + Whether the platform default trust anchors are trusted. + + With `true`, connections to public HTTPS servers work out of the box. Which anchors those are is + platform-specific: the Keychain on macOS, the `ROOT` store on Windows, OpenSSL's configured paths + elsewhere. `SSL_CERT_FILE` and `SSL_CERT_DIR` are honoured on every platform, and are consulted + afresh for every context. On macOS the Keychain is read once per process, since doing so costs + around a tenth of a second, so a root added to it after the first context is built is not picked + up until the process restarts. The per-certificate trust settings decide, so a root added locally + (as `mkcert` and `security add-trusted-cert` do) is trusted and one explicitly denied is not; a setting that applies only to a named host, key usage, or application grants no trust, since an anchor cannot carry that restriction. OpenSSL's own bundle is not merged on top of the Keychain, as it would reinstate the roots those settings turned away; it is read only when the Keychain yields no anchor at all. `SSL_CERT_FILE` and `SSL_CERT_DIR` name locations of their own, which are - read in addition to the Keychain and do not drag OpenSSL's bundle in with them. All of this is - skipped entirely when `trustSystemRoots := false`, environment variables included. -- `verifyPeer := false` disables peer verification entirely; neither the CA file nor the system - anchors are consulted, and `trustSystemRoots` is therefore ignored. This cannot be undone: a - context built this way can never be made to verify. + read in addition to the Keychain and do not drag OpenSSL's bundle in with them. -`caFile` must be a path without embedded NUL bytes, which is checked before `verifyPeer` is -consulted. Where the file is read, private key and CRL entries are ignored — no revocation checking -is performed — and a file yielding no certificate at all is rejected. + With `false` none of that is consulted, environment variables included, and only `ca` is trusted. + -/ + trustSystemRoots : Bool := true -Verifying the peer proves the certificate chains to a trusted anchor; it does **not** prove the -certificate belongs to the host being connected to. Binding a hostname is the session layer's job. --/ -@[inline] def mk (caFile : String := "") (verifyPeer : Bool := true) - (trustSystemRoots : Bool := true) : IO Context.Client := - mkImpl caFile verifyPeer trustSystemRoots +@[extern "lean_ssl_ctx_mk_client"] +private opaque mkImpl (ca : @& String) (caIsFile : Bool) (hasCA : Bool) (verifyPeer : Bool) + (trustSystemRoots : Bool) : IO Context.Client /-- -Creates a client-side TLS context with CA trust anchors from an in-memory PEM string instead of a -file path. Accepts one or more PEM-encoded certificates (same format as a CA bundle file); private -key and CRL entries are ignored, and a string yielding no certificates at all is rejected. - -Trust-anchor semantics match `mk`, hostname verification included — that is the session layer's job: -- With `verifyPeer := true` and `trustSystemRoots := true` (both the default) the client trusts the - platform default trust anchors, and a non-empty `caPEM` is trusted *in addition* to them. -- With `trustSystemRoots := false` only `caPEM` is trusted, which is how to pin against a specific - CA. It must then yield at least one certificate; an empty `caPEM` is refused, since the context - would have no anchor to verify against. -- An empty `caPEM` with `verifyPeer := true` uses just the platform default trust anchors. -- `verifyPeer := false` disables peer verification entirely (the PEM is not parsed, and - `trustSystemRoots` is ignored). - -Unlike `mk`, which takes a path and so rejects embedded NUL bytes, this reads `caPEM` as bytes with -an explicit length, so a NUL does not truncate it. It is still an ordinary junk byte to the PEM -parser, and where it lands decides what happens. A block is recognised only when its line begins with -`-----BEGIN ` and ends with `-----`, so a NUL breaking either of those fixed parts leaves a line that -no longer opens a block and that certificate is dropped without a word. A NUL that leaves the block -open but spoils it — in the type name, in the base64 body, or anywhere in the `-----END` line — -rejects the whole string, valid certificates alongside it included. Outside any block it is harmless. - -Use this when the CA certificate is embedded in the binary rather than on disk. +Creates a client-side TLS context trusting the anchors named by `cfg`. + +Pinning against a specific CA is `{ ca := some ca, trustSystemRoots := false }`: a certificate +issued by any other authority, public roots included, is then rejected. `ca` must supply at least +one certificate in that case, since a verifying context with no anchor at all could never complete a +handshake; that combination is refused here rather than at connection time. + +A trusted CA has to be self-signed, whichever way it is supplied: a chain is only accepted once it +reaches a self-signed certificate, so trusting an intermediate alone loads without complaint and +then fails every handshake. + +Verifying the peer proves the certificate chains to a trusted anchor; it does **not** prove the +certificate belongs to the host being connected to. Binding a hostname is the session layer's job. -/ -@[extern "lean_ssl_ctx_mk_client_from_pem"] -opaque mkFromPEM (caPEM : @& String) (verifyPeer : Bool := true) - (trustSystemRoots : Bool := true) : IO Context.Client +def mk (cfg : Config := {}) : IO Context.Client := + match cfg.ca with + | none => mkImpl "" false false cfg.verifyPeer cfg.trustSystemRoots + | some ca => mkImpl ca.bytes ca.isFile true cfg.verifyPeer cfg.trustSystemRoots end Client end Context diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 9dd0886e6089..4a8cf448662f 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -36,6 +36,15 @@ static lean_obj_res reject_embedded_nul(b_obj_arg path) { : mk_embedded_nul_error(path); } +// PEM material the caller named: a path when `is_file`, otherwise the bytes themselves. +struct pem_source { + b_obj_arg obj; + bool is_file; + + char const * data() const { return lean_string_cstr(obj); } + size_t size() const { return lean_string_size(obj) - 1; } +}; + // Reports a failure against a path, as an errno-derived IO error where the errno is meaningful. static lean_obj_res mk_ssl_file_error(b_obj_arg file, char const * msg) { ERR_clear_error(); @@ -73,6 +82,29 @@ static lean_obj_res mk_ssl_invalid_argument(char const * msg) { return lean_io_result_mk_error(lean_mk_io_error_invalid_argument(EINVAL, mk_string(msg))); } +// Reports a failure against PEM material, naming the path when there is one to name. +static lean_obj_res mk_pem_error(pem_source src, char const * msg) { + return src.is_file ? mk_ssl_file_error(src.obj, msg) : mk_ssl_invalid_argument(msg); +} + +// Opens `src` for reading. On failure returns nullptr and stores an IO error in `*err`. +static BIO * open_pem_bio(pem_source src, char const * unreadable, lean_obj_res * err) { + if (src.is_file) { + BIO * bio = BIO_new_file(src.data(), "r"); + if (bio == nullptr) *err = mk_ssl_file_error(src.obj, unreadable); + return bio; + } + + if (src.size() > (size_t)INT_MAX) { + *err = mk_ssl_invalid_argument("the PEM string is too large"); + return nullptr; + } + + BIO * bio = BIO_new_mem_buf(src.data(), (int)src.size()); + if (bio == nullptr) *err = mk_ssl_invalid_argument(unreadable); + return bio; +} + // Whether a certificate was turned away on policy grounds rather than being unreadable as PEM. static bool rejected_by_security_level() { unsigned long err = ERR_peek_last_error(); @@ -138,8 +170,9 @@ static void configure_ctx_options(SSL_CTX * ctx) { // Read only by the server state machine. SSL_CTX_set_num_tickets(ctx, 0); - // Covers the certificate chain and the private key. A CA bundle is read through a bare BIO - // rather than the context, so `load_ca_bundle` has to pass the same callback itself. + // A backstop. Every read this file performs goes through a bare BIO and passes the callback + // itself, so nothing here consults this one; it is set so that any OpenSSL path reaching for the + // context's callback still cannot end up prompting on a terminal. SSL_CTX_set_default_passwd_cb(ctx, reject_encrypted_pem); // Backs the flags above: a TLS 1.2 server still offers session-ID resumption through this cache, @@ -190,39 +223,105 @@ static lean_obj_res wrap_ssl_context(ssl_ctx_ptr ctx) { return lean_io_result_mk_ok(obj); } -// Loads the certificate chain the server presents and the key it signs with, from paths the caller -// has passed through `reject_embedded_nul`. -static lean_obj_res load_server_credentials(SSL_CTX * ctx, b_obj_arg cert_file, b_obj_arg key_file) { +// What `SSL_CTX_use_certificate_chain_file` does, against an arbitrary BIO: the leaf certificate +// plus every intermediate behind it, so the whole chain reaches the peer. There is no public +// `SSL_CTX_use_certificate_chain_bio`, so in-memory material has to go the long way round. +static bool use_certificate_chain_bio(SSL_CTX * ctx, BIO * bio) { + // `_AUX` so a certificate carrying OpenSSL's trust extensions is read the same way the file + // variant reads it. + X509 * leaf = PEM_read_bio_X509_AUX(bio, nullptr, reject_encrypted_pem, nullptr); + if (leaf == nullptr) return false; + + bool used = SSL_CTX_use_certificate(ctx, leaf) == 1; + X509_free(leaf); + + if (!used || SSL_CTX_clear_chain_certs(ctx) != 1) return false; + + while (X509 * ca = PEM_read_bio_X509(bio, nullptr, reject_encrypted_pem, nullptr)) { + // Takes ownership only on success. + if (SSL_CTX_add0_chain_cert(ctx, ca) != 1) { + X509_free(ca); + return false; + } + } + + // The loop ends either on a malformed block or on running out of them; only the latter is fine, + // so a corrupt intermediate is rejected rather than silently dropping the rest of the chain. + unsigned long err = ERR_peek_last_error(); + + if (ERR_GET_LIB(err) != ERR_LIB_PEM || ERR_GET_REASON(err) != PEM_R_NO_START_LINE) return false; + + ERR_clear_error(); + return true; +} + +// Loads the certificate chain the server presents and the key it signs with. +static lean_obj_res load_server_credentials(SSL_CTX * ctx, pem_source cert, pem_source key) { ERR_clear_error(); - if (SSL_CTX_use_certificate_chain_file(ctx, lean_string_cstr(cert_file)) <= 0) { - return mk_ssl_file_error(cert_file, rejected_by_security_level() + char const * unreadable_cert = "could not read a PEM certificate chain"; + lean_obj_res err = nullptr; + BIO * cert_bio = open_pem_bio(cert, unreadable_cert, &err); + + if (cert_bio == nullptr) return err; + + bool cert_ok = use_certificate_chain_bio(ctx, cert_bio); + BIO_free(cert_bio); + + if (!cert_ok) { + return mk_pem_error(cert, rejected_by_security_level() ? "the certificate is rejected by the TLS security level (key too small or signature " "digest too weak)" - : "could not read a PEM certificate chain"); + : unreadable_cert); } ERR_clear_error(); + char const * unreadable_key = "could not read an unencrypted PEM private key"; char const * mismatch = "the private key does not match the certificate"; + BIO * key_bio = open_pem_bio(key, unreadable_key, &err); + + if (key_bio == nullptr) return err; - if (SSL_CTX_use_PrivateKey_file(ctx, lean_string_cstr(key_file), SSL_FILETYPE_PEM) <= 0) { - return mk_ssl_file_error(key_file, ERR_GET_LIB(ERR_peek_last_error()) == ERR_LIB_X509 + EVP_PKEY * pkey = PEM_read_bio_PrivateKey(key_bio, nullptr, reject_encrypted_pem, nullptr); + BIO_free(key_bio); + + if (pkey == nullptr) return mk_pem_error(key, unreadable_key); + + bool used = SSL_CTX_use_PrivateKey(ctx, pkey) == 1; + EVP_PKEY_free(pkey); + + // A key of the certificate's own algorithm is compared here and rejected outright; one of a + // different algorithm lands in an unused slot instead, which only the check below catches. + if (!used) { + return mk_pem_error(key, ERR_GET_LIB(ERR_peek_last_error()) == ERR_LIB_X509 ? mismatch - : "could not read an unencrypted PEM private key"); + : unreadable_key); } ERR_clear_error(); - if (SSL_CTX_check_private_key(ctx) != 1) return mk_ssl_file_error(key_file, mismatch); + if (SSL_CTX_check_private_key(ctx) != 1) return mk_pem_error(key, mismatch); return nullptr; } -/* Std.Internal.SSL.Context.Server.mk (certFile keyFile : @& String) : IO Context.Server */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, b_obj_arg key_file) { - if (lean_obj_res err = reject_embedded_nul(cert_file)) return err; - if (lean_obj_res err = reject_embedded_nul(key_file)) return err; +/* Std.Internal.SSL.Context.Server.mkImpl (cert : @& String) (certIsFile : Bool) + (key : @& String) (keyIsFile : Bool) : IO Context.Server */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert, uint8_t cert_is_file, + b_obj_arg key, uint8_t key_is_file) { + pem_source cert_src{cert, cert_is_file != 0}; + pem_source key_src{key, key_is_file != 0}; + + // Only a path has to survive the trip through a C string; in-memory PEM is read with a length, + // so a NUL there is data. + if (cert_src.is_file) { + if (lean_obj_res err = reject_embedded_nul(cert)) return err; + } + + if (key_src.is_file) { + if (lean_obj_res err = reject_embedded_nul(key)) return err; + } lean_obj_res base_err = nullptr; ssl_ctx_ptr ctx = mk_ssl_ctx_base(TLS_server_method(), &base_err); @@ -231,18 +330,61 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, // The server presents its certificate but never authenticates the client (no mutual TLS). SSL_CTX_set_verify(ctx.get(), SSL_VERIFY_NONE, nullptr); - if (lean_obj_res err = load_server_credentials(ctx.get(), cert_file, key_file)) return err; + if (lean_obj_res err = load_server_credentials(ctx.get(), cert_src, key_src)) return err; return wrap_ssl_context(std::move(ctx)); } -// Shared skeleton of the client constructors; `load_ca` returns nullptr or an IO error to propagate. +// Adds every certificate `src` yields to the trust store, on top of whatever it already holds. +static lean_obj_res load_ca_bundle(SSL_CTX * ctx, pem_source src) { + char const * unreadable = src.is_file + ? "could not read PEM CA certificates" + : "could not read PEM CA certificates from the given string"; + + char const * no_certs = src.is_file + ? "the CA file contains no certificates" + : "the given CA PEM string contains no certificates"; + + lean_obj_res err = nullptr; + BIO * bio = open_pem_bio(src, unreadable, &err); + + if (bio == nullptr) return err; + + STACK_OF(X509_INFO) * infos = PEM_X509_INFO_read_bio(bio, nullptr, reject_encrypted_pem, nullptr); + BIO_free(bio); + + if (infos == nullptr) return mk_pem_error(src, unreadable); + + X509_STORE * store = SSL_CTX_get_cert_store(ctx); + int cert_count = 0; + + for (int i = 0, n = sk_X509_INFO_num(infos); i < n; i++) { + // A bundle may hold private keys and CRLs; only certificates are anchors. + X509 * cert = sk_X509_INFO_value(infos, i)->x509; + + if (cert == nullptr) continue; + cert_count++; + + if (X509_STORE_add_cert(store, cert) != 1) { + err = mk_openssl_io_error("X509_STORE_add_cert failed"); + break; + } + } + + sk_X509_INFO_pop_free(infos, X509_INFO_free); + + if (err != nullptr) return err; + if (cert_count == 0) return mk_pem_error(src, no_certs); + + return nullptr; +} + // `has_ca` says whether the caller supplied CA material at all, which decides whether dropping the -// platform anchors would leave nothing behind. `load_ca` is what enforces that supplied material -// actually yields a certificate, so the two together guarantee a verifying context has an anchor. -template +// platform anchors would leave nothing behind. `load_ca_bundle` is what enforces that supplied +// material actually yields a certificate, so the two together guarantee a verifying context has an +// anchor. static lean_obj_res mk_client_ctx(uint8_t verify_peer, uint8_t trust_system_roots, bool has_ca, - LoadCA load_ca) { + pem_source ca) { if (verify_peer && !trust_system_roots && !has_ca) { return mk_ssl_invalid_argument( "no trust anchors: peer verification is on, the platform trust anchors are excluded, " @@ -272,98 +414,41 @@ static lean_obj_res mk_client_ctx(uint8_t verify_peer, uint8_t trust_system_root // The caller's own CAs are added to whatever the store already holds: on top of the platform // anchors, or into an otherwise empty store when those were excluded. - if (lean_obj_res ca_err = load_ca(ctx.get())) return ca_err; + if (has_ca) { + if (lean_obj_res ca_err = load_ca_bundle(ctx.get(), ca)) return ca_err; + } SSL_CTX_set_verify(ctx.get(), SSL_VERIFY_PEER, nullptr); return wrap_ssl_context(std::move(ctx)); } -// Adds every certificate `bio` yields to the trust store, on top of the system anchors already there, -// and frees `bio`. -template -static lean_obj_res load_ca_bundle(SSL_CTX * ctx, BIO * bio, char const * unreadable, char const * no_certs, MkErr mk_err) { - if (bio == nullptr) return mk_err(unreadable); - - STACK_OF(X509_INFO) * infos = PEM_X509_INFO_read_bio(bio, nullptr, reject_encrypted_pem, nullptr); - BIO_free(bio); - - if (infos == nullptr) return mk_err(unreadable); - - X509_STORE * store = SSL_CTX_get_cert_store(ctx); - lean_obj_res err = nullptr; - int cert_count = 0; - - for (int i = 0, n = sk_X509_INFO_num(infos); i < n; i++) { - X509 * cert = sk_X509_INFO_value(infos, i)->x509; - - if (cert == nullptr) continue; - cert_count++; - - if (X509_STORE_add_cert(store, cert) != 1) { - err = mk_openssl_io_error("X509_STORE_add_cert failed"); - break; - } - } - - sk_X509_INFO_pop_free(infos, X509_INFO_free); - - if (err != nullptr) return err; - if (cert_count == 0) return mk_err(no_certs); - - return nullptr; -} - -/* Std.Internal.SSL.Context.Client.mkImpl (caFile : @& String) (verifyPeer trustSystemRoots : Bool) : IO Context.Client */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, uint8_t verify_peer, +/* Std.Internal.SSL.Context.Client.mkImpl (ca : @& String) (caIsFile hasCA verifyPeer + trustSystemRoots : Bool) : IO Context.Client */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca, uint8_t ca_is_file, + uint8_t has_ca, uint8_t verify_peer, uint8_t trust_system_roots) { - if (lean_obj_res err = reject_embedded_nul(ca_file)) return err; - - const char * ca = lean_string_cstr(ca_file); + pem_source ca_src{ca, ca_is_file != 0}; - return mk_client_ctx(verify_peer, trust_system_roots, ca[0] != '\0', - [&](SSL_CTX * ctx) -> lean_obj_res { - // An empty CA path leaves the client with just the system trust anchors. - if (ca[0] == '\0') return nullptr; - - return load_ca_bundle(ctx, BIO_new_file(ca, "r"), - "could not read PEM CA certificates", "the CA file contains no certificates", - [&](char const * msg) { return mk_ssl_file_error(ca_file, msg); }); - }); -} + // Checked before `verifyPeer` is consulted, so a path that could never be opened is reported as + // such even where it would not have been read. + if (has_ca && ca_src.is_file) { + if (lean_obj_res err = reject_embedded_nul(ca)) return err; + } -/* Std.Internal.SSL.Context.Client.mkFromPEM (caPEM : @& String) (verifyPeer trustSystemRoots : Bool) : IO Context.Client */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca_pem, uint8_t verify_peer, - uint8_t trust_system_roots) { - const char * pem = lean_string_cstr(ca_pem); - size_t pem_size = lean_string_size(ca_pem) - 1; - - return mk_client_ctx(verify_peer, trust_system_roots, pem_size != 0, - [&](SSL_CTX * ctx) -> lean_obj_res { - if (pem_size == 0) return nullptr; - if (pem_size > INT_MAX) return mk_ssl_invalid_argument("the CA PEM string is too large"); - - return load_ca_bundle(ctx, BIO_new_mem_buf(pem, (int)pem_size), - "could not read PEM CA certificates from the given string", - "the given CA PEM string contains no certificates", - mk_ssl_invalid_argument); - }); + return mk_client_ctx(verify_peer, trust_system_roots, has_ca != 0, ca_src); } #else void initialize_openssl_context() {} -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg /*cert_file*/, b_obj_arg /*key_file*/) { - lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); -} - -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg /*ca_file*/, - uint8_t /*verify_peer*/, uint8_t /*trust_system_roots*/) { +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg /*cert*/, + uint8_t /*cert_is_file*/, b_obj_arg /*key*/, uint8_t /*key_is_file*/) { lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); } -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg /*ca_pem*/, - uint8_t /*verify_peer*/, uint8_t /*trust_system_roots*/) { +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg /*ca*/, uint8_t /*ca_is_file*/, + uint8_t /*has_ca*/, uint8_t /*verify_peer*/, uint8_t /*trust_system_roots*/) { lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); } diff --git a/src/runtime/openssl/context.h b/src/runtime/openssl/context.h index af35a1bf19ed..98f8877a809f 100644 --- a/src/runtime/openssl/context.h +++ b/src/runtime/openssl/context.h @@ -31,8 +31,9 @@ inline SSL_CTX * lean_to_ssl_context(lean_object * o) { return (SSL_CTX*)lean_ge // ======================================= // Context Operations -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert_file, b_obj_arg key_file); -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca_file, uint8_t verify_peer, uint8_t trust_system_roots); -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client_from_pem(b_obj_arg ca_pem, uint8_t verify_peer, uint8_t trust_system_roots); +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert, uint8_t cert_is_file, + b_obj_arg key, uint8_t key_is_file); +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca, uint8_t ca_is_file, + uint8_t has_ca, uint8_t verify_peer, uint8_t trust_system_roots); } diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index 4c2a89dca9fa..e2a10180053e 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -60,7 +60,7 @@ def testCRLPEM : String := include_cert% "async_ssl_certs/crl.pem" -- Three distinct certificates in one file, the shape of a real CA bundle. def testBundlePEM : String := testCertPEM ++ testWildcardCertPEM ++ testMultiSANCertPEM --- Writes the embedded certificate and key to a temporary directory for the path-based APIs. +-- Writes the embedded certificate and key to a temporary directory, for the `PEM.file` cases. def setupTestCerts : IO (String × String) := do let dir ← IO.FS.createTempDir let keyFile := toString (dir / "key.pem") @@ -71,17 +71,17 @@ def setupTestCerts : IO (String × String) := do -- Context creation and configuration (smoke test). def testContextCreation (certFile keyFile : String) : IO Unit := do - let _serverCtx ← Context.Server.mk certFile keyFile + let _serverCtx ← Context.Server.mk { cert := .file certFile, key := .file keyFile } -- Empty CA with `verifyPeer := false` disables verification without parsing any CA material. - let _clientCtx ← Context.Client.mk "" false + let _clientCtx ← Context.Client.mk { verifyPeer := false } -- Non-empty CA file with `verifyPeer := true` exercises the additive trust path: the system -- roots plus the supplied CA. - let _clientCtx2 ← Context.Client.mk certFile true + let _clientCtx2 ← Context.Client.mk { ca := some (.file certFile) } -- A non-empty CA path with `verifyPeer := false` is accepted, but the CA file is not parsed. - let _clientCtx3 ← Context.Client.mk certFile false + let _clientCtx3 ← Context.Client.mk { ca := some (.file certFile), verifyPeer := false } -- Defaults: no CA file, peer verification against the system trust anchors. let _clientCtx4 ← Context.Client.mk @@ -89,9 +89,9 @@ def testContextCreation (certFile keyFile : String) : IO Unit := do -- Creating a client from an in-memory PEM string. def testMkClientFromPEM (certFile : String) : IO Unit := do let caPEM ← IO.FS.readFile certFile - let _clientCtx ← Context.Client.mkFromPEM caPEM true + let _clientCtx ← Context.Client.mk { ca := some (.text caPEM) } --- Materializes rejected input on disk for the path-based APIs. +-- Materializes rejected input on disk, for the `PEM.file` cases. def writeTempFile (name contents : String) : IO String := do let dir ← IO.FS.createTempDir let path := toString (dir / name) @@ -179,7 +179,7 @@ def malformedPEMError (detail : String) : String := -- An empty CA bundle with `verifyPeer := true` falls back to the platform trust anchors and succeeds. def testMkFromPEMEmptyFallsBack : IO Unit := do - let _clientCtx ← Context.Client.mkFromPEM "" true + let _clientCtx ← Context.Client.mk {} /-! `trustSystemRoots := false` narrows the store to the supplied CA, which is what pinning against a @@ -193,22 +193,26 @@ def noAnchorsError : String := excluded, and no CA certificate was given" def testPinnedToSuppliedCA (certFile : String) : IO Unit := do - let _clientCtx ← Context.Client.mk certFile true false - let _clientCtx2 ← Context.Client.mkFromPEM testCertPEM true false - let _clientCtx3 ← Context.Client.mkFromPEM testBundlePEM true false + let _clientCtx ← Context.Client.mk { ca := some (.file certFile), trustSystemRoots := false } + let _clientCtx2 ← Context.Client.mk { ca := some (.text testCertPEM), trustSystemRoots := false } + let _clientCtx3 ← Context.Client.mk { ca := some (.text testBundlePEM), trustSystemRoots := false } def testPinningRejectsEmptyCA : IO Unit := do - assertErrorMessage "pinned with no CA path" noAnchorsError - (discard <| Context.Client.mk "" true false) - - assertErrorMessage "pinned with no CA PEM" noAnchorsError - (discard <| Context.Client.mkFromPEM "" true false) + assertErrorMessage "pinned with no CA at all" noAnchorsError + (discard <| Context.Client.mk { trustSystemRoots := false }) + +-- `ca := some` is a claim that anchors were supplied, so empty material is a bundle that holds no +-- certificate rather than an absent one. That is a different diagnosis from the case above, and the +-- more specific of the two. +def testPinningRejectsEmptyCAMaterial : IO Unit := do + assertErrorMessage "pinned to an empty CA string" + (malformedPEMError "the given CA PEM string contains no certificates") + (discard <| Context.Client.mk { ca := some (.text ""), trustSystemRoots := false }) -- With verification off there is no store to be empty, so excluding the platform anchors is not a -- contradiction and `trustSystemRoots` is simply ignored. def testPinningIgnoredWithoutVerification : IO Unit := do - let _clientCtx ← Context.Client.mk "" false false - let _clientCtx2 ← Context.Client.mkFromPEM "" false false + let _clientCtx ← Context.Client.mk { verifyPeer := false, trustSystemRoots := false } -- Supplied CA material still has to yield a certificate. These reach the ordinary bundle-loading -- failures rather than the "no trust anchors" one, which is what pins the check to the *absence* of @@ -216,119 +220,184 @@ def testPinningIgnoredWithoutVerification : IO Unit := do def testPinningStillValidatesCA (junkFile : String) : IO Unit := do assertErrorMessage "pinned to a malformed CA file" (malformedFileError junkFile "the CA file contains no certificates") - (discard <| Context.Client.mk junkFile true false) + (discard <| Context.Client.mk { ca := some (.file junkFile), trustSystemRoots := false }) assertErrorMessage "pinned to a CA string with no certificates" (malformedPEMError "the given CA PEM string contains no certificates") - (discard <| Context.Client.mkFromPEM "not a certificate at all" true false) + (discard <| Context.Client.mk + { ca := some (.text "not a certificate at all"), trustSystemRoots := false }) -- An unusable path is still rejected as a path, before the anchor bookkeeping is consulted. def testPinningRejectsNulInCAFile : IO Unit := do let caPath := "ca\x00.pem" assertErrorMessage "NUL byte in a pinned CA path" (nulByteError caPath) - (discard <| Context.Client.mk caPath true false) + (discard <| Context.Client.mk { ca := some (.file caPath), trustSystemRoots := false }) + +/-! +Server credentials may be supplied in memory rather than by path, for a certificate that comes from +a secret manager or is embedded in the binary. `PEM.text` reads with an explicit length, so unlike a +path it carries no NUL restriction; the failures it reports have no path to name. +-/ + +def testMkServerFromMemory : IO Unit := do + let _serverCtx ← Context.Server.mk { cert := .text testCertPEM, key := .text testKeyPEM } + +-- The two sources are independent, so a file certificate pairs with an in-memory key and back. +def testMkServerMixedSources (certFile keyFile : String) : IO Unit := do + let _serverCtx ← Context.Server.mk { cert := .file certFile, key := .text testKeyPEM } + let _serverCtx2 ← Context.Server.mk { cert := .text testCertPEM, key := .file keyFile } + +-- The whole chain is loaded from memory too, not just the leaf. +def testMkServerFromMemoryLoadsChain : IO Unit := do + let _serverCtx ← Context.Server.mk + { cert := .text (testCertPEM ++ testWildcardCertPEM), key := .text testKeyPEM } + + assertErrorMessage "corrupt intermediate in an in-memory chain" + (malformedPEMError "could not read a PEM certificate chain") + (discard <| Context.Server.mk + { cert := .text (testCertPEM ++ testCorruptCertPEM), key := .text testKeyPEM }) + +-- In-memory failures report the same diagnoses as the path-based ones, without a path attached. +def testMkServerFromMemoryErrors : IO Unit := do + assertErrorMessage "malformed in-memory certificate" + (malformedPEMError "could not read a PEM certificate chain") + (discard <| Context.Server.mk { cert := .text "this is not pem\n", key := .text testKeyPEM }) + + assertErrorMessage "malformed in-memory key" + (malformedPEMError "could not read an unencrypted PEM private key") + (discard <| Context.Server.mk { cert := .text testCertPEM, key := .text "this is not pem\n" }) + + assertErrorMessage "mismatched in-memory key" + (malformedPEMError "the private key does not match the certificate") + (discard <| Context.Server.mk { cert := .text testCertPEM, key := .text testUnrelatedKeyPEM }) + + assertErrorMessage "cross-algorithm in-memory key" + (malformedPEMError "the private key does not match the certificate") + (discard <| Context.Server.mk { cert := .text testCertPEM, key := .text testECKeyPEM }) + +-- Encrypted material must be refused without prompting here too, which is the failure mode that +-- hangs rather than fails loudly. +def testMkServerFromMemoryRejectsEncrypted : IO Unit := do + assertErrorMessage "in-memory encrypted key" + (malformedPEMError "could not read an unencrypted PEM private key") + (discard <| Context.Server.mk { cert := .text testCertPEM, key := .text testEncryptedKeyPEM }) + + assertErrorMessage "in-memory empty-passphrase key" + (malformedPEMError "could not read an unencrypted PEM private key") + (discard <| Context.Server.mk + { cert := .text testCertPEM, key := .text testEmptyPassphraseKeyPEM }) + + assertErrorMessage "in-memory encrypted certificate" + (malformedPEMError "could not read a PEM certificate chain") + (discard <| Context.Server.mk { cert := .text testEncryptedCertPEM, key := .text testKeyPEM }) + +-- A path cannot carry a NUL, but in-memory material is read with a length, so it can. +def testMkServerFromMemoryAcceptsNul : IO Unit := do + let _serverCtx ← Context.Server.mk + { cert := .text (testCertPEM.push '\x00'), key := .text testKeyPEM } -- `verifyPeer := false` succeeds without parsing the CA material, even for a real bundle. def testMkFromPEMNoVerify (certFile : String) : IO Unit := do let caPEM ← IO.FS.readFile certFile - let _clientCtx ← Context.Client.mkFromPEM caPEM false + let _clientCtx ← Context.Client.mk { ca := some (.text caPEM), verifyPeer := false } -- A bundle of several distinct certificates is loaded in full: every certificate in the PEM becomes -- a trust anchor, not just the first one. def testMkFromPEMAcceptsBundle : IO Unit := do - let _clientCtx ← Context.Client.mkFromPEM testBundlePEM true + let _clientCtx ← Context.Client.mk { ca := some (.text testBundlePEM) } def testMkAcceptsBundleFile (bundleFile : String) : IO Unit := do - let _clientCtx ← Context.Client.mk bundleFile true + let _clientCtx ← Context.Client.mk { ca := some (.file bundleFile) } -- Repeated certificates are skipped instead of failing, so a bundle that overlaps the system trust -- anchors (or repeats itself) still yields a usable context. def testMkFromPEMAcceptsDuplicates : IO Unit := do - let _clientCtx ← Context.Client.mkFromPEM (testCertPEM ++ testCertPEM) true + let _clientCtx ← Context.Client.mk { ca := some (.text (testCertPEM ++ testCertPEM)) } def testMkAcceptsDuplicatesInFile (dupFile : String) : IO Unit := do - let _clientCtx ← Context.Client.mk dupFile true + let _clientCtx ← Context.Client.mk { ca := some (.file dupFile) } --- Unlike the path-based APIs, `mkFromPEM` hands OpenSSL an explicit length rather than a C string, +-- Unlike `PEM.file`, `PEM.text` hands OpenSSL an explicit length rather than a C string, -- so a NUL byte is data (here: trailing junk after a complete certificate) and not an error. def testMkFromPEMAcceptsNulBytes : IO Unit := do - let _clientCtx ← Context.Client.mkFromPEM (testCertPEM.push '\x00') true + let _clientCtx ← Context.Client.mk { ca := some (.text (testCertPEM.push '\x00')) } def testMkFromPEMRejectsGarbage : IO Unit := do assertErrorMessage "garbage PEM" (malformedPEMError "the given CA PEM string contains no certificates") - (discard <| Context.Client.mkFromPEM "not a certificate at all" true) + (discard <| Context.Client.mk { ca := some (.text "not a certificate at all") }) def testMkNoVerifyIgnoresCorruptCAFile (corruptFile : String) : IO Unit := do - let _clientCtx ← Context.Client.mk corruptFile false + let _clientCtx ← Context.Client.mk { ca := some (.file corruptFile), verifyPeer := false } def testMkFromPEMRejectsEmptyBlock : IO Unit := do assertErrorMessage "PEM without certificates" (malformedPEMError "could not read PEM CA certificates from the given string") - (discard <| Context.Client.mkFromPEM "-----BEGIN CERTIFICATE-----\n-----END CERTIFICATE-----\n" true) + (discard <| Context.Client.mk + { ca := some (.text "-----BEGIN CERTIFICATE-----\n-----END CERTIFICATE-----\n") }) def testMkFromPEMRejectsCorruptCert : IO Unit := do assertErrorMessage "one-bit-flipped CA PEM" (malformedPEMError "could not read PEM CA certificates from the given string") - (discard <| Context.Client.mkFromPEM testCorruptCertPEM true) + (discard <| Context.Client.mk { ca := some (.text testCorruptCertPEM) }) -- Text with no PEM armour at all parses to an empty bundle rather than failing to parse, so it is --- reported as "no certificates" — the same way `mkFromPEM` reports the same bytes. +-- reported as "no certificates" — the same way `PEM.text` reports the same bytes. def testMkRejectsMalformedCAFile (junkFile : String) : IO Unit := do assertErrorMessage "malformed CA file" (malformedFileError junkFile "the CA file contains no certificates") - (discard <| Context.Client.mk junkFile true) + (discard <| Context.Client.mk { ca := some (.file junkFile) }) def testMkRejectsCorruptCAFile (corruptFile : String) : IO Unit := do assertErrorMessage "one-bit-flipped CA file" (malformedFileError corruptFile "could not read PEM CA certificates") - (discard <| Context.Client.mk corruptFile true) + (discard <| Context.Client.mk { ca := some (.file corruptFile) }) def testMkRejectsMissingCAFile : IO Unit := do assertErrorMessage "missing CA file" (missingFileError "/nonexistent/path/to/ca.pem") - (discard <| Context.Client.mk "/nonexistent/path/to/ca.pem" true) + (discard <| Context.Client.mk { ca := some (.file "/nonexistent/path/to/ca.pem") }) def testMkServerRejectsMissingCert (keyFile : String) : IO Unit := do assertErrorMessage "missing server cert" (missingFileError "/nonexistent/cert.pem") - (discard <| Context.Server.mk "/nonexistent/cert.pem" keyFile) + (discard <| Context.Server.mk { cert := .file "/nonexistent/cert.pem", key := .file keyFile }) def testMkServerRejectsMissingKey (certFile : String) : IO Unit := do assertErrorMessage "missing server key" (missingFileError "/nonexistent/key.pem") - (discard <| Context.Server.mk certFile "/nonexistent/key.pem") + (discard <| Context.Server.mk { cert := .file certFile, key := .file "/nonexistent/key.pem" }) def testMkServerRejectsMalformedKey (certFile junkFile : String) : IO Unit := do assertErrorMessage "malformed server key" (malformedFileError junkFile "could not read an unencrypted PEM private key") - (discard <| Context.Server.mk certFile junkFile) + (discard <| Context.Server.mk { cert := .file certFile, key := .file junkFile }) def testMkServerRejectsCertAsKey (certFile : String) : IO Unit := do assertErrorMessage "certificate used as server key" (malformedFileError certFile "could not read an unencrypted PEM private key") - (discard <| Context.Server.mk certFile certFile) + (discard <| Context.Server.mk { cert := .file certFile, key := .file certFile }) def testMkServerRejectsMalformedCert (junkFile keyFile : String) : IO Unit := do assertErrorMessage "malformed server cert" (malformedFileError junkFile "could not read a PEM certificate chain") - (discard <| Context.Server.mk junkFile keyFile) + (discard <| Context.Server.mk { cert := .file junkFile, key := .file keyFile }) def testMkServerRejectsCorruptCert (corruptFile keyFile : String) : IO Unit := do assertErrorMessage "one-bit-flipped server cert" (malformedFileError corruptFile "could not read a PEM certificate chain") - (discard <| Context.Server.mk corruptFile keyFile) + (discard <| Context.Server.mk { cert := .file corruptFile, key := .file keyFile }) def testMkServerRejectsSwappedFiles (certFile keyFile : String) : IO Unit := do assertErrorMessage "swapped server cert/key" (malformedFileError keyFile "could not read a PEM certificate chain") - (discard <| Context.Server.mk keyFile certFile) + (discard <| Context.Server.mk { cert := .file keyFile, key := .file certFile }) def testMkServerRejectsMismatchedKey (certFile key2File : String) : IO Unit := do assertErrorMessage "server key from a different pair" (malformedFileError key2File "the private key does not match the certificate") - (discard <| Context.Server.mk certFile key2File) + (discard <| Context.Server.mk { cert := .file certFile, key := .file key2File }) -- A key of a different algorithm than the certificate lands in an unused slot of the context, so -- `SSL_CTX_use_PrivateKey_file` accepts it without ever comparing the two; only the separate @@ -336,7 +405,7 @@ def testMkServerRejectsMismatchedKey (certFile key2File : String) : IO Unit := d def testMkServerRejectsCrossAlgorithmKey (certFile ecKeyFile : String) : IO Unit := do assertErrorMessage "EC server key against an RSA certificate" (malformedFileError ecKeyFile "the private key does not match the certificate") - (discard <| Context.Server.mk certFile ecKeyFile) + (discard <| Context.Server.mk { cert := .file certFile, key := .file ecKeyFile }) -- Encrypted keys are unsupported. The point of this test is as much the absence of output as the -- error itself: with no password callback installed OpenSSL prompts for the passphrase on the @@ -344,28 +413,28 @@ def testMkServerRejectsCrossAlgorithmKey (certFile ecKeyFile : String) : IO Unit def testMkServerRejectsEncryptedKey (certFile encKeyFile : String) : IO Unit := do assertErrorMessage "passphrase-protected server key" (malformedFileError encKeyFile "could not read an unencrypted PEM private key") - (discard <| Context.Server.mk certFile encKeyFile) + (discard <| Context.Server.mk { cert := .file certFile, key := .file encKeyFile }) -- An empty passphrase still counts as encrypted. A password callback that reports a zero-length -- passphrase instead of a failure decrypts this key and accepts it. def testMkServerRejectsEmptyPassphraseKey (certFile emptyPwKeyFile : String) : IO Unit := do assertErrorMessage "server key encrypted under an empty passphrase" (malformedFileError emptyPwKeyFile "could not read an unencrypted PEM private key") - (discard <| Context.Server.mk certFile emptyPwKeyFile) + (discard <| Context.Server.mk { cert := .file certFile, key := .file emptyPwKeyFile }) def testMkServerRejectsNulInCert (keyFile : String) : IO Unit := do let certPath := "cert\x00.pem" assertErrorMessage "NUL byte in server cert path" (nulByteError certPath) - (discard <| Context.Server.mk certPath keyFile) + (discard <| Context.Server.mk { cert := .file certPath, key := .file keyFile }) def testMkServerRejectsNulInKey (certFile : String) : IO Unit := do let keyPath := "key\x00.pem" assertErrorMessage "NUL byte in server key path" (nulByteError keyPath) - (discard <| Context.Server.mk certFile keyPath) + (discard <| Context.Server.mk { cert := .file certFile, key := .file keyPath }) -- The CA path is checked before `verifyPeer`, so a NUL is rejected even when the file would never -- have been opened. @@ -374,11 +443,11 @@ def testMkRejectsNulInCAFile : IO Unit := do assertErrorMessage "NUL byte in CA path" (nulByteError caPath) - (discard <| Context.Client.mk caPath true) + (discard <| Context.Client.mk { ca := some (.file caPath) }) assertErrorMessage "NUL byte in CA path without verification" (nulByteError caPath) - (discard <| Context.Client.mk caPath false) + (discard <| Context.Client.mk { ca := some (.file caPath), verifyPeer := false }) /-! Encrypted PEM material must be rejected outright. A passphrase callback reporting failure is what @@ -391,17 +460,17 @@ in each of the three constructors. def testMkServerRejectsEncryptedCert (encCertFile keyFile : String) : IO Unit := do assertErrorMessage "encrypted server certificate" (malformedFileError encCertFile "could not read a PEM certificate chain") - (discard <| Context.Server.mk encCertFile keyFile) + (discard <| Context.Server.mk { cert := .file encCertFile, key := .file keyFile }) def testMkRejectsEncryptedCertCAFile (encCertFile : String) : IO Unit := do assertErrorMessage "encrypted CA certificate file" (malformedFileError encCertFile "could not read PEM CA certificates") - (discard <| Context.Client.mk encCertFile true) + (discard <| Context.Client.mk { ca := some (.file encCertFile) }) def testMkFromPEMRejectsEncryptedCert : IO Unit := do assertErrorMessage "encrypted CA certificate string" (malformedPEMError "could not read PEM CA certificates from the given string") - (discard <| Context.Client.mkFromPEM testEncryptedCertPEM true) + (discard <| Context.Client.mk { ca := some (.text testEncryptedCertPEM) }) -- A CA bundle is required to contain at least one certificate. A file holding only a key parses -- without complaint and would leave the trust store silently unchanged, so the count is checked @@ -409,27 +478,27 @@ def testMkFromPEMRejectsEncryptedCert : IO Unit := do def testMkRejectsCertlessCAFile (keyFile : String) : IO Unit := do assertErrorMessage "CA file holding only a private key" (malformedFileError keyFile "the CA file contains no certificates") - (discard <| Context.Client.mk keyFile true) + (discard <| Context.Client.mk { ca := some (.file keyFile) }) def testMkFromPEMRejectsCertlessPEM : IO Unit := do assertErrorMessage "CA string holding only a private key" (malformedPEMError "the given CA PEM string contains no certificates") - (discard <| Context.Client.mkFromPEM testKeyPEM true) + (discard <| Context.Client.mk { ca := some (.text testKeyPEM) }) -- Non-certificate entries in a bundle are skipped rather than rejected. A *traditional* RSA key is -- the case that matters: it yields a parsed entry carrying no certificate, unlike the PKCS#8 form -- which is dropped before that point. def testMkFromPEMSkipsTraditionalKey : IO Unit := do - let _clientCtx ← Context.Client.mkFromPEM (testTraditionalKeyPEM ++ testCertPEM) true - let _clientCtx2 ← Context.Client.mkFromPEM (testCertPEM ++ testTraditionalKeyPEM) true + let _clientCtx ← Context.Client.mk { ca := some (.text (testTraditionalKeyPEM ++ testCertPEM)) } + let _clientCtx2 ← Context.Client.mk { ca := some (.text (testCertPEM ++ testTraditionalKeyPEM)) } def testMkFromPEMRejectsTraditionalKeyOnly : IO Unit := do assertErrorMessage "traditional RSA key with no certificate" (malformedPEMError "the given CA PEM string contains no certificates") - (discard <| Context.Client.mkFromPEM testTraditionalKeyPEM true) + (discard <| Context.Client.mk { ca := some (.text testTraditionalKeyPEM) }) /-! -`mkFromPEM` hands OpenSSL an explicit length rather than a C string, so a NUL does not truncate the +`PEM.text` hands OpenSSL an explicit length rather than a C string, so a NUL does not truncate the input. It is still junk to the PEM parser, which needs `-----BEGIN` to start a line, so where the NUL sits decides between three outcomes. Appending a NUL to a complete certificate would pass either way, so these put material the parser must still reach *after* the NUL. @@ -437,19 +506,19 @@ way, so these put material the parser must still reach *after* the NUL. -- Terminated by a newline the NUL is skipped like any other junk line. def testMkFromPEMReadsPastNul : IO Unit := do - let _clientCtx ← Context.Client.mkFromPEM ("\x00\n" ++ testCertPEM) true + let _clientCtx ← Context.Client.mk { ca := some (.text ("\x00\n" ++ testCertPEM)) } def testMkFromPEMParsesPastNul : IO Unit := do assertErrorMessage "corrupt certificate after a NUL byte" (malformedPEMError "could not read PEM CA certificates from the given string") - (discard <| Context.Client.mkFromPEM (testCertPEM ++ "\x00\n" ++ testCorruptCertPEM) true) + (discard <| Context.Client.mk { ca := some (.text (testCertPEM ++ "\x00\n" ++ testCorruptCertPEM)) }) -- Sharing a line with the marker, the NUL hides it and that certificate is dropped without an error -- of its own; only the empty bundle behind it is reported. def testMkFromPEMDropsCertBehindNul : IO Unit := do assertErrorMessage "certificate behind an unterminated NUL" (malformedPEMError "the given CA PEM string contains no certificates") - (discard <| Context.Client.mkFromPEM ("\x00" ++ testCertPEM) true) + (discard <| Context.Client.mk { ca := some (.text ("\x00" ++ testCertPEM)) }) -- Inside the body the NUL corrupts the block, which discards the whole bundle rather than just that -- certificate. @@ -457,8 +526,8 @@ def testMkFromPEMRejectsNulInsideCert : IO Unit := do let split := 200 assertErrorMessage "NUL inside a certificate body" (malformedPEMError "could not read PEM CA certificates from the given string") - (discard <| Context.Client.mkFromPEM - ((testCertPEM.take split).toString ++ "\x00" ++ (testCertPEM.drop split).toString) true) + (discard <| Context.Client.mk { ca := some (.text + ((testCertPEM.take split).toString ++ "\x00" ++ (testCertPEM.drop split).toString)) }) -- Inside the marker's type name the line still opens a block, but the name no longer matches the one -- on the `-----END` line, so the whole string is rejected instead of that certificate being skipped. @@ -467,16 +536,16 @@ def testMkFromPEMRejectsNulInsideCert : IO Unit := do def testMkFromPEMRejectsNulInMarkerName : IO Unit := do assertErrorMessage "NUL inside a PEM marker's type name" (malformedPEMError "could not read PEM CA certificates from the given string") - (discard <| Context.Client.mkFromPEM - (testCertPEM.replace "-----BEGIN CERTIFICATE-----" "-----BEGIN CERTI\x00FICATE-----") true) + (discard <| Context.Client.mk { ca := some (.text + (testCertPEM.replace "-----BEGIN CERTIFICATE-----" "-----BEGIN CERTI\x00FICATE-----")) }) -- The block is already open by the time the `-----END` line is read, so a NUL anywhere in it leaves a -- block that can never be closed and the whole string is rejected. def testMkFromPEMRejectsNulInEndMarker : IO Unit := do assertErrorMessage "NUL inside the END marker" (malformedPEMError "could not read PEM CA certificates from the given string") - (discard <| Context.Client.mkFromPEM - (testCertPEM.replace "-----END CERTIFICATE-----" "-----END CERTI\x00FICATE-----") true) + (discard <| Context.Client.mk { ca := some (.text + (testCertPEM.replace "-----END CERTIFICATE-----" "-----END CERTI\x00FICATE-----")) }) -- The whole chain is loaded, not just the leaf, so a corrupt certificate in a later position is -- still rejected. This is the observable difference between `SSL_CTX_use_certificate_chain_file` @@ -484,13 +553,13 @@ def testMkFromPEMRejectsNulInEndMarker : IO Unit := do def testMkServerRejectsCorruptChainMember (chainFile keyFile : String) : IO Unit := do assertErrorMessage "corrupt intermediate in the server chain" (malformedFileError chainFile "could not read a PEM certificate chain") - (discard <| Context.Server.mk chainFile keyFile) + (discard <| Context.Server.mk { cert := .file chainFile, key := .file keyFile }) -- Building a context parses certificates; it does not check their validity period. An expired -- certificate is therefore accepted here and only rejected at handshake time. def testAcceptsExpiredCert (expiredFile keyFile : String) : IO Unit := do - let _serverCtx ← Context.Server.mk expiredFile keyFile - let _clientCtx ← Context.Client.mkFromPEM testExpiredCertPEM true + let _serverCtx ← Context.Server.mk { cert := .file expiredFile, key := .file keyFile } + let _clientCtx ← Context.Client.mk { ca := some (.text testExpiredCertPEM) } /-! A certificate can be refused on policy grounds rather than because it could not be read: the TLS @@ -508,14 +577,14 @@ def testMkServerRejectsWeakCert (weakCertFile keyFile : String) : IO Unit := do [ malformedFileError weakCertFile "the certificate is rejected by the TLS security level (key too small or signature digest too weak)", malformedFileError keyFile "the private key does not match the certificate" ] - (discard <| Context.Server.mk weakCertFile keyFile) + (discard <| Context.Server.mk { cert := .file weakCertFile, key := .file keyFile }) -- The security level governs the certificate a server presents, not the anchors a client trusts, so -- the very file rejected above still loads as a CA. This is what pins the diagnosis to the security -- level rather than to the certificate being malformed. def testAcceptsWeakCertAsCA (weakCertFile : String) : IO Unit := do - let _clientCtx ← Context.Client.mkFromPEM testWeakCertPEM true - let _clientCtx2 ← Context.Client.mk weakCertFile true + let _clientCtx ← Context.Client.mk { ca := some (.text testWeakCertPEM) } + let _clientCtx2 ← Context.Client.mk { ca := some (.file weakCertFile) } /-! A bundle entry that is not a certificate is skipped, and a bundle of nothing but such entries is @@ -526,34 +595,34 @@ one, and the only one the "a lone CRL" case in the loader is actually about. def testMkRejectsCRLOnlyCAFile (crlFile : String) : IO Unit := do assertErrorMessage "CA file holding only a CRL" (malformedFileError crlFile "the CA file contains no certificates") - (discard <| Context.Client.mk crlFile true) + (discard <| Context.Client.mk { ca := some (.file crlFile) }) def testMkFromPEMRejectsCRLOnly : IO Unit := do assertErrorMessage "CA string holding only a CRL" (malformedPEMError "the given CA PEM string contains no certificates") - (discard <| Context.Client.mkFromPEM testCRLPEM true) + (discard <| Context.Client.mk { ca := some (.text testCRLPEM) }) def testMkFromPEMSkipsCRL : IO Unit := do - let _clientCtx ← Context.Client.mkFromPEM (testCRLPEM ++ testCertPEM) true - let _clientCtx2 ← Context.Client.mkFromPEM (testCertPEM ++ testCRLPEM) true + let _clientCtx ← Context.Client.mk { ca := some (.text (testCRLPEM ++ testCertPEM)) } + let _clientCtx2 ← Context.Client.mk { ca := some (.text (testCertPEM ++ testCRLPEM)) } -- A zero-byte file has no PEM armour to fail on, so it parses to an empty bundle and is reported as -- holding no certificates rather than as unreadable. def testMkRejectsEmptyCAFile (emptyFile : String) : IO Unit := do assertErrorMessage "zero-byte CA file" (malformedFileError emptyFile "the CA file contains no certificates") - (discard <| Context.Client.mk emptyFile true) + (discard <| Context.Client.mk { ca := some (.file emptyFile) }) -- Only the *CA* path treats "" as "use the platform anchors". The server has no such fallback, so an -- empty path reaches the OS and fails there. def testMkServerRejectsEmptyPaths (certFile keyFile : String) : IO Unit := do assertErrorMessage "empty server cert path" (missingFileError "") - (discard <| Context.Server.mk "" keyFile) + (discard <| Context.Server.mk { cert := .file "", key := .file keyFile }) assertErrorMessage "empty server key path" (missingFileError "") - (discard <| Context.Server.mk certFile "") + (discard <| Context.Server.mk { cert := .file certFile, key := .file "" }) /-! The path is reported with the failure whenever the `IO.Error` constructor has room for it. These @@ -572,11 +641,11 @@ def testRejectsDirectoryPaths (dir certFile keyFile : String) : IO Unit := do assertErrorMessage "directory as server cert" (malformedFileError dir ("could not read a PEM certificate chain" ++ note)) - (discard <| Context.Server.mk dir keyFile) + (discard <| Context.Server.mk { cert := .file dir, key := .file keyFile }) assertErrorMessage "directory as server key" (malformedFileError dir ("could not read an unencrypted PEM private key" ++ note)) - (discard <| Context.Server.mk certFile dir) + (discard <| Context.Server.mk { cert := .file certFile, key := .file dir }) -- Which failure this is depends on the C library. On POSIX `BIO_new_file` opens the directory and -- the read that follows yields nothing, so the empty bundle is what gets reported; the Windows CRT @@ -585,7 +654,7 @@ def testRejectsDirectoryPaths (dir certFile keyFile : String) : IO Unit := do assertErrorMessageOneOf "directory as CA file" [ malformedFileError dir ("the CA file contains no certificates" ++ note), malformedFileError dir ("could not read PEM CA certificates" ++ note) ] - (discard <| Context.Client.mk dir true) + (discard <| Context.Client.mk { ca := some (.file dir) }) -- A character device is the readable non-regular file: OpenSSL opens `/dev/null` and reads it to -- completion, so the diagnosis is about what the empty read produced and the file type is only a @@ -597,12 +666,12 @@ def testAppendsNoteToReadableNonRegularFile (certFile : String) : IO Unit := do assertErrorMessage "character device as CA file" (malformedFileError "/dev/null" "the CA file contains no certificates (the path is not a regular file)") - (discard <| Context.Client.mk "/dev/null" true) + (discard <| Context.Client.mk { ca := some (.file "/dev/null") }) assertErrorMessage "character device as server key" (malformedFileError "/dev/null" "could not read an unencrypted PEM private key (the path is not a regular file)") - (discard <| Context.Server.mk certFile "/dev/null") + (discard <| Context.Server.mk { cert := .file certFile, key := .file "/dev/null" }) -- Skipped when the permission bits do not bite, which is the case for a privileged user. def testMkRejectsUnreadableCAFile (unreadableFile : String) : IO Unit := do @@ -611,12 +680,12 @@ def testMkRejectsUnreadableCAFile (unreadableFile : String) : IO Unit := do assertErrorMessage "CA file with no read permission" s!"permission denied (error code: 13)\n file: {unreadableFile}" - (discard <| Context.Client.mk unreadableFile true) + (discard <| Context.Client.mk { ca := some (.file unreadableFile) }) def testMkRejectsNonDirectoryParent (notADirPath : String) : IO Unit := do assertErrorMessage "CA path whose parent is a regular file" s!"inappropriate type (error code: 20, not a directory)\n file: {notADirPath}" - (discard <| Context.Client.mk notADirPath true) + (discard <| Context.Client.mk { ca := some (.file notADirPath) }) #eval do let (certFile, keyFile) ← setupTestCerts @@ -626,6 +695,17 @@ def testMkRejectsNonDirectoryParent (notADirPath : String) : IO Unit := do let (certFile, _) ← setupTestCerts testMkClientFromPEM certFile +-- Server credentials supplied in memory rather than by path. +#eval do + let (certFile, keyFile) ← setupTestCerts + + testMkServerFromMemory + testMkServerMixedSources certFile keyFile + testMkServerFromMemoryLoadsChain + testMkServerFromMemoryErrors + testMkServerFromMemoryRejectsEncrypted + testMkServerFromMemoryAcceptsNul + #eval testMkFromPEMEmptyFallsBack -- Pinning: the supplied CA replaces the platform anchors rather than joining them. @@ -634,6 +714,7 @@ def testMkRejectsNonDirectoryParent (notADirPath : String) : IO Unit := do testPinnedToSuppliedCA certFile testPinningRejectsEmptyCA + testPinningRejectsEmptyCAMaterial testPinningIgnoredWithoutVerification testPinningStillValidatesCA (← setupMalformedFile) testPinningRejectsNulInCAFile From 6520b055fb4718c3f78beade8d32f98e9a1a6527 Mon Sep 17 00:00:00 2001 From: Sofia Rodrigues Date: Mon, 31 Aug 2026 20:32:31 -0300 Subject: [PATCH 36/36] feat: allow partial chain --- src/Std/Internal/SSL/Context.lean | 26 +- src/runtime/openssl/context.cpp | 138 ++-- src/runtime/openssl/context.h | 6 +- src/runtime/openssl/trust_store.cpp | 5 +- tests/elab/async_ssl_certs/README.md | 11 +- tests/elab/async_ssl_certs/intermediate.pem | 19 + tests/elab/async_ssl_context.lean | 830 +++++++++----------- 7 files changed, 498 insertions(+), 537 deletions(-) create mode 100644 tests/elab/async_ssl_certs/intermediate.pem diff --git a/src/Std/Internal/SSL/Context.lean b/src/Std/Internal/SSL/Context.lean index 3188ceec53e7..90dffaa534fc 100644 --- a/src/Std/Internal/SSL/Context.lean +++ b/src/Std/Internal/SSL/Context.lean @@ -152,10 +152,23 @@ structure Config where With `false` none of that is consulted, environment variables included, and only `ca` is trusted. -/ trustSystemRoots : Bool := true + /-- + Whether a certificate in the trust store may anchor a chain without being self-signed itself. + + With `false`, the default, a chain is accepted only once it reaches a self-signed certificate, so + an intermediate CA cannot serve as a trust anchor. Supplying nothing but intermediates as `ca` + while also excluding the platform anchors then describes a context that could never verify + anything, and is rejected outright rather than left to fail at every handshake. Alongside the + platform anchors an intermediate is merely redundant, so it passes. + + With `true` any certificate in the store anchors a chain, which is what pinning to an intermediate + rather than to the root above it requires. + -/ + allowPartialChain : Bool := false @[extern "lean_ssl_ctx_mk_client"] private opaque mkImpl (ca : @& String) (caIsFile : Bool) (hasCA : Bool) (verifyPeer : Bool) - (trustSystemRoots : Bool) : IO Context.Client + (trustSystemRoots : Bool) (allowPartialChain : Bool) : IO Context.Client /-- Creates a client-side TLS context trusting the anchors named by `cfg`. @@ -165,17 +178,18 @@ issued by any other authority, public roots included, is then rejected. `ca` mus one certificate in that case, since a verifying context with no anchor at all could never complete a handshake; that combination is refused here rather than at connection time. -A trusted CA has to be self-signed, whichever way it is supplied: a chain is only accepted once it -reaches a self-signed certificate, so trusting an intermediate alone loads without complaint and -then fails every handshake. +A trusted CA has to be self-signed unless `allowPartialChain` says otherwise, since a chain is only +accepted once it reaches a self-signed certificate. Pinning to nothing but intermediates is refused +here rather than failing at every handshake. Verifying the peer proves the certificate chains to a trusted anchor; it does **not** prove the certificate belongs to the host being connected to. Binding a hostname is the session layer's job. -/ def mk (cfg : Config := {}) : IO Context.Client := match cfg.ca with - | none => mkImpl "" false false cfg.verifyPeer cfg.trustSystemRoots - | some ca => mkImpl ca.bytes ca.isFile true cfg.verifyPeer cfg.trustSystemRoots + | none => mkImpl "" false false cfg.verifyPeer cfg.trustSystemRoots cfg.allowPartialChain + | some ca => + mkImpl ca.bytes ca.isFile true cfg.verifyPeer cfg.trustSystemRoots cfg.allowPartialChain end Client end Context diff --git a/src/runtime/openssl/context.cpp b/src/runtime/openssl/context.cpp index 4a8cf448662f..ff2d31ffc549 100644 --- a/src/runtime/openssl/context.cpp +++ b/src/runtime/openssl/context.cpp @@ -45,33 +45,24 @@ struct pem_source { size_t size() const { return lean_string_size(obj) - 1; } }; -// Reports a failure against a path, as an errno-derived IO error where the errno is meaningful. -static lean_obj_res mk_ssl_file_error(b_obj_arg file, char const * msg) { +// Reports a failure against a path. `errnum` is the `errno` the open failed with, or 0 for a +// failure with no OS error behind it (unparsable PEM, a key that does not match its certificate). +static lean_obj_res mk_ssl_file_error(b_obj_arg file, char const * msg, int errnum = 0) { ERR_clear_error(); - char const * path = lean_string_cstr(file); - int errnum = 0; - std::string detail(msg); struct stat st; - if (stat(path, &st) != 0) { - errnum = errno; - } else if (S_ISREG(st.st_mode)) { - FILE * probe = fopen(path, "rb"); - if (probe == nullptr) errnum = errno; else fclose(probe); - } else { - detail += " (the path is not a regular file)"; + if (stat(lean_string_cstr(file), &st) == 0 && !S_ISREG(st.st_mode)) { + lean_inc(file); + return lean_io_result_mk_error(lean_mk_io_error_invalid_argument_file( + file, EINVAL, mk_string(std::string(msg) + " (the path is not a regular file)"))); } - if (errnum == ENOENT || errnum == EACCES || errnum == EPERM || errnum == ENOTDIR || - errnum == ELOOP || errnum == ENAMETOOLONG || errnum == EMFILE || errnum == ENFILE || - errnum == ENOMEM) { - return lean_io_result_mk_error(decode_io_error(errnum, file)); - } + if (errnum != 0) return lean_io_result_mk_error(decode_io_error(errnum, file)); lean_inc(file); return lean_io_result_mk_error(lean_mk_io_error_invalid_argument_file( - file, errnum != 0 ? errnum : EINVAL, mk_string(detail))); + file, EINVAL, mk_string(msg))); } static int reject_encrypted_pem(char *, int, int, void *) { return -1; } @@ -83,15 +74,18 @@ static lean_obj_res mk_ssl_invalid_argument(char const * msg) { } // Reports a failure against PEM material, naming the path when there is one to name. -static lean_obj_res mk_pem_error(pem_source src, char const * msg) { - return src.is_file ? mk_ssl_file_error(src.obj, msg) : mk_ssl_invalid_argument(msg); +static lean_obj_res mk_pem_error(pem_source src, char const * msg, int errnum = 0) { + return src.is_file ? mk_ssl_file_error(src.obj, msg, errnum) : mk_ssl_invalid_argument(msg); } // Opens `src` for reading. On failure returns nullptr and stores an IO error in `*err`. static BIO * open_pem_bio(pem_source src, char const * unreadable, lean_obj_res * err) { if (src.is_file) { + // Captured here rather than recovered later by re-opening the path, which would both race + // and lose the distinction between an open failure and an unreadable file. + errno = 0; BIO * bio = BIO_new_file(src.data(), "r"); - if (bio == nullptr) *err = mk_ssl_file_error(src.obj, unreadable); + if (bio == nullptr) *err = mk_ssl_file_error(src.obj, unreadable, errno); return bio; } @@ -116,11 +110,9 @@ static bool rejected_by_security_level() { reason == SSL_R_CA_MD_TOO_WEAK; } -lean_object * mk_openssl_error(char const * where, int ssl_err) { +lean_object * mk_openssl_error(char const * where) { std::string msg(where); - if (ssl_err != 0) msg += " (ssl_error=" + std::to_string(ssl_err) + ")"; - for (int i = 0; i < 10; i++) { unsigned long err = ERR_get_error(); if (err == 0) break; @@ -157,10 +149,6 @@ static void configure_ctx_options(SSL_CTX * ctx) { // No effect on TLS 1.3, which replaced renegotiation with key updates. SSL_OP_NO_RENEGOTIATION | - // Mitigates CRIME, where compression leaks secret bytes via ciphertext length. Already the - // default since OpenSSL 1.1, but set explicitly so the intent is clear. - SSL_OP_NO_COMPRESSION | - // Disables RFC 5077 session tickets in TLS 1.2. In TLS 1.3 it only downgrades them to the // stateful form; the call below is what stops those being sent. SSL_OP_NO_TICKET @@ -193,11 +181,6 @@ static void configure_ctx_options(SSL_CTX * ctx) { static ssl_ctx_ptr mk_ssl_ctx_base(const SSL_METHOD * method, lean_obj_res * err) { ERR_clear_error(); - if (!ensure_openssl_initialized()) { - *err = mk_openssl_io_error("OPENSSL_init_ssl failed"); - return nullptr; - } - ssl_ctx_ptr ctx(SSL_CTX_new(method)); if (ctx == nullptr) { @@ -306,10 +289,8 @@ static lean_obj_res load_server_credentials(SSL_CTX * ctx, pem_source cert, pem_ return nullptr; } -/* Std.Internal.SSL.Context.Server.mkImpl (cert : @& String) (certIsFile : Bool) - (key : @& String) (keyIsFile : Bool) : IO Context.Server */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert, uint8_t cert_is_file, - b_obj_arg key, uint8_t key_is_file) { +static lean_obj_res mk_server_ctx(b_obj_arg cert, uint8_t cert_is_file, b_obj_arg key, + uint8_t key_is_file) { pem_source cert_src{cert, cert_is_file != 0}; pem_source key_src{key, key_is_file != 0}; @@ -336,14 +317,12 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert, uint8 } // Adds every certificate `src` yields to the trust store, on top of whatever it already holds. -static lean_obj_res load_ca_bundle(SSL_CTX * ctx, pem_source src) { - char const * unreadable = src.is_file - ? "could not read PEM CA certificates" - : "could not read PEM CA certificates from the given string"; +// With `require_self_signed`, the material must also hold a certificate a chain can terminate at. +static lean_obj_res load_ca_bundle(SSL_CTX * ctx, pem_source src, bool require_self_signed) { + ERR_clear_error(); - char const * no_certs = src.is_file - ? "the CA file contains no certificates" - : "the given CA PEM string contains no certificates"; + char const * unreadable = "could not read PEM CA certificates"; + char const * no_certs = "the CA material contains no certificates"; lean_obj_res err = nullptr; BIO * bio = open_pem_bio(src, unreadable, &err); @@ -357,6 +336,7 @@ static lean_obj_res load_ca_bundle(SSL_CTX * ctx, pem_source src) { X509_STORE * store = SSL_CTX_get_cert_store(ctx); int cert_count = 0; + bool any_self_signed = false; for (int i = 0, n = sk_X509_INFO_num(infos); i < n; i++) { // A bundle may hold private keys and CRLs; only certificates are anchors. @@ -365,6 +345,10 @@ static lean_obj_res load_ca_bundle(SSL_CTX * ctx, pem_source src) { if (cert == nullptr) continue; cert_count++; + // `EXFLAG_SS` is the same notion of self-signed that chain building terminates on. A bundle + // pairing a root with the intermediates below it therefore passes on the strength of the root. + if ((X509_get_extension_flags(cert) & EXFLAG_SS) != 0) any_self_signed = true; + if (X509_STORE_add_cert(store, cert) != 1) { err = mk_openssl_io_error("X509_STORE_add_cert failed"); break; @@ -376,6 +360,12 @@ static lean_obj_res load_ca_bundle(SSL_CTX * ctx, pem_source src) { if (err != nullptr) return err; if (cert_count == 0) return mk_pem_error(src, no_certs); + if (require_self_signed && !any_self_signed) { + return mk_pem_error(src, + "the CA material holds no self-signed certificate, so no chain can terminate in it " + "(supply the root, or allow partial chains to anchor at an intermediate)"); + } + return nullptr; } @@ -383,8 +373,8 @@ static lean_obj_res load_ca_bundle(SSL_CTX * ctx, pem_source src) { // platform anchors would leave nothing behind. `load_ca_bundle` is what enforces that supplied // material actually yields a certificate, so the two together guarantee a verifying context has an // anchor. -static lean_obj_res mk_client_ctx(uint8_t verify_peer, uint8_t trust_system_roots, bool has_ca, - pem_source ca) { +static lean_obj_res mk_client_ctx(uint8_t verify_peer, uint8_t trust_system_roots, + uint8_t allow_partial_chain, bool has_ca, pem_source ca) { if (verify_peer && !trust_system_roots && !has_ca) { return mk_ssl_invalid_argument( "no trust anchors: peer verification is on, the platform trust anchors are excluded, " @@ -401,6 +391,12 @@ static lean_obj_res mk_client_ctx(uint8_t verify_peer, uint8_t trust_system_root return wrap_ssl_context(std::move(ctx)); } + if (allow_partial_chain) { + // Lets chain building stop at any certificate in the store rather than only at a self-signed + // one, which is what anchoring on an intermediate requires. + X509_VERIFY_PARAM_set_flags(SSL_CTX_get0_param(ctx.get()), X509_V_FLAG_PARTIAL_CHAIN); + } + if (trust_system_roots) { std::string detail; @@ -415,18 +411,20 @@ static lean_obj_res mk_client_ctx(uint8_t verify_peer, uint8_t trust_system_root // The caller's own CAs are added to whatever the store already holds: on top of the platform // anchors, or into an otherwise empty store when those were excluded. if (has_ca) { - if (lean_obj_res ca_err = load_ca_bundle(ctx.get(), ca)) return ca_err; + // An anchor that cannot terminate a chain is only a dead configuration when it is the sole + // source of anchors; alongside the platform roots it is merely redundant. + bool require_self_signed = !allow_partial_chain && !trust_system_roots; + + if (lean_obj_res ca_err = load_ca_bundle(ctx.get(), ca, require_self_signed)) return ca_err; } SSL_CTX_set_verify(ctx.get(), SSL_VERIFY_PEER, nullptr); return wrap_ssl_context(std::move(ctx)); } -/* Std.Internal.SSL.Context.Client.mkImpl (ca : @& String) (caIsFile hasCA verifyPeer - trustSystemRoots : Bool) : IO Context.Client */ -extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca, uint8_t ca_is_file, - uint8_t has_ca, uint8_t verify_peer, - uint8_t trust_system_roots) { +static lean_obj_res mk_client_ctx_checked(b_obj_arg ca, uint8_t ca_is_file, uint8_t has_ca, + uint8_t verify_peer, uint8_t trust_system_roots, + uint8_t allow_partial_chain) { pem_source ca_src{ca, ca_is_file != 0}; // Checked before `verifyPeer` is consulted, so a path that could never be opened is reported as @@ -435,7 +433,38 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca, uint8_t if (lean_obj_res err = reject_embedded_nul(ca)) return err; } - return mk_client_ctx(verify_peer, trust_system_roots, has_ca != 0, ca_src); + return mk_client_ctx(verify_peer, trust_system_roots, allow_partial_chain, has_ca != 0, ca_src); +} + +// Runs a constructor behind the two guards every entry point needs: OpenSSL initialized before any +// `ERR_*` call can register `atexit(OPENSSL_cleanup)` behind `OPENSSL_INIT_NO_ATEXIT`'s back, and no +// C++ exception escaping into Lean-generated code. +template +static lean_obj_res ssl_entry_point(F && build) { + try { + if (!ensure_openssl_initialized()) { + return lean_io_result_mk_error(lean_mk_io_user_error( + mk_string("OPENSSL_init_ssl failed"))); + } + + return build(); + } catch (std::exception & ex) { + return lean_io_result_mk_error(lean_mk_io_user_error(mk_string(ex.what()))); + } +} + +/* Std.Internal.SSL.Context.Server.mkImpl (cert : @& String) (certIsFile : Bool) + (key : @& String) (keyIsFile : Bool) : IO Context.Server */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert, uint8_t cert_is_file, b_obj_arg key, uint8_t key_is_file) { + return ssl_entry_point([&] { return mk_server_ctx(cert, cert_is_file, key, key_is_file); }); +} + +/* Std.Internal.SSL.Context.Client.mkImpl (ca : @& String) (caIsFile hasCA verifyPeer + trustSystemRoots allowPartialChain : Bool) : IO Context.Client */ +extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca, uint8_t ca_is_file, uint8_t has_ca, uint8_t verify_peer, uint8_t trust_system_roots, uint8_t allow_partial_chain) { + return ssl_entry_point([&] { + return mk_client_ctx_checked(ca, ca_is_file, has_ca, verify_peer, trust_system_roots, allow_partial_chain); + }); } #else @@ -448,7 +477,8 @@ extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg /*cert*/, } extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg /*ca*/, uint8_t /*ca_is_file*/, - uint8_t /*has_ca*/, uint8_t /*verify_peer*/, uint8_t /*trust_system_roots*/) { + uint8_t /*has_ca*/, uint8_t /*verify_peer*/, uint8_t /*trust_system_roots*/, + uint8_t /*allow_partial_chain*/) { lean_always_assert(false && "Please build a version of Lean4 with OpenSSL to invoke this."); } diff --git a/src/runtime/openssl/context.h b/src/runtime/openssl/context.h index 98f8877a809f..27c987fe2f2a 100644 --- a/src/runtime/openssl/context.h +++ b/src/runtime/openssl/context.h @@ -22,8 +22,8 @@ void initialize_openssl_context(); #ifndef LEAN_EMSCRIPTEN // Drains the OpenSSL error queue and returns a single error message combining up to 10 entries. -lean_object * mk_openssl_error(char const * where, int ssl_err = 0); -inline lean_obj_res mk_openssl_io_error(char const * where, int ssl_err = 0) { return lean_io_result_mk_error(mk_openssl_error(where, ssl_err)); } +lean_object * mk_openssl_error(char const * where); +inline lean_obj_res mk_openssl_io_error(char const * where) { return lean_io_result_mk_error(mk_openssl_error(where)); } inline lean_object * lean_ssl_context_new(SSL_CTX * ctx) { return lean_alloc_external(g_ssl_context_external_class, ctx); } inline SSL_CTX * lean_to_ssl_context(lean_object * o) { return (SSL_CTX*)lean_get_external_data(o); } #endif @@ -34,6 +34,6 @@ inline SSL_CTX * lean_to_ssl_context(lean_object * o) { return (SSL_CTX*)lean_ge extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_server(b_obj_arg cert, uint8_t cert_is_file, b_obj_arg key, uint8_t key_is_file); extern "C" LEAN_EXPORT lean_obj_res lean_ssl_ctx_mk_client(b_obj_arg ca, uint8_t ca_is_file, - uint8_t has_ca, uint8_t verify_peer, uint8_t trust_system_roots); + uint8_t has_ca, uint8_t verify_peer, uint8_t trust_system_roots, uint8_t allow_partial_chain); } diff --git a/src/runtime/openssl/trust_store.cpp b/src/runtime/openssl/trust_store.cpp index 76fbe0b26349..4369be4b6356 100644 --- a/src/runtime/openssl/trust_store.cpp +++ b/src/runtime/openssl/trust_store.cpp @@ -126,10 +126,13 @@ enum class trust_setting { unspecified, trusted, denied }; static trust_setting tls_trust_setting(SecCertificateRef cert, SecTrustSettingsDomain domain) { CFArrayRef settings = nullptr; - if (SecTrustSettingsCopyTrustSettings(cert, domain, &settings) != errSecSuccess || settings == nullptr) { + if (SecTrustSettingsCopyTrustSettings(cert, domain, &settings) != errSecSuccess) { + if (settings != nullptr) CFRelease(settings); return trust_setting::unspecified; } + if (settings == nullptr) return trust_setting::unspecified; + // An empty settings array is how Apple encodes unconditional trust. CFIndex count = CFArrayGetCount(settings); trust_setting result = count == 0 ? trust_setting::trusted : trust_setting::unspecified; diff --git a/tests/elab/async_ssl_certs/README.md b/tests/elab/async_ssl_certs/README.md index 34bc82eace37..b0002b0c8a02 100644 --- a/tests/elab/async_ssl_certs/README.md +++ b/tests/elab/async_ssl_certs/README.md @@ -1,6 +1,6 @@ # TLS test certificate fixtures -Self-signed certificates used by the `async_ssl_*` tests. These contain **no secrets**: the +Certificate fixtures used by the `async_ssl_*` tests, self-signed but for `intermediate.pem`. These contain **no secrets**: the private key exists only so the tests can drive a real TLS handshake, and nothing outside the test suite trusts these certificates. They are committed as fixtures (instead of generated at test time) so the tests neither shell out to the `openssl` CLI nor depend on it being @@ -8,8 +8,8 @@ installed — subprocess spawning in these tests also produced spurious LeakSani in the sanitizer CI build. All certificates are signed by `key.pem` (RSA-2048) and are valid until 2126, with two exceptions: -`expired.pem`, whose validity window is entirely in 2020 (used to verify that expired certificates -are rejected), and `weakcert.pem`, which is self-signed under a throwaway 512-bit key that is not +`expired.pem`, whose validity window is entirely in 2020 (building a context parses a certificate +without checking its validity period, so this one is rejected only at handshake time), and `weakcert.pem`, which is self-signed under a throwaway 512-bit key that is not kept. | file | subject | notes | @@ -27,6 +27,7 @@ kept. | `expired.pem` | `CN=localhost` | valid 2020-01-01 → 2020-01-02 only | | `corrupt.pem` | | `cert.pem` with one bit flipped in the first DER byte (`SEQUENCE` tag → `SET`) | | `weakcert.pem` | `CN=localhost` | self-signed under a 512-bit RSA key; parses perfectly but is below every security level a build may default to, so it is refused on policy grounds rather than as unreadable PEM | +| `intermediate.pem` | `CN=Test Intermediate CA` | a CA signed by `cert.pem` rather than by itself, so no chain can terminate at it; the only fixture whose issuer differs from its subject | | `crl.pem` | | a CRL issued by `cert.pem`; the non-certificate bundle entry that is *not* a private key, so it is what distinguishes "holds no certificates" from "could not be read" | `corrupt.pem` still has intact PEM armour and valid base64 — it differs from `cert.pem` by a single @@ -55,6 +56,10 @@ openssl rsa -in key.pem -traditional -out tradkey.pem # sit exactly on security level 1's floor, making the test depend on which level the build defaults to. openssl req -x509 -newkey rsa:512 -keyout weakkey.pem -out weakcert.pem -days 36500 -nodes \ -subj "/CN=localhost" && rm weakkey.pem +openssl req -new -key key2.pem -out inter.csr -subj "/CN=Test Intermediate CA" +openssl x509 -req -in inter.csr -CA cert.pem -CAkey key.pem -set_serial 42 -days 36500 \ + -extfile <(printf 'basicConstraints=critical,CA:TRUE\nkeyUsage=critical,keyCertSign,cRLSign\n') \ + -out intermediate.pem && rm inter.csr mkdir -p ca/newcerts && touch ca/index.txt && echo 01 > ca/crlnumber printf '[ca]\ndefault_ca=CA_default\n[CA_default]\ndatabase=./ca/index.txt\ncrlnumber=./ca/crlnumber\ndefault_md=sha256\ndefault_crl_days=36500\n' > ca/openssl.cnf openssl ca -config ca/openssl.cnf -gencrl -cert cert.pem -keyfile key.pem -out crl.pem && rm -r ca diff --git a/tests/elab/async_ssl_certs/intermediate.pem b/tests/elab/async_ssl_certs/intermediate.pem new file mode 100644 index 000000000000..18a207dd905c --- /dev/null +++ b/tests/elab/async_ssl_certs/intermediate.pem @@ -0,0 +1,19 @@ +-----BEGIN CERTIFICATE----- +MIIDEzCCAfugAwIBAgIBKjANBgkqhkiG9w0BAQsFADAUMRIwEAYDVQQDDAlsb2Nh +bGhvc3QwIBcNMjYwODMxMjIxMjI2WhgPMjEyNjA4MDcyMjEyMjZaMB8xHTAbBgNV +BAMMFFRlc3QgSW50ZXJtZWRpYXRlIENBMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8A +MIIBCgKCAQEA16dHSIlSMRr18CnOIL6pJ1d/a9JPwAhIvdN7IrjQ4h5TNgSbWdEU +jTthMmc/rFClIibDT1QUkUEK7t3cMLdi4PCUmN/90XLP74LKxwf3xkRRh4BxYI/v +l19gccJ8sEOwYMLY0zTXTqw3hDuoKCWK4H3P7wTIDCR/qNXZxsHZFFg+/2W6WTO8 +CDwg4S507sp3KDB/CFHTFuohqU8ruTTkEdK4zAd66sNCsg+svLk8D03Ffud8wH5h +PpEPp9qdsMZFhPX+dEQAkzI2nO2SkDMSN/5BKhVG1CBh1QRojNS8ulWeqEqP//Xt +up20YIIUZIh15MCWtDiX7AVyKi4kYjVxlwIDAQABo2MwYTAPBgNVHRMBAf8EBTAD +AQH/MA4GA1UdDwEB/wQEAwIBBjAdBgNVHQ4EFgQUc9NBEBgBrwKY62s1HJ8KeMMO +l48wHwYDVR0jBBgwFoAUWpvqssFt9BbEJYc1tkle3R7PejQwDQYJKoZIhvcNAQEL +BQADggEBAA96MyWfF/QvDD91iyrQQrf/tsHyXoNXw4SFVSHlRjGzomMp/z0F8TJy +2eQvcfEZAc5KfngJJqyG+Z1PlHso36Atm8TyRLX/yeN2pbrIY1NxbSvNc5lXOxRF +o6ji+ljm6G3MKB8YLIU8FwdTMw+WoHRjGeqHQVEbJr/neKe9Kvt/SKnH8i7yoRWC +OQktGusU8Z+lbdJ9JoaHGbbg2d+qFSCMuBb8efbEHMCzmBKfHlvK31Sm6q8wIGFe +2TjaiIdHEq1M5OGPUSmI93fZU83bROxCNnj27QRV8z9nkctqHeUF0F5Pdo8/r7mL +L6gm0xIk5duKa2Kp7P7hSq+IOceIAyw= +-----END CERTIFICATE----- diff --git a/tests/elab/async_ssl_context.lean b/tests/elab/async_ssl_context.lean index e2a10180053e..48367f11aea0 100644 --- a/tests/elab/async_ssl_context.lean +++ b/tests/elab/async_ssl_context.lean @@ -53,6 +53,10 @@ def testEncryptedCertPEM : String := include_cert% "async_ssl_certs/enccert.pem" -- the security level instead, which is a different failure from unreadable PEM. def testWeakCertPEM : String := include_cert% "async_ssl_certs/weakcert.pem" +-- Signed by `cert.pem` rather than by itself, so it is a CA that no chain can terminate at. It is +-- the only fixture here whose issuer differs from its subject. +def testIntermediateCertPEM : String := include_cert% "async_ssl_certs/intermediate.pem" + -- A CRL: the non-certificate bundle entry that is not a private key. It is what separates "this -- bundle holds no certificates" from "this bundle could not be read". def testCRLPEM : String := include_cert% "async_ssl_certs/crl.pem" @@ -60,84 +64,66 @@ def testCRLPEM : String := include_cert% "async_ssl_certs/crl.pem" -- Three distinct certificates in one file, the shape of a real CA bundle. def testBundlePEM : String := testCertPEM ++ testWildcardCertPEM ++ testMultiSANCertPEM --- Writes the embedded certificate and key to a temporary directory, for the `PEM.file` cases. -def setupTestCerts : IO (String × String) := do - let dir ← IO.FS.createTempDir - let keyFile := toString (dir / "key.pem") - let certFile := toString (dir / "cert.pem") - IO.FS.writeFile keyFile testKeyPEM - IO.FS.writeFile certFile testCertPEM - return (certFile, keyFile) - --- Context creation and configuration (smoke test). -def testContextCreation (certFile keyFile : String) : IO Unit := do - let _serverCtx ← Context.Server.mk { cert := .file certFile, key := .file keyFile } - - -- Empty CA with `verifyPeer := false` disables verification without parsing any CA material. - let _clientCtx ← Context.Client.mk { verifyPeer := false } - - -- Non-empty CA file with `verifyPeer := true` exercises the additive trust path: the system - -- roots plus the supplied CA. - let _clientCtx2 ← Context.Client.mk { ca := some (.file certFile) } - - -- A non-empty CA path with `verifyPeer := false` is accepted, but the CA file is not parsed. - let _clientCtx3 ← Context.Client.mk { ca := some (.file certFile), verifyPeer := false } - - -- Defaults: no CA file, peer verification against the system trust anchors. - let _clientCtx4 ← Context.Client.mk - --- Creating a client from an in-memory PEM string. -def testMkClientFromPEM (certFile : String) : IO Unit := do - let caPEM ← IO.FS.readFile certFile - let _clientCtx ← Context.Client.mk { ca := some (.text caPEM) } - --- Materializes rejected input on disk, for the `PEM.file` cases. -def writeTempFile (name contents : String) : IO String := do - let dir ← IO.FS.createTempDir - let path := toString (dir / name) - IO.FS.writeFile path contents - return path - -def setupMalformedFile : IO String := writeTempFile "junk.pem" "this is not pem\n" - -def setupCorruptCert : IO String := writeTempFile "corrupt.pem" testCorruptCertPEM - -def setupUnrelatedKey : IO String := writeTempFile "key2.pem" testUnrelatedKeyPEM - -def setupECKey : IO String := writeTempFile "eckey.pem" testECKeyPEM - -def setupEncryptedKey : IO String := writeTempFile "enckey.pem" testEncryptedKeyPEM - -def setupEmptyPassphraseKey : IO String := writeTempFile "emptypwkey.pem" testEmptyPassphraseKeyPEM - -def setupBundle : IO String := writeTempFile "bundle.pem" testBundlePEM - -def setupDuplicateBundle : IO String := writeTempFile "dup.pem" (testBundlePEM ++ testCertPEM) - -def setupEncryptedCert : IO String := writeTempFile "enccert.pem" testEncryptedCertPEM - -def setupExpiredCert : IO String := writeTempFile "expired.pem" testExpiredCertPEM - -def setupWeakCert : IO String := writeTempFile "weak.pem" testWeakCertPEM - -def setupCRL : IO String := writeTempFile "crl.pem" testCRLPEM - -def setupEmptyFile : IO String := writeTempFile "empty.pem" "" - -def setupDirectory : IO String := return toString (← IO.FS.createTempDir) - --- A valid leaf followed by a corrupt second certificate, i.e. a chain whose *intermediate* is bad. -def setupCorruptChain : IO String := writeTempFile "chain.pem" (testCertPEM ++ testCorruptCertPEM) - -def setupUnreadableFile : IO String := do - let path ← writeTempFile "secret.pem" testCertPEM - IO.setAccessRights path { user := { read := false, write := false, execution := false } } - return path +/-! +Every file the `PEM.file` cases need, written once into one temporary directory. The in-memory +constants above are the same material; a fixture exists only where a test needs a *path*. +-/ --- A path that treats a regular file as if it were a directory, which the OS refuses with ENOTDIR. -def setupNonDirectoryParent : IO String := do - let path ← writeTempFile "notadir.pem" testCertPEM - return toString (System.FilePath.mk path / "ca.pem") +structure Fixtures where + cert : String + key : String + /-- Matches no certificate here, so pairing it with `cert` is a key/certificate mismatch. -/ + unrelatedKey : String + ecKey : String + encKey : String + emptyPwKey : String + encCert : String + expired : String + weak : String + intermediate : String + /-- Text with no PEM armour at all. -/ + junk : String + corrupt : String + /-- A valid leaf followed by a corrupt second certificate: a chain whose *intermediate* is bad. -/ + chain : String + empty : String + dir : String + unreadable : String + /-- A path that treats a regular file as if it were a directory, which the OS refuses. -/ + nonDirParent : String + +def mkFixtures : IO Fixtures := do + let root ← IO.FS.createTempDir + + let write (name contents : String) : IO String := do + let path := toString (root / name) + IO.FS.writeFile path contents + return path + + let cert ← write "cert.pem" testCertPEM + let key ← write "key.pem" testKeyPEM + let unrelatedKey ← write "key2.pem" testUnrelatedKeyPEM + let ecKey ← write "eckey.pem" testECKeyPEM + let encKey ← write "enckey.pem" testEncryptedKeyPEM + let emptyPwKey ← write "emptypwkey.pem" testEmptyPassphraseKeyPEM + let encCert ← write "enccert.pem" testEncryptedCertPEM + let expired ← write "expired.pem" testExpiredCertPEM + let weak ← write "weak.pem" testWeakCertPEM + let intermediate ← write "intermediate.pem" testIntermediateCertPEM + let junk ← write "junk.pem" "this is not pem\n" + let corrupt ← write "corrupt.pem" testCorruptCertPEM + let chain ← write "chain.pem" (testCertPEM ++ testCorruptCertPEM) + let empty ← write "empty.pem" "" + + let dir := toString (root / "subdir") + IO.FS.createDir dir + + let unreadable ← write "secret.pem" testCertPEM + IO.setAccessRights unreadable { user := { read := false, write := false, execution := false } } + + return { cert, key, unrelatedKey, ecKey, encKey, emptyPwKey, encCert, expired, weak, + intermediate, junk, corrupt, chain, empty, dir, unreadable, + nonDirParent := toString (System.FilePath.mk cert / "ca.pem") } -- Asserts that an IO action fails with exactly `expected` as its message. def assertErrorMessage (label expected : String) (act : IO Unit) : IO Unit := do @@ -177,7 +163,40 @@ def nulByteError (path : String) : String := def malformedPEMError (detail : String) : String := s!"invalid argument (error code: 22, {detail})" --- An empty CA bundle with `verifyPeer := true` falls back to the platform trust anchors and succeeds. +/-! +The CA loader reports one message per failure regardless of where the material came from: the +`file:` field the error already carries is what says which source it was. +-/ + +def caUnreadable : String := "could not read PEM CA certificates" + +def caNoCerts : String := "the CA material contains no certificates" + +def caNoSelfSigned : String := + "the CA material holds no self-signed certificate, so no chain can terminate in it (supply the \ + root, or allow partial chains to anchor at an intermediate)" + +-- Context creation and configuration (smoke test). +def testContextCreation (f : Fixtures) : IO Unit := do + let _serverCtx ← Context.Server.mk { cert := .file f.cert, key := .file f.key } + + -- Empty CA with `verifyPeer := false` disables verification without parsing any CA material. + let _clientCtx ← Context.Client.mk { verifyPeer := false } + + -- Non-empty CA file with `verifyPeer := true` exercises the additive trust path: the system + -- roots plus the supplied CA. + let _clientCtx2 ← Context.Client.mk { ca := some (.file f.cert) } + + -- A non-empty CA path with `verifyPeer := false` is accepted, but the CA file is not parsed. + let _clientCtx3 ← Context.Client.mk { ca := some (.file f.cert), verifyPeer := false } + + -- Defaults: no CA file, peer verification against the system trust anchors. + let _clientCtx4 ← Context.Client.mk + + -- The same anchors supplied in memory rather than by path. + let _clientCtx5 ← Context.Client.mk { ca := some (.text testCertPEM) } + +-- An absent CA with `verifyPeer := true` falls back to the platform trust anchors and succeeds. def testMkFromPEMEmptyFallsBack : IO Unit := do let _clientCtx ← Context.Client.mk {} @@ -192,8 +211,8 @@ def noAnchorsError : String := malformedPEMError "no trust anchors: peer verification is on, the platform trust anchors are \ excluded, and no CA certificate was given" -def testPinnedToSuppliedCA (certFile : String) : IO Unit := do - let _clientCtx ← Context.Client.mk { ca := some (.file certFile), trustSystemRoots := false } +def testPinnedToSuppliedCA (f : Fixtures) : IO Unit := do + let _clientCtx ← Context.Client.mk { ca := some (.file f.cert), trustSystemRoots := false } let _clientCtx2 ← Context.Client.mk { ca := some (.text testCertPEM), trustSystemRoots := false } let _clientCtx3 ← Context.Client.mk { ca := some (.text testBundlePEM), trustSystemRoots := false } @@ -205,10 +224,54 @@ def testPinningRejectsEmptyCA : IO Unit := do -- certificate rather than an absent one. That is a different diagnosis from the case above, and the -- more specific of the two. def testPinningRejectsEmptyCAMaterial : IO Unit := do - assertErrorMessage "pinned to an empty CA string" - (malformedPEMError "the given CA PEM string contains no certificates") + assertErrorMessage "pinned to an empty CA string" (malformedPEMError caNoCerts) (discard <| Context.Client.mk { ca := some (.text ""), trustSystemRoots := false }) +/-! +A trust anchor has to be a certificate chain building can terminate at, which by default means a +self-signed one. Pinning to nothing but intermediates therefore describes a context that could never +verify anything; `allowPartialChain` is what makes it verify, and without it the configuration is +refused where the mistake is rather than at every handshake. +-/ + +def testPinningRejectsIntermediateOnly (f : Fixtures) : IO Unit := do + assertErrorMessage "pinned to an intermediate PEM" (malformedPEMError caNoSelfSigned) + (discard <| Context.Client.mk + { ca := some (.text testIntermediateCertPEM), trustSystemRoots := false }) + + assertErrorMessage "pinned to an intermediate CA file" + (malformedFileError f.intermediate caNoSelfSigned) + (discard <| Context.Client.mk { ca := some (.file f.intermediate), trustSystemRoots := false }) + +-- `allowPartialChain` is the opt-in that makes an intermediate anchor a chain, so the same material +-- is accepted once it is set. +def testPinningToIntermediateWithPartialChain (f : Fixtures) : IO Unit := do + let _clientCtx ← Context.Client.mk + { ca := some (.text testIntermediateCertPEM), trustSystemRoots := false, + allowPartialChain := true } + + let _clientCtx2 ← Context.Client.mk + { ca := some (.file f.intermediate), trustSystemRoots := false, allowPartialChain := true } + +-- A bundle pairing the root with the intermediates beneath it terminates at the root, so the order +-- the two appear in does not matter. +def testPinningAcceptsRootWithIntermediate : IO Unit := do + let _clientCtx ← Context.Client.mk + { ca := some (.text (testIntermediateCertPEM ++ testCertPEM)), trustSystemRoots := false } + + let _clientCtx2 ← Context.Client.mk + { ca := some (.text (testCertPEM ++ testIntermediateCertPEM)), trustSystemRoots := false } + +-- Alongside the platform anchors an intermediate is redundant rather than fatal, so the check fires +-- only where the supplied material is the sole source of anchors. +def testIntermediateAllowedBesideSystemRoots : IO Unit := do + let _clientCtx ← Context.Client.mk { ca := some (.text testIntermediateCertPEM) } + +-- With verification off nothing is anchored at all, so the check does not apply. +def testIntermediateIgnoredWithoutVerification : IO Unit := do + let _clientCtx ← Context.Client.mk + { ca := some (.text testIntermediateCertPEM), verifyPeer := false, trustSystemRoots := false } + -- With verification off there is no store to be empty, so excluding the platform anchors is not a -- contradiction and `trustSystemRoots` is simply ignored. def testPinningIgnoredWithoutVerification : IO Unit := do @@ -217,13 +280,11 @@ def testPinningIgnoredWithoutVerification : IO Unit := do -- Supplied CA material still has to yield a certificate. These reach the ordinary bundle-loading -- failures rather than the "no trust anchors" one, which is what pins the check to the *absence* of -- CA material rather than to it being unusable. -def testPinningStillValidatesCA (junkFile : String) : IO Unit := do - assertErrorMessage "pinned to a malformed CA file" - (malformedFileError junkFile "the CA file contains no certificates") - (discard <| Context.Client.mk { ca := some (.file junkFile), trustSystemRoots := false }) +def testPinningStillValidatesCA (f : Fixtures) : IO Unit := do + assertErrorMessage "pinned to a malformed CA file" (malformedFileError f.junk caNoCerts) + (discard <| Context.Client.mk { ca := some (.file f.junk), trustSystemRoots := false }) - assertErrorMessage "pinned to a CA string with no certificates" - (malformedPEMError "the given CA PEM string contains no certificates") + assertErrorMessage "pinned to a CA string with no certificates" (malformedPEMError caNoCerts) (discard <| Context.Client.mk { ca := some (.text "not a certificate at all"), trustSystemRoots := false }) @@ -236,329 +297,240 @@ def testPinningRejectsNulInCAFile : IO Unit := do /-! Server credentials may be supplied in memory rather than by path, for a certificate that comes from -a secret manager or is embedded in the binary. `PEM.text` reads with an explicit length, so unlike a -path it carries no NUL restriction; the failures it reports have no path to name. +a secret manager or is embedded in the binary. The two sources meet in a single loader as soon as +the material is open, so the cases below cover what is particular to `PEM.text`: no path to name in +a failure, and no NUL restriction. The diagnoses themselves are exercised through `PEM.file`. -/ -def testMkServerFromMemory : IO Unit := do +def testMkServerFromMemory (f : Fixtures) : IO Unit := do let _serverCtx ← Context.Server.mk { cert := .text testCertPEM, key := .text testKeyPEM } --- The two sources are independent, so a file certificate pairs with an in-memory key and back. -def testMkServerMixedSources (certFile keyFile : String) : IO Unit := do - let _serverCtx ← Context.Server.mk { cert := .file certFile, key := .text testKeyPEM } - let _serverCtx2 ← Context.Server.mk { cert := .text testCertPEM, key := .file keyFile } + -- The two sources are independent, so a file certificate pairs with an in-memory key and back. + let _serverCtx2 ← Context.Server.mk { cert := .file f.cert, key := .text testKeyPEM } + let _serverCtx3 ← Context.Server.mk { cert := .text testCertPEM, key := .file f.key } --- The whole chain is loaded from memory too, not just the leaf. -def testMkServerFromMemoryLoadsChain : IO Unit := do - let _serverCtx ← Context.Server.mk + -- The whole chain is loaded from memory too, not just the leaf. + let _serverCtx4 ← Context.Server.mk { cert := .text (testCertPEM ++ testWildcardCertPEM), key := .text testKeyPEM } - assertErrorMessage "corrupt intermediate in an in-memory chain" - (malformedPEMError "could not read a PEM certificate chain") - (discard <| Context.Server.mk - { cert := .text (testCertPEM ++ testCorruptCertPEM), key := .text testKeyPEM }) - -- In-memory failures report the same diagnoses as the path-based ones, without a path attached. +-- One unreadable case and one mismatch case pin both error shapes. def testMkServerFromMemoryErrors : IO Unit := do assertErrorMessage "malformed in-memory certificate" (malformedPEMError "could not read a PEM certificate chain") (discard <| Context.Server.mk { cert := .text "this is not pem\n", key := .text testKeyPEM }) - assertErrorMessage "malformed in-memory key" - (malformedPEMError "could not read an unencrypted PEM private key") - (discard <| Context.Server.mk { cert := .text testCertPEM, key := .text "this is not pem\n" }) - assertErrorMessage "mismatched in-memory key" (malformedPEMError "the private key does not match the certificate") (discard <| Context.Server.mk { cert := .text testCertPEM, key := .text testUnrelatedKeyPEM }) - assertErrorMessage "cross-algorithm in-memory key" - (malformedPEMError "the private key does not match the certificate") - (discard <| Context.Server.mk { cert := .text testCertPEM, key := .text testECKeyPEM }) - --- Encrypted material must be refused without prompting here too, which is the failure mode that --- hangs rather than fails loudly. -def testMkServerFromMemoryRejectsEncrypted : IO Unit := do - assertErrorMessage "in-memory encrypted key" - (malformedPEMError "could not read an unencrypted PEM private key") - (discard <| Context.Server.mk { cert := .text testCertPEM, key := .text testEncryptedKeyPEM }) - - assertErrorMessage "in-memory empty-passphrase key" - (malformedPEMError "could not read an unencrypted PEM private key") - (discard <| Context.Server.mk - { cert := .text testCertPEM, key := .text testEmptyPassphraseKeyPEM }) - - assertErrorMessage "in-memory encrypted certificate" - (malformedPEMError "could not read a PEM certificate chain") - (discard <| Context.Server.mk { cert := .text testEncryptedCertPEM, key := .text testKeyPEM }) - -- A path cannot carry a NUL, but in-memory material is read with a length, so it can. def testMkServerFromMemoryAcceptsNul : IO Unit := do let _serverCtx ← Context.Server.mk { cert := .text (testCertPEM.push '\x00'), key := .text testKeyPEM } -- `verifyPeer := false` succeeds without parsing the CA material, even for a real bundle. -def testMkFromPEMNoVerify (certFile : String) : IO Unit := do - let caPEM ← IO.FS.readFile certFile - let _clientCtx ← Context.Client.mk { ca := some (.text caPEM), verifyPeer := false } +def testMkFromPEMNoVerify : IO Unit := do + let _clientCtx ← Context.Client.mk { ca := some (.text testBundlePEM), verifyPeer := false } -- A bundle of several distinct certificates is loaded in full: every certificate in the PEM becomes --- a trust anchor, not just the first one. +-- a trust anchor, not just the first one. Repeated certificates are skipped instead of failing, so a +-- bundle that overlaps the system trust anchors (or repeats itself) still yields a usable context. def testMkFromPEMAcceptsBundle : IO Unit := do let _clientCtx ← Context.Client.mk { ca := some (.text testBundlePEM) } - -def testMkAcceptsBundleFile (bundleFile : String) : IO Unit := do - let _clientCtx ← Context.Client.mk { ca := some (.file bundleFile) } - --- Repeated certificates are skipped instead of failing, so a bundle that overlaps the system trust --- anchors (or repeats itself) still yields a usable context. -def testMkFromPEMAcceptsDuplicates : IO Unit := do - let _clientCtx ← Context.Client.mk { ca := some (.text (testCertPEM ++ testCertPEM)) } - -def testMkAcceptsDuplicatesInFile (dupFile : String) : IO Unit := do - let _clientCtx ← Context.Client.mk { ca := some (.file dupFile) } + let _clientCtx2 ← Context.Client.mk { ca := some (.text (testBundlePEM ++ testCertPEM)) } -- Unlike `PEM.file`, `PEM.text` hands OpenSSL an explicit length rather than a C string, -- so a NUL byte is data (here: trailing junk after a complete certificate) and not an error. def testMkFromPEMAcceptsNulBytes : IO Unit := do let _clientCtx ← Context.Client.mk { ca := some (.text (testCertPEM.push '\x00')) } -def testMkFromPEMRejectsGarbage : IO Unit := do - assertErrorMessage "garbage PEM" - (malformedPEMError "the given CA PEM string contains no certificates") - (discard <| Context.Client.mk { ca := some (.text "not a certificate at all") }) - -def testMkNoVerifyIgnoresCorruptCAFile (corruptFile : String) : IO Unit := do - let _clientCtx ← Context.Client.mk { ca := some (.file corruptFile), verifyPeer := false } +def testMkNoVerifyIgnoresCorruptCAFile (f : Fixtures) : IO Unit := do + let _clientCtx ← Context.Client.mk { ca := some (.file f.corrupt), verifyPeer := false } def testMkFromPEMRejectsEmptyBlock : IO Unit := do - assertErrorMessage "PEM without certificates" - (malformedPEMError "could not read PEM CA certificates from the given string") + assertErrorMessage "PEM without certificates" (malformedPEMError caUnreadable) (discard <| Context.Client.mk { ca := some (.text "-----BEGIN CERTIFICATE-----\n-----END CERTIFICATE-----\n") }) -def testMkFromPEMRejectsCorruptCert : IO Unit := do - assertErrorMessage "one-bit-flipped CA PEM" - (malformedPEMError "could not read PEM CA certificates from the given string") - (discard <| Context.Client.mk { ca := some (.text testCorruptCertPEM) }) - -- Text with no PEM armour at all parses to an empty bundle rather than failing to parse, so it is --- reported as "no certificates" — the same way `PEM.text` reports the same bytes. -def testMkRejectsMalformedCAFile (junkFile : String) : IO Unit := do - assertErrorMessage "malformed CA file" - (malformedFileError junkFile "the CA file contains no certificates") - (discard <| Context.Client.mk { ca := some (.file junkFile) }) +-- reported as "no certificates" rather than as unreadable. +def testMkRejectsMalformedCAFile (f : Fixtures) : IO Unit := do + assertErrorMessage "malformed CA file" (malformedFileError f.junk caNoCerts) + (discard <| Context.Client.mk { ca := some (.file f.junk) }) -def testMkRejectsCorruptCAFile (corruptFile : String) : IO Unit := do - assertErrorMessage "one-bit-flipped CA file" - (malformedFileError corruptFile "could not read PEM CA certificates") - (discard <| Context.Client.mk { ca := some (.file corruptFile) }) +def testMkRejectsCorruptCAFile (f : Fixtures) : IO Unit := do + assertErrorMessage "one-bit-flipped CA file" (malformedFileError f.corrupt caUnreadable) + (discard <| Context.Client.mk { ca := some (.file f.corrupt) }) def testMkRejectsMissingCAFile : IO Unit := do assertErrorMessage "missing CA file" (missingFileError "/nonexistent/path/to/ca.pem") (discard <| Context.Client.mk { ca := some (.file "/nonexistent/path/to/ca.pem") }) -def testMkServerRejectsMissingCert (keyFile : String) : IO Unit := do +def testMkServerRejectsMissingFiles (f : Fixtures) : IO Unit := do assertErrorMessage "missing server cert" (missingFileError "/nonexistent/cert.pem") - (discard <| Context.Server.mk { cert := .file "/nonexistent/cert.pem", key := .file keyFile }) + (discard <| Context.Server.mk { cert := .file "/nonexistent/cert.pem", key := .file f.key }) -def testMkServerRejectsMissingKey (certFile : String) : IO Unit := do assertErrorMessage "missing server key" (missingFileError "/nonexistent/key.pem") - (discard <| Context.Server.mk { cert := .file certFile, key := .file "/nonexistent/key.pem" }) + (discard <| Context.Server.mk { cert := .file f.cert, key := .file "/nonexistent/key.pem" }) -def testMkServerRejectsMalformedKey (certFile junkFile : String) : IO Unit := do +def testMkServerRejectsMalformedKey (f : Fixtures) : IO Unit := do assertErrorMessage "malformed server key" - (malformedFileError junkFile "could not read an unencrypted PEM private key") - (discard <| Context.Server.mk { cert := .file certFile, key := .file junkFile }) + (malformedFileError f.junk "could not read an unencrypted PEM private key") + (discard <| Context.Server.mk { cert := .file f.cert, key := .file f.junk }) -def testMkServerRejectsCertAsKey (certFile : String) : IO Unit := do +def testMkServerRejectsCertAsKey (f : Fixtures) : IO Unit := do assertErrorMessage "certificate used as server key" - (malformedFileError certFile "could not read an unencrypted PEM private key") - (discard <| Context.Server.mk { cert := .file certFile, key := .file certFile }) + (malformedFileError f.cert "could not read an unencrypted PEM private key") + (discard <| Context.Server.mk { cert := .file f.cert, key := .file f.cert }) -def testMkServerRejectsMalformedCert (junkFile keyFile : String) : IO Unit := do +def testMkServerRejectsMalformedCert (f : Fixtures) : IO Unit := do assertErrorMessage "malformed server cert" - (malformedFileError junkFile "could not read a PEM certificate chain") - (discard <| Context.Server.mk { cert := .file junkFile, key := .file keyFile }) + (malformedFileError f.junk "could not read a PEM certificate chain") + (discard <| Context.Server.mk { cert := .file f.junk, key := .file f.key }) -def testMkServerRejectsCorruptCert (corruptFile keyFile : String) : IO Unit := do +def testMkServerRejectsCorruptCert (f : Fixtures) : IO Unit := do assertErrorMessage "one-bit-flipped server cert" - (malformedFileError corruptFile "could not read a PEM certificate chain") - (discard <| Context.Server.mk { cert := .file corruptFile, key := .file keyFile }) + (malformedFileError f.corrupt "could not read a PEM certificate chain") + (discard <| Context.Server.mk { cert := .file f.corrupt, key := .file f.key }) -def testMkServerRejectsSwappedFiles (certFile keyFile : String) : IO Unit := do +def testMkServerRejectsSwappedFiles (f : Fixtures) : IO Unit := do assertErrorMessage "swapped server cert/key" - (malformedFileError keyFile "could not read a PEM certificate chain") - (discard <| Context.Server.mk { cert := .file keyFile, key := .file certFile }) + (malformedFileError f.key "could not read a PEM certificate chain") + (discard <| Context.Server.mk { cert := .file f.key, key := .file f.cert }) -def testMkServerRejectsMismatchedKey (certFile key2File : String) : IO Unit := do +def testMkServerRejectsMismatchedKey (f : Fixtures) : IO Unit := do assertErrorMessage "server key from a different pair" - (malformedFileError key2File "the private key does not match the certificate") - (discard <| Context.Server.mk { cert := .file certFile, key := .file key2File }) + (malformedFileError f.unrelatedKey "the private key does not match the certificate") + (discard <| Context.Server.mk { cert := .file f.cert, key := .file f.unrelatedKey }) -- A key of a different algorithm than the certificate lands in an unused slot of the context, so --- `SSL_CTX_use_PrivateKey_file` accepts it without ever comparing the two; only the separate +-- `SSL_CTX_use_PrivateKey` accepts it without ever comparing the two; only the separate -- `SSL_CTX_check_private_key` rejects it. -def testMkServerRejectsCrossAlgorithmKey (certFile ecKeyFile : String) : IO Unit := do +def testMkServerRejectsCrossAlgorithmKey (f : Fixtures) : IO Unit := do assertErrorMessage "EC server key against an RSA certificate" - (malformedFileError ecKeyFile "the private key does not match the certificate") - (discard <| Context.Server.mk { cert := .file certFile, key := .file ecKeyFile }) + (malformedFileError f.ecKey "the private key does not match the certificate") + (discard <| Context.Server.mk { cert := .file f.cert, key := .file f.ecKey }) --- Encrypted keys are unsupported. The point of this test is as much the absence of output as the --- error itself: with no password callback installed OpenSSL prompts for the passphrase on the --- terminal, which blocks when one is attached and pollutes the test output when one is not. -def testMkServerRejectsEncryptedKey (certFile encKeyFile : String) : IO Unit := do +/-! +Encrypted PEM material must be rejected outright. A passphrase callback reporting failure is what +prevents OpenSSL falling back to its own callback, which prompts on `/dev/tty` and blocks forever — +a hang that no amount of redirecting stdin escapes. The point of these tests is as much the absence +of output as the error itself. An encrypted *certificate* is decrypted in place while the bundle is +read, so it reaches the callback through a different path than a key does, in each constructor. +-/ + +def testRejectsEncryptedMaterial (f : Fixtures) : IO Unit := do assertErrorMessage "passphrase-protected server key" - (malformedFileError encKeyFile "could not read an unencrypted PEM private key") - (discard <| Context.Server.mk { cert := .file certFile, key := .file encKeyFile }) + (malformedFileError f.encKey "could not read an unencrypted PEM private key") + (discard <| Context.Server.mk { cert := .file f.cert, key := .file f.encKey }) --- An empty passphrase still counts as encrypted. A password callback that reports a zero-length --- passphrase instead of a failure decrypts this key and accepts it. -def testMkServerRejectsEmptyPassphraseKey (certFile emptyPwKeyFile : String) : IO Unit := do + -- An empty passphrase still counts as encrypted. A password callback that reports a zero-length + -- passphrase instead of a failure decrypts this key and accepts it. assertErrorMessage "server key encrypted under an empty passphrase" - (malformedFileError emptyPwKeyFile "could not read an unencrypted PEM private key") - (discard <| Context.Server.mk { cert := .file certFile, key := .file emptyPwKeyFile }) + (malformedFileError f.emptyPwKey "could not read an unencrypted PEM private key") + (discard <| Context.Server.mk { cert := .file f.cert, key := .file f.emptyPwKey }) -def testMkServerRejectsNulInCert (keyFile : String) : IO Unit := do - let certPath := "cert\x00.pem" + assertErrorMessage "encrypted server certificate" + (malformedFileError f.encCert "could not read a PEM certificate chain") + (discard <| Context.Server.mk { cert := .file f.encCert, key := .file f.key }) + + assertErrorMessage "encrypted CA certificate file" + (malformedFileError f.encCert caUnreadable) + (discard <| Context.Client.mk { ca := some (.file f.encCert) }) - assertErrorMessage "NUL byte in server cert path" - (nulByteError certPath) - (discard <| Context.Server.mk { cert := .file certPath, key := .file keyFile }) + assertErrorMessage "in-memory encrypted key" + (malformedPEMError "could not read an unencrypted PEM private key") + (discard <| Context.Server.mk { cert := .text testCertPEM, key := .text testEncryptedKeyPEM }) -def testMkServerRejectsNulInKey (certFile : String) : IO Unit := do +def testRejectsNulInPaths (f : Fixtures) : IO Unit := do + let certPath := "cert\x00.pem" let keyPath := "key\x00.pem" + let caPath := "ca\x00.pem" - assertErrorMessage "NUL byte in server key path" - (nulByteError keyPath) - (discard <| Context.Server.mk { cert := .file certFile, key := .file keyPath }) + assertErrorMessage "NUL byte in server cert path" (nulByteError certPath) + (discard <| Context.Server.mk { cert := .file certPath, key := .file f.key }) --- The CA path is checked before `verifyPeer`, so a NUL is rejected even when the file would never --- have been opened. -def testMkRejectsNulInCAFile : IO Unit := do - let caPath := "ca\x00.pem" + assertErrorMessage "NUL byte in server key path" (nulByteError keyPath) + (discard <| Context.Server.mk { cert := .file f.cert, key := .file keyPath }) - assertErrorMessage "NUL byte in CA path" - (nulByteError caPath) + assertErrorMessage "NUL byte in CA path" (nulByteError caPath) (discard <| Context.Client.mk { ca := some (.file caPath) }) - assertErrorMessage "NUL byte in CA path without verification" - (nulByteError caPath) + -- The CA path is checked before `verifyPeer`, so a NUL is rejected even when the file would never + -- have been opened. + assertErrorMessage "NUL byte in CA path without verification" (nulByteError caPath) (discard <| Context.Client.mk { ca := some (.file caPath), verifyPeer := false }) /-! -Encrypted PEM material must be rejected outright. A passphrase callback reporting failure is what -prevents OpenSSL falling back to its own callback, which prompts on `/dev/tty` and blocks forever — -a hang that no amount of redirecting stdin escapes. `enckey.pem` and `emptypwkey.pem` cover the -private key; the tests here cover an encrypted *certificate*, which is read by a different code path -in each of the three constructors. +A CA bundle is required to contain at least one certificate. Material holding only non-certificate +entries parses without complaint and would leave the trust store silently unchanged, so the count is +checked explicitly. A *traditional* RSA key is the case that matters among those entries: it yields +a parsed entry carrying no certificate, unlike the PKCS#8 form which is dropped before that point. +A CRL is the other one. -/ -def testMkServerRejectsEncryptedCert (encCertFile keyFile : String) : IO Unit := do - assertErrorMessage "encrypted server certificate" - (malformedFileError encCertFile "could not read a PEM certificate chain") - (discard <| Context.Server.mk { cert := .file encCertFile, key := .file keyFile }) +def testMkRejectsCertlessCAFile (f : Fixtures) : IO Unit := do + assertErrorMessage "CA file holding only a private key" (malformedFileError f.key caNoCerts) + (discard <| Context.Client.mk { ca := some (.file f.key) }) -def testMkRejectsEncryptedCertCAFile (encCertFile : String) : IO Unit := do - assertErrorMessage "encrypted CA certificate file" - (malformedFileError encCertFile "could not read PEM CA certificates") - (discard <| Context.Client.mk { ca := some (.file encCertFile) }) - -def testMkFromPEMRejectsEncryptedCert : IO Unit := do - assertErrorMessage "encrypted CA certificate string" - (malformedPEMError "could not read PEM CA certificates from the given string") - (discard <| Context.Client.mk { ca := some (.text testEncryptedCertPEM) }) - --- A CA bundle is required to contain at least one certificate. A file holding only a key parses --- without complaint and would leave the trust store silently unchanged, so the count is checked --- explicitly. -def testMkRejectsCertlessCAFile (keyFile : String) : IO Unit := do - assertErrorMessage "CA file holding only a private key" - (malformedFileError keyFile "the CA file contains no certificates") - (discard <| Context.Client.mk { ca := some (.file keyFile) }) + -- A zero-byte file has no PEM armour to fail on, so it parses to an empty bundle too. + assertErrorMessage "zero-byte CA file" (malformedFileError f.empty caNoCerts) + (discard <| Context.Client.mk { ca := some (.file f.empty) }) def testMkFromPEMRejectsCertlessPEM : IO Unit := do - assertErrorMessage "CA string holding only a private key" - (malformedPEMError "the given CA PEM string contains no certificates") - (discard <| Context.Client.mk { ca := some (.text testKeyPEM) }) - --- Non-certificate entries in a bundle are skipped rather than rejected. A *traditional* RSA key is --- the case that matters: it yields a parsed entry carrying no certificate, unlike the PKCS#8 form --- which is dropped before that point. -def testMkFromPEMSkipsTraditionalKey : IO Unit := do + assertErrorMessage "traditional RSA key with no certificate" (malformedPEMError caNoCerts) + (discard <| Context.Client.mk { ca := some (.text testTraditionalKeyPEM) }) + + assertErrorMessage "CA string holding only a CRL" (malformedPEMError caNoCerts) + (discard <| Context.Client.mk { ca := some (.text testCRLPEM) }) + +-- Non-certificate entries alongside a certificate are skipped rather than rejected. +def testMkFromPEMSkipsNonCertificates : IO Unit := do let _clientCtx ← Context.Client.mk { ca := some (.text (testTraditionalKeyPEM ++ testCertPEM)) } let _clientCtx2 ← Context.Client.mk { ca := some (.text (testCertPEM ++ testTraditionalKeyPEM)) } - -def testMkFromPEMRejectsTraditionalKeyOnly : IO Unit := do - assertErrorMessage "traditional RSA key with no certificate" - (malformedPEMError "the given CA PEM string contains no certificates") - (discard <| Context.Client.mk { ca := some (.text testTraditionalKeyPEM) }) + let _clientCtx3 ← Context.Client.mk { ca := some (.text (testCRLPEM ++ testCertPEM)) } + let _clientCtx4 ← Context.Client.mk { ca := some (.text (testCertPEM ++ testCRLPEM)) } /-! `PEM.text` hands OpenSSL an explicit length rather than a C string, so a NUL does not truncate the input. It is still junk to the PEM parser, which needs `-----BEGIN` to start a line, so where the -NUL sits decides between three outcomes. Appending a NUL to a complete certificate would pass either -way, so these put material the parser must still reach *after* the NUL. +NUL sits decides between three outcomes. -/ -- Terminated by a newline the NUL is skipped like any other junk line. def testMkFromPEMReadsPastNul : IO Unit := do let _clientCtx ← Context.Client.mk { ca := some (.text ("\x00\n" ++ testCertPEM)) } -def testMkFromPEMParsesPastNul : IO Unit := do - assertErrorMessage "corrupt certificate after a NUL byte" - (malformedPEMError "could not read PEM CA certificates from the given string") - (discard <| Context.Client.mk { ca := some (.text (testCertPEM ++ "\x00\n" ++ testCorruptCertPEM)) }) - -- Sharing a line with the marker, the NUL hides it and that certificate is dropped without an error -- of its own; only the empty bundle behind it is reported. def testMkFromPEMDropsCertBehindNul : IO Unit := do - assertErrorMessage "certificate behind an unterminated NUL" - (malformedPEMError "the given CA PEM string contains no certificates") + assertErrorMessage "certificate behind an unterminated NUL" (malformedPEMError caNoCerts) (discard <| Context.Client.mk { ca := some (.text ("\x00" ++ testCertPEM)) }) -- Inside the body the NUL corrupts the block, which discards the whole bundle rather than just that -- certificate. def testMkFromPEMRejectsNulInsideCert : IO Unit := do let split := 200 - assertErrorMessage "NUL inside a certificate body" - (malformedPEMError "could not read PEM CA certificates from the given string") + assertErrorMessage "NUL inside a certificate body" (malformedPEMError caUnreadable) (discard <| Context.Client.mk { ca := some (.text ((testCertPEM.take split).toString ++ "\x00" ++ (testCertPEM.drop split).toString)) }) --- Inside the marker's type name the line still opens a block, but the name no longer matches the one --- on the `-----END` line, so the whole string is rejected instead of that certificate being skipped. --- This is the boundary against `testMkFromPEMDropsCertBehindNul`, where the NUL lands in the fixed --- `-----BEGIN ` prefix instead and stops the line opening a block at all. -def testMkFromPEMRejectsNulInMarkerName : IO Unit := do - assertErrorMessage "NUL inside a PEM marker's type name" - (malformedPEMError "could not read PEM CA certificates from the given string") - (discard <| Context.Client.mk { ca := some (.text - (testCertPEM.replace "-----BEGIN CERTIFICATE-----" "-----BEGIN CERTI\x00FICATE-----")) }) - --- The block is already open by the time the `-----END` line is read, so a NUL anywhere in it leaves a --- block that can never be closed and the whole string is rejected. -def testMkFromPEMRejectsNulInEndMarker : IO Unit := do - assertErrorMessage "NUL inside the END marker" - (malformedPEMError "could not read PEM CA certificates from the given string") - (discard <| Context.Client.mk { ca := some (.text - (testCertPEM.replace "-----END CERTIFICATE-----" "-----END CERTI\x00FICATE-----")) }) - -- The whole chain is loaded, not just the leaf, so a corrupt certificate in a later position is -- still rejected. This is the observable difference between `SSL_CTX_use_certificate_chain_file` -- and `SSL_CTX_use_certificate_file`. -def testMkServerRejectsCorruptChainMember (chainFile keyFile : String) : IO Unit := do +def testMkServerRejectsCorruptChainMember (f : Fixtures) : IO Unit := do assertErrorMessage "corrupt intermediate in the server chain" - (malformedFileError chainFile "could not read a PEM certificate chain") - (discard <| Context.Server.mk { cert := .file chainFile, key := .file keyFile }) + (malformedFileError f.chain "could not read a PEM certificate chain") + (discard <| Context.Server.mk { cert := .file f.chain, key := .file f.key }) -- Building a context parses certificates; it does not check their validity period. An expired -- certificate is therefore accepted here and only rejected at handshake time. -def testAcceptsExpiredCert (expiredFile keyFile : String) : IO Unit := do - let _serverCtx ← Context.Server.mk { cert := .file expiredFile, key := .file keyFile } +def testAcceptsExpiredCert (f : Fixtures) : IO Unit := do + let _serverCtx ← Context.Server.mk { cert := .file f.expired, key := .file f.key } let _clientCtx ← Context.Client.mk { ca := some (.text testExpiredCertPEM) } /-! @@ -568,61 +540,35 @@ reader after a problem their file does not have. The key is 512 bits so that eve default to rejects it — OpenSSL defaults to level 2 only since 3.2, and level 1 still admits 1024. The level is not ours to fix, though: a context inherits it from the ambient `openssl.cnf`, and a build -configured `DEFAULT@SECLEVEL=0` admits the certificate outright. `weakCertFile` is therefore paired with -an unrelated key, so the load fails either way and the two failures can be told apart. +configured `DEFAULT@SECLEVEL=0` admits the certificate outright. The weak certificate is therefore paired +with an unrelated key, so the load fails either way and the two failures can be told apart. -/ -def testMkServerRejectsWeakCert (weakCertFile keyFile : String) : IO Unit := do +def testMkServerRejectsWeakCert (f : Fixtures) : IO Unit := do assertErrorMessageOneOf "512-bit server certificate" - [ malformedFileError weakCertFile + [ malformedFileError f.weak "the certificate is rejected by the TLS security level (key too small or signature digest too weak)", - malformedFileError keyFile "the private key does not match the certificate" ] - (discard <| Context.Server.mk { cert := .file weakCertFile, key := .file keyFile }) + malformedFileError f.key "the private key does not match the certificate" ] + (discard <| Context.Server.mk { cert := .file f.weak, key := .file f.key }) -- The security level governs the certificate a server presents, not the anchors a client trusts, so -- the very file rejected above still loads as a CA. This is what pins the diagnosis to the security -- level rather than to the certificate being malformed. -def testAcceptsWeakCertAsCA (weakCertFile : String) : IO Unit := do +def testAcceptsWeakCertAsCA (f : Fixtures) : IO Unit := do let _clientCtx ← Context.Client.mk { ca := some (.text testWeakCertPEM) } - let _clientCtx2 ← Context.Client.mk { ca := some (.file weakCertFile) } - -/-! -A bundle entry that is not a certificate is skipped, and a bundle of nothing but such entries is -rejected for holding no certificates. `tradkey.pem` covers the private-key form; a CRL is the other -one, and the only one the "a lone CRL" case in the loader is actually about. --/ - -def testMkRejectsCRLOnlyCAFile (crlFile : String) : IO Unit := do - assertErrorMessage "CA file holding only a CRL" - (malformedFileError crlFile "the CA file contains no certificates") - (discard <| Context.Client.mk { ca := some (.file crlFile) }) - -def testMkFromPEMRejectsCRLOnly : IO Unit := do - assertErrorMessage "CA string holding only a CRL" - (malformedPEMError "the given CA PEM string contains no certificates") - (discard <| Context.Client.mk { ca := some (.text testCRLPEM) }) + let _clientCtx2 ← Context.Client.mk { ca := some (.file f.weak) } -def testMkFromPEMSkipsCRL : IO Unit := do - let _clientCtx ← Context.Client.mk { ca := some (.text (testCRLPEM ++ testCertPEM)) } - let _clientCtx2 ← Context.Client.mk { ca := some (.text (testCertPEM ++ testCRLPEM)) } +-- Only the *CA* material has a fallback to the platform anchors. The server has none, so an empty +-- path reaches the OS and fails there. +def testMkServerRejectsEmptyPaths (f : Fixtures) : IO Unit := do + -- `stat("")` is `ENOENT` on POSIX and `EINVAL` on the Windows CRT. + assertErrorMessageOneOf "empty server cert path" + [ missingFileError "", malformedFileError "" "could not read a PEM certificate chain" ] + (discard <| Context.Server.mk { cert := .file "", key := .file f.key }) --- A zero-byte file has no PEM armour to fail on, so it parses to an empty bundle and is reported as --- holding no certificates rather than as unreadable. -def testMkRejectsEmptyCAFile (emptyFile : String) : IO Unit := do - assertErrorMessage "zero-byte CA file" - (malformedFileError emptyFile "the CA file contains no certificates") - (discard <| Context.Client.mk { ca := some (.file emptyFile) }) - --- Only the *CA* path treats "" as "use the platform anchors". The server has no such fallback, so an --- empty path reaches the OS and fails there. -def testMkServerRejectsEmptyPaths (certFile keyFile : String) : IO Unit := do - assertErrorMessage "empty server cert path" - (missingFileError "") - (discard <| Context.Server.mk { cert := .file "", key := .file keyFile }) - - assertErrorMessage "empty server key path" - (missingFileError "") - (discard <| Context.Server.mk { cert := .file certFile, key := .file "" }) + assertErrorMessageOneOf "empty server key path" + [ missingFileError "", malformedFileError "" "could not read an unencrypted PEM private key" ] + (discard <| Context.Server.mk { cert := .file f.cert, key := .file "" }) /-! The path is reported with the failure whenever the `IO.Error` constructor has room for it. These @@ -636,201 +582,145 @@ the wrong table. -- actually reported rather than replacing it, because the file type need not be what went wrong — -- OpenSSL reads a FIFO or a `/dev/fd` entry as happily as a file on disk, so a mismatched key reached -- through one still has to say so. -def testRejectsDirectoryPaths (dir certFile keyFile : String) : IO Unit := do +def testRejectsDirectoryPaths (f : Fixtures) : IO Unit := do let note := " (the path is not a regular file)" assertErrorMessage "directory as server cert" - (malformedFileError dir ("could not read a PEM certificate chain" ++ note)) - (discard <| Context.Server.mk { cert := .file dir, key := .file keyFile }) + (malformedFileError f.dir ("could not read a PEM certificate chain" ++ note)) + (discard <| Context.Server.mk { cert := .file f.dir, key := .file f.key }) assertErrorMessage "directory as server key" - (malformedFileError dir ("could not read an unencrypted PEM private key" ++ note)) - (discard <| Context.Server.mk { cert := .file certFile, key := .file dir }) + (malformedFileError f.dir ("could not read an unencrypted PEM private key" ++ note)) + (discard <| Context.Server.mk { cert := .file f.cert, key := .file f.dir }) -- Which failure this is depends on the C library. On POSIX `BIO_new_file` opens the directory and -- the read that follows yields nothing, so the empty bundle is what gets reported; the Windows CRT -- cannot open a directory as a stream at all, so the BIO is null and the path is unreadable instead. -- Either way the note has to be appended rather than substituted, or which of the two it was is lost. assertErrorMessageOneOf "directory as CA file" - [ malformedFileError dir ("the CA file contains no certificates" ++ note), - malformedFileError dir ("could not read PEM CA certificates" ++ note) ] - (discard <| Context.Client.mk { ca := some (.file dir) }) + [ malformedFileError f.dir (caNoCerts ++ note), + malformedFileError f.dir (caUnreadable ++ note) ] + (discard <| Context.Client.mk { ca := some (.file f.dir) }) -- A character device is the readable non-regular file: OpenSSL opens `/dev/null` and reads it to -- completion, so the diagnosis is about what the empty read produced and the file type is only a -- footnote. -def testAppendsNoteToReadableNonRegularFile (certFile : String) : IO Unit := do +def testAppendsNoteToReadableNonRegularFile (f : Fixtures) : IO Unit := do if System.Platform.isWindows then return assertErrorMessage "character device as CA file" - (malformedFileError "/dev/null" - "the CA file contains no certificates (the path is not a regular file)") + (malformedFileError "/dev/null" (caNoCerts ++ " (the path is not a regular file)")) (discard <| Context.Client.mk { ca := some (.file "/dev/null") }) assertErrorMessage "character device as server key" (malformedFileError "/dev/null" "could not read an unencrypted PEM private key (the path is not a regular file)") - (discard <| Context.Server.mk { cert := .file certFile, key := .file "/dev/null" }) + (discard <| Context.Server.mk { cert := .file f.cert, key := .file "/dev/null" }) -- Skipped when the permission bits do not bite, which is the case for a privileged user. -def testMkRejectsUnreadableCAFile (unreadableFile : String) : IO Unit := do - if (← (IO.FS.readFile unreadableFile).toBaseIO).isOk then +def testMkRejectsUnreadableCAFile (f : Fixtures) : IO Unit := do + if (← (IO.FS.readFile f.unreadable).toBaseIO).isOk then return assertErrorMessage "CA file with no read permission" - s!"permission denied (error code: 13)\n file: {unreadableFile}" - (discard <| Context.Client.mk { ca := some (.file unreadableFile) }) - -def testMkRejectsNonDirectoryParent (notADirPath : String) : IO Unit := do - assertErrorMessage "CA path whose parent is a regular file" - s!"inappropriate type (error code: 20, not a directory)\n file: {notADirPath}" - (discard <| Context.Client.mk { ca := some (.file notADirPath) }) - -#eval do - let (certFile, keyFile) ← setupTestCerts - testContextCreation certFile keyFile + s!"permission denied (error code: 13)\n file: {f.unreadable}" + (discard <| Context.Client.mk { ca := some (.file f.unreadable) }) -#eval do - let (certFile, _) ← setupTestCerts - testMkClientFromPEM certFile +-- A path traversing a regular file is `ENOTDIR` on POSIX; the Windows CRT reports `ENOENT`. +def testMkRejectsNonDirectoryParent (f : Fixtures) : IO Unit := do + assertErrorMessageOneOf "CA path whose parent is a regular file" + [ s!"inappropriate type (error code: 20, not a directory)\n file: {f.nonDirParent}", + missingFileError f.nonDirParent ] + (discard <| Context.Client.mk { ca := some (.file f.nonDirParent) }) --- Server credentials supplied in memory rather than by path. #eval do - let (certFile, keyFile) ← setupTestCerts + let f ← mkFixtures - testMkServerFromMemory - testMkServerMixedSources certFile keyFile - testMkServerFromMemoryLoadsChain + testContextCreation f + testMkFromPEMEmptyFallsBack + testMkServerFromMemory f testMkServerFromMemoryErrors - testMkServerFromMemoryRejectsEncrypted testMkServerFromMemoryAcceptsNul + testMkFromPEMNoVerify + testMkFromPEMAcceptsBundle + testMkFromPEMAcceptsNulBytes -#eval testMkFromPEMEmptyFallsBack +-- Encrypted PEM, in every constructor. A regression here does not fail loudly: it blocks on a +-- passphrase prompt, so keep these ahead of anything that would mask a hang. +#eval do + let f ← mkFixtures + testRejectsEncryptedMaterial f --- Pinning: the supplied CA replaces the platform anchors rather than joining them. +-- Pinning: `trustSystemRoots := false` narrows the store to the supplied CA. #eval do - let (certFile, _) ← setupTestCerts + let f ← mkFixtures - testPinnedToSuppliedCA certFile + testPinnedToSuppliedCA f testPinningRejectsEmptyCA testPinningRejectsEmptyCAMaterial testPinningIgnoredWithoutVerification - testPinningStillValidatesCA (← setupMalformedFile) + testPinningStillValidatesCA f testPinningRejectsNulInCAFile +-- A trust anchor must be one a chain can terminate at. #eval do - let (certFile, _) ← setupTestCerts - testMkFromPEMNoVerify certFile - -#eval do - testMkFromPEMAcceptsBundle - testMkFromPEMAcceptsDuplicates - testMkFromPEMAcceptsNulBytes - testMkAcceptsBundleFile (← setupBundle) - testMkAcceptsDuplicatesInFile (← setupDuplicateBundle) - -#eval - testMkFromPEMRejectsGarbage - -#eval - testMkFromPEMRejectsEmptyBlock - -#eval - testMkRejectsMissingCAFile - -#eval do - let junkFile ← setupMalformedFile - testMkRejectsMalformedCAFile junkFile - -#eval testMkFromPEMRejectsCorruptCert - -#eval do - let corruptFile ← setupCorruptCert - testMkRejectsCorruptCAFile corruptFile - testMkNoVerifyIgnoresCorruptCAFile corruptFile + let f ← mkFixtures -#eval do - let (certFile, keyFile) ← setupTestCerts - let junkFile ← setupMalformedFile - let corruptFile ← setupCorruptCert - - testMkServerRejectsMissingCert keyFile - testMkServerRejectsMissingKey certFile - testMkServerRejectsMalformedCert junkFile keyFile - testMkServerRejectsMalformedKey certFile junkFile - testMkServerRejectsCorruptCert corruptFile keyFile - testMkServerRejectsCertAsKey certFile - testMkServerRejectsSwappedFiles certFile keyFile - testMkServerRejectsMismatchedKey certFile (← setupUnrelatedKey) - testMkServerRejectsCrossAlgorithmKey certFile (← setupECKey) - testMkServerRejectsEncryptedKey certFile (← setupEncryptedKey) - testMkServerRejectsEmptyPassphraseKey certFile (← setupEmptyPassphraseKey) + testPinningRejectsIntermediateOnly f + testPinningToIntermediateWithPartialChain f + testPinningAcceptsRootWithIntermediate + testIntermediateAllowedBesideSystemRoots + testIntermediateIgnoredWithoutVerification +-- CA material that cannot be used as a trust anchor. #eval do - let (certFile, keyFile) ← setupTestCerts - testMkServerRejectsNulInCert keyFile - testMkServerRejectsNulInKey certFile - testMkRejectsNulInCAFile + let f ← mkFixtures --- Encrypted PEM in all three constructors. A regression here does not fail loudly: it blocks on a --- passphrase prompt, so keep these ahead of anything that would mask a hang. -#eval do - let (_, keyFile) ← setupTestCerts - let encCertFile ← setupEncryptedCert - - testMkServerRejectsEncryptedCert encCertFile keyFile - testMkRejectsEncryptedCertCAFile encCertFile - testMkFromPEMRejectsEncryptedCert + testMkRejectsMissingCAFile + testMkRejectsMalformedCAFile f + testMkRejectsCorruptCAFile f + testMkNoVerifyIgnoresCorruptCAFile f + testMkFromPEMRejectsEmptyBlock + testMkRejectsCertlessCAFile f + testMkFromPEMRejectsCertlessPEM + testMkFromPEMSkipsNonCertificates --- A CA bundle must actually contain a certificate. +-- Server credentials that do not load. #eval do - let (_, keyFile) ← setupTestCerts - - testMkRejectsCertlessCAFile keyFile - testMkFromPEMRejectsCertlessPEM - testMkFromPEMSkipsTraditionalKey - testMkFromPEMRejectsTraditionalKeyOnly + let f ← mkFixtures + + testMkServerRejectsMissingFiles f + testMkServerRejectsMalformedCert f + testMkServerRejectsMalformedKey f + testMkServerRejectsCorruptCert f + testMkServerRejectsCertAsKey f + testMkServerRejectsSwappedFiles f + testMkServerRejectsMismatchedKey f + testMkServerRejectsCrossAlgorithmKey f + testMkServerRejectsCorruptChainMember f + testRejectsNulInPaths f -- NUL is data, not a terminator, but it is not invisible either. #eval do testMkFromPEMReadsPastNul - testMkFromPEMParsesPastNul testMkFromPEMDropsCertBehindNul testMkFromPEMRejectsNulInsideCert - testMkFromPEMRejectsNulInMarkerName - testMkFromPEMRejectsNulInEndMarker - -#eval do - let (certFile, keyFile) ← setupTestCerts - - testMkServerRejectsCorruptChainMember (← setupCorruptChain) keyFile - testAcceptsExpiredCert (← setupExpiredCert) keyFile - testMkClientFromPEM certFile - --- Rejected on policy, not for being unreadable. -#eval do - let (_, keyFile) ← setupTestCerts - let weakCertFile ← setupWeakCert - - testMkServerRejectsWeakCert weakCertFile keyFile - testAcceptsWeakCertAsCA weakCertFile --- A bundle must hold a certificate, and a CRL is not one. +-- Accepted here, rejected later: the clock and the security level. #eval do - let crlFile ← setupCRL + let f ← mkFixtures - testMkRejectsCRLOnlyCAFile crlFile - testMkFromPEMRejectsCRLOnly - testMkFromPEMSkipsCRL - testMkRejectsEmptyCAFile (← setupEmptyFile) + testAcceptsExpiredCert f + testMkServerRejectsWeakCert f + testAcceptsWeakCertAsCA f -- OS-level failures keep the path and the real errno. #eval do - let (certFile, keyFile) ← setupTestCerts + let f ← mkFixtures - testMkRejectsUnreadableCAFile (← setupUnreadableFile) - testMkRejectsNonDirectoryParent (← setupNonDirectoryParent) - testMkServerRejectsEmptyPaths certFile keyFile - testRejectsDirectoryPaths (← setupDirectory) certFile keyFile - testAppendsNoteToReadableNonRegularFile certFile + testMkRejectsUnreadableCAFile f + testMkRejectsNonDirectoryParent f + testMkServerRejectsEmptyPaths f + testRejectsDirectoryPaths f + testAppendsNoteToReadableNonRegularFile f