native/tls.c — sigil-tls

1/*

2 * Sigil TLS Library Implementation

3 *

4 * This file implements TLS/SSL connections using mbedTLS.

5 * Provides secure TCP connections for HTTPS and other TLS protocols.

6 *

7 * Supports TLS 1.2 and TLS 1.3 with the shared sigil-crypto configuration.

8 * mbedTLS initializes PSA as part of its TLS 1.3 handshake.

9 *

10 * Certificate Verification:

11 * - By default, certificates are verified against system CA certificates

12 * - Set SIGIL_TLS_INSECURE=1 to skip verification (for testing only)

13 *

14 * Note: TLS is not available on Emscripten/WebAssembly builds.

15 */

17#include "sigil-internal.h"

19#ifdef __EMSCRIPTEN__

20/*

21 * Stub implementation for Emscripten builds.

22 * TLS requires native sockets which aren't available in the browser.

23 * Note: sigil__tls_get_fd is now in tls-hooks.c (returns -1 when no hooks registered).

24 */

25void sigil__init_sigil_tls_module(SigilVM *vm)

26{

27 (void)vm;

28 /* TLS module not available on web platform - don't register hooks */

29}

31#else /* Native build */

32#include <stdio.h>

33#include <stdlib.h>

34#include <string.h>

35#include <errno.h>

36#include <fcntl.h>

37#ifdef _WIN32

38#include <winsock2.h>

39#else

40#include <unistd.h>

41#include <time.h>

42#include <sys/types.h>

43#include <sys/socket.h>

44#include <sys/select.h>

45#include <netinet/in.h>

46#include <netdb.h>

47#endif

49#include "mbedtls/ssl.h"

50#include "mbedtls/net_sockets.h"

51#include "mbedtls/entropy.h"

52#include "mbedtls/ctr_drbg.h"

53#include "mbedtls/error.h"

54#include "mbedtls/x509_crt.h"

56#ifdef SIGIL_TLS_DEBUG

57#include "mbedtls/debug.h"

59/* Debug callback for mbedTLS - enabled with SIGIL_TLS_DEBUG */

60static void tls_debug_callback(void *ctx, int level, const char *file, int line, const char *str)

61{

62 (void)ctx;

63 (void)level;

64 const char *p = strrchr(file, '/');

65 if (p) file = p + 1;

66 fprintf(stderr, "[mbedTLS] %s:%d: %s", file, line, str);

67}

68#endif

70/* Common CA certificate bundle paths on various Linux distributions */

71static const char *ca_cert_paths[] = {

72 "/etc/ssl/certs/ca-certificates.crt", /* Debian/Ubuntu/Guix */

73 "/etc/pki/tls/certs/ca-bundle.crt", /* Fedora/RHEL */

74 "/etc/ssl/ca-bundle.pem", /* openSUSE */

75 "/etc/pki/ca-trust/extracted/pem/tls-ca-bundle.pem", /* CentOS */

76 "/etc/ssl/cert.pem", /* Alpine/FreeBSD */

77 "/usr/local/share/certs/ca-root-nss.crt", /* FreeBSD */

78 "/etc/certs/ca-certificates.crt", /* Guix alternative */

79 NULL

80};

82/*

83 * TLS Connection data structure

84 *

85 * Wraps mbedTLS context for a single TLS connection.

86 * Each connection has its own SSL context and config.

87 */

88typedef struct {

89 mbedtls_ssl_context ssl;

90 mbedtls_ssl_config conf;

91 mbedtls_net_context server_fd;

92 mbedtls_x509_crt cacert;

93 int closed;

94 /* Tracks tls-set-non-blocking!. tls-write consults it: in blocking mode

95 * it keeps retrying WANT_WRITE (the original behaviour), in non-blocking

96 * mode it must hand control back instead of spinning on a socket that

97 * will not accept bytes. */

98 int nonblocking;

99 /* Absolute monotonic deadline (ms) for a handshake in progress, or 0 for

100 * none. Read by the deadline-aware BIO callbacks, which are the only

101 * place that sees every individual handshake read. Always back to 0

102 * before an established connection is handed to a caller. */

103 long handshake_deadline_ms;

104} TlsConnectionData;

105

106/* Per-attempt diagnostics are copied before connection cleanup. No shared

107 * last-error slot: another connection cannot overwrite this attempt's result. */

108typedef struct {

109 int error_code;

110 const char *handshake_state;

111 const char *protocol;

112 const char *cipher;

113 uint32_t verify_flags;

114} TlsDiagnostics;

115

116/* Symbol used as type tag for TLS connection foreign objects */

117static Value tls_connection_type_tag = SIGIL_UNDEFINED;

118

119/* Global entropy and RNG context (shared across connections for efficiency) */

120static mbedtls_entropy_context global_entropy;

121static mbedtls_ctr_drbg_context global_ctr_drbg;

122static mbedtls_x509_crt global_cacert;

123static int global_tls_initialized = 0;

124static int global_cacert_loaded = 0;

125static int global_insecure_mode = 0;

126

127/*

128 * Check if insecure mode is enabled via environment variable

129 */

130static int is_insecure_mode(void)

131{

132 const char *val = getenv("SIGIL_TLS_INSECURE");

133 return val && (val[0] == '1' || val[0] == 't' || val[0] == 'T');

134}

135

136/*

137 * Try to load CA certificates from common system paths

138 */

139static int load_system_ca_certs(void)

140{

141 if (global_cacert_loaded) return 0;

142

143 mbedtls_x509_crt_init(&global_cacert);

144

145 for (int i = 0; ca_cert_paths[i] != NULL; i++) {

146 int ret = mbedtls_x509_crt_parse_file(&global_cacert, ca_cert_paths[i]);

147 if (ret == 0) {

148 global_cacert_loaded = 1;

149 return 0;

150 }

151 }

152

153 /* Also try loading from SSL_CERT_FILE environment variable */

154 const char *cert_file = getenv("SSL_CERT_FILE");

155 if (cert_file) {

156 int ret = mbedtls_x509_crt_parse_file(&global_cacert, cert_file);

157 if (ret == 0) {

158 global_cacert_loaded = 1;

159 return 0;

160 }

161 }

162

163 /* Couldn't load any CA certificates */

164 return -1;

165}

166

167/*

168 * Initialize global TLS state (entropy, RNG, CA certs)

169 * Called once at module initialization.

170 */

171static int ensure_tls_initialized(void)

172{

173 if (!global_tls_initialized) {

174 mbedtls_entropy_init(&global_entropy);

175 mbedtls_ctr_drbg_init(&global_ctr_drbg);

176

177 const char *pers = "sigil_tls";

178 int ret = mbedtls_ctr_drbg_seed(&global_ctr_drbg, mbedtls_entropy_func,

179 &global_entropy,

180 (const unsigned char *)pers, strlen(pers));

181 if (ret != 0) {

182 return -1;

183 }

184

185 /* Check for insecure mode */

186 global_insecure_mode = is_insecure_mode();

187

188 /* Try to load CA certificates (not fatal if fails, but verify won't work) */

189 if (!global_insecure_mode) {

190 load_system_ca_certs();

191 }

192

193 global_tls_initialized = 1;

194 }

195 return 0;

196}

197

198/*

199 * Finalizer - clean up TLS connection when GC reclaims object

200 */

201static void tls_connection_finalizer(void *data)

202{

203 TlsConnectionData *conn = (TlsConnectionData *)data;

204 if (conn) {

205 if (!conn->closed) {

206 mbedtls_ssl_close_notify(&conn->ssl);

207 mbedtls_net_free(&conn->server_fd);

208 mbedtls_ssl_free(&conn->ssl);

209 mbedtls_ssl_config_free(&conn->conf);

210 mbedtls_x509_crt_free(&conn->cacert);

211 }

212 free(conn);

213 }

214}

215

216/*

217 * Helper: Create a TLS connection object

218 */

219static Value make_tls_connection(SigilVM *vm, TlsConnectionData *data)

220{

221 return sigil_make_foreign(vm, tls_connection_type_tag, data,

222 tls_connection_finalizer, sizeof(TlsConnectionData));

223}

224

225/*

226 * Helper: Check if value is a TLS connection

227 */

228static int is_tls_connection(Value v)

229{

230 if (!sigil_is_foreign(v)) return 0;

231 return sigil_foreign_type(v) == tls_connection_type_tag;

232}

233

234/*

235 * Helper: Get TLS connection data from value

236 */

237static TlsConnectionData *as_tls_connection(Value v)

238{

239 return (TlsConnectionData *)sigil_foreign_data(v);

240}

241

242/*

243 * tls-connection? value -> boolean

244 * Check if value is a TLS connection object.

245 */

246static Value native_tls_connectionp(SigilVM *vm, int argc, Value *args)

247{

248 (void)vm;

249 (void)argc;

250 return sigil_bool(is_tls_connection(args[0]));

251}

252

253#ifndef _WIN32

254/*

255 * Connect to host:port with a bounded total deadline, populating ctx->fd.

256 *

257 * Resolves the host (which may yield several CDN addresses) and tries each

258 * in turn with a NON-BLOCKING connect + select(), so a blackholed address

259 * (SYN dropped) cannot burn the full OS SYN-retransmit timeout (~127s on

260 * Linux). The whole operation is bounded by timeout_ms; on success the

261 * socket is restored to blocking mode (mbedTLS drives it blocking after).

262 *

263 * Returns 0 on success (ctx->fd set), -1 on failure/timeout. This is the

264 * opt-in path: native_tls_connect only calls it when a positive timeout is

265 * supplied; otherwise the original blocking mbedtls_net_connect runs,

266 * leaving the default behavior byte-identical.

267 */

268static long sigil_tls_now_ms(void)

269{

270 struct timespec ts;

271 clock_gettime(CLOCK_MONOTONIC, &ts);

272 return (long)ts.tv_sec * 1000L + ts.tv_nsec / 1000000L;

273}

274

275static int sigil_tls_connect_timeout(mbedtls_net_context *ctx,

276 const char *host, const char *port,

277 long timeout_ms)

278{

279 struct addrinfo hints, *res = NULL, *cur;

280 memset(&hints, 0, sizeof(hints));

281 hints.ai_family = AF_UNSPEC;

282 hints.ai_socktype = SOCK_STREAM;

283 hints.ai_protocol = IPPROTO_TCP;

284

285 if (getaddrinfo(host, port, &hints, &res) != 0) {

286 return -1;

287 }

288

289 long deadline = sigil_tls_now_ms() + timeout_ms;

290 int sockfd = -1;

291 int connected = 0;

292

293 /* Count addresses so each gets a fair slice of the total deadline: a

294 * blackholed first address can't consume the whole budget, leaving a

295 * working address (e.g. IPv4 after a dead IPv6, or another CDN node)

296 * still reachable within the same call (Happy-Eyeballs-lite). */

297 int addrs_remaining = 0;

298 for (cur = res; cur != NULL; cur = cur->ai_next) addrs_remaining++;

299

300 for (cur = res; cur != NULL; cur = cur->ai_next, addrs_remaining--) {

301 long remaining = deadline - sigil_tls_now_ms();

302 if (remaining <= 0) break;

303 long per_addr = remaining / (addrs_remaining > 0 ? addrs_remaining : 1);

304 if (per_addr < 1) per_addr = 1;

305

306 sockfd = socket(cur->ai_family, cur->ai_socktype, cur->ai_protocol);

307 if (sockfd < 0) continue;

308

309 int flags = fcntl(sockfd, F_GETFL, 0);

310 if (flags == -1 || fcntl(sockfd, F_SETFL, flags | O_NONBLOCK) == -1) {

311 close(sockfd);

312 sockfd = -1;

313 continue;

314 }

315

316 int rc = connect(sockfd, cur->ai_addr, cur->ai_addrlen);

317 if (rc == 0) {

318 connected = 1;

319 } else if (errno == EINPROGRESS) {

320 fd_set wset;

321 FD_ZERO(&wset);

322 FD_SET(sockfd, &wset);

323 struct timeval tv;

324 tv.tv_sec = per_addr / 1000L;

325 tv.tv_usec = (per_addr % 1000L) * 1000L;

326 int sel = select(sockfd + 1, NULL, &wset, NULL, &tv);

327 if (sel > 0 && FD_ISSET(sockfd, &wset)) {

328 int so_err = 0;

329 socklen_t len = sizeof(so_err);

330 if (getsockopt(sockfd, SOL_SOCKET, SO_ERROR, &so_err, &len) == 0

331 && so_err == 0) {

332 connected = 1;

333 }

334 }

335 /* sel == 0 -> this address timed out; sel < 0 -> select error */

336 }

337

338 if (connected) {

339 /* Restore blocking mode for mbedTLS's blocking I/O. */

340 fcntl(sockfd, F_SETFL, flags);

341 break;

342 }

343

344 close(sockfd);

345 sockfd = -1;

346 }

347

348 freeaddrinfo(res);

349

350 if (!connected || sockfd < 0) {

351 return -1;

352 }

353 ctx->fd = sockfd;

354 return 0;

355}

356#endif /* !_WIN32 */

357

358/*

359 * Handshake outcomes, shared by tls-connect and tls-upgrade.

360 *

361 * TIMEOUT is deliberately distinct from FAILED: "the peer never answered"

362 * and "the peer refused us" are different facts, and a caller retries them

363 * differently. Folding them together is what let a stalled handshake read

364 * as an ordinary connection failure.

365 */

366#define SIGIL_TLS_HS_OK 0

367#define SIGIL_TLS_HS_TIMEOUT 1

368#define SIGIL_TLS_HS_FAILED 2

369

370#ifndef _WIN32

371/*

372 * Deadline-aware BIO callbacks, used ONLY while a bounded handshake is in

373 * progress. p_bio is the TlsConnectionData, so the deadline is reachable

374 * from inside the callback.

375 *

376 * WHY THE DEADLINE HAS TO LIVE HERE rather than in the caller's loop, which

377 * is where I first put it and where it did not work:

378 *

379 * mbedtls_ssl_handshake does not return between handshake steps, and

380 * mbedtls_ssl_fetch_input loops `while (in_left < nb_want)` passing the

381 * FULL configured read_timeout to every partial read. A deadline enforced

382 * in the caller's loop is therefore consulted once per handshake, not once

383 * per read, and a peer that DRIPS bytes resets a fresh full-length timeout

384 * on each one. Measured: against a peer sending one byte every 600 ms, a

385 * 1000 ms bound took 13.06 s to fire, and against a peer that never

386 * stopped dripping it had not fired at all after 120 s.

387 *

388 * mbedtls_ssl_check_timer would have caught it, but only if a timer

389 * callback is installed, and mbedTLS cancels that timer at several points

390 * in the handshake. Clamping the timeout on the read itself needs no timer

391 * and cannot be cancelled: this is the one place that sees every read.

392 */

393static int sigil_tls_bio_remaining(TlsConnectionData *conn, long *out)

394{

395 if (conn->handshake_deadline_ms <= 0) {

396 *out = 0; /* no deadline in force */

397 return 0;

398 }

399 *out = conn->handshake_deadline_ms - sigil_tls_now_ms();

400 return 1;

401}

402

403static int sigil_tls_bio_recv_timeout(void *ctx, unsigned char *buf, size_t len,

404 uint32_t timeout)

405{

406 TlsConnectionData *conn = (TlsConnectionData *)ctx;

407 long remaining;

408

409 if (sigil_tls_bio_remaining(conn, &remaining)) {

410 if (remaining <= 0) {

411 return MBEDTLS_ERR_SSL_TIMEOUT;

412 }

413 /* Never wait past the whole-handshake deadline, whatever mbedTLS

414 * asks for. This is the clamp that makes the bound a total. */

415 if (timeout == 0 || (long)timeout > remaining) {

416 timeout = (uint32_t)remaining;

417 }

418 }

419 return mbedtls_net_recv_timeout(&conn->server_fd, buf, len, timeout);

420}

421

422static int sigil_tls_bio_recv(void *ctx, unsigned char *buf, size_t len)

423{

424 /* mbedTLS prefers f_recv_timeout when set, so this is a fallback. Route

425 * it through the same clamp rather than letting it block unbounded. */

426 return sigil_tls_bio_recv_timeout(ctx, buf, len, 0);

427}

428

429static int sigil_tls_bio_send(void *ctx, const unsigned char *buf, size_t len)

430{

431 TlsConnectionData *conn = (TlsConnectionData *)ctx;

432 long remaining;

433

434 /* The handshake WRITE can block too: a peer that accepts and never reads

435 * fills the window, and the client flight then blocks in send(). Rare

436 * with a flight of a few hundred bytes, but "rare" is not a bound. */

437 if (sigil_tls_bio_remaining(conn, &remaining)) {

438 fd_set wset;

439 struct timeval tv;

440 int sel;

441

442 if (remaining <= 0) {

443 return MBEDTLS_ERR_SSL_TIMEOUT;

444 }

445 FD_ZERO(&wset);

446 FD_SET(conn->server_fd.fd, &wset);

447 tv.tv_sec = remaining / 1000L;

448 tv.tv_usec = (remaining % 1000L) * 1000L;

449 sel = select(conn->server_fd.fd + 1, NULL, &wset, NULL, &tv);

450 if (sel == 0) {

451 return MBEDTLS_ERR_SSL_TIMEOUT;

452 }

453 if (sel < 0) {

454 if (errno == EINTR) {

455 return MBEDTLS_ERR_SSL_WANT_WRITE;

456 }

457 return MBEDTLS_ERR_NET_SEND_FAILED;

458 }

459 }

460 return mbedtls_net_send(&conn->server_fd, buf, len);

461}

462#endif /* !_WIN32 */

463

464static const char *tls_handshake_state_name(int state)

465{

466 switch (state) {

467 case MBEDTLS_SSL_HELLO_REQUEST: return "hello-request";

468 case MBEDTLS_SSL_CLIENT_HELLO: return "client-hello";

469 case MBEDTLS_SSL_SERVER_HELLO: return "server-hello";

470 case MBEDTLS_SSL_SERVER_CERTIFICATE: return "server-certificate";

471 case MBEDTLS_SSL_SERVER_KEY_EXCHANGE: return "server-key-exchange";

472 case MBEDTLS_SSL_CERTIFICATE_REQUEST: return "certificate-request";

473 case MBEDTLS_SSL_SERVER_HELLO_DONE: return "server-hello-done";

474 case MBEDTLS_SSL_CLIENT_CERTIFICATE: return "client-certificate";

475 case MBEDTLS_SSL_CLIENT_KEY_EXCHANGE: return "client-key-exchange";

476 case MBEDTLS_SSL_CERTIFICATE_VERIFY: return "certificate-verify";

477 case MBEDTLS_SSL_CLIENT_CHANGE_CIPHER_SPEC: return "client-change-cipher-spec";

478 case MBEDTLS_SSL_CLIENT_FINISHED: return "client-finished";

479 case MBEDTLS_SSL_SERVER_CHANGE_CIPHER_SPEC: return "server-change-cipher-spec";

480 case MBEDTLS_SSL_SERVER_FINISHED: return "server-finished";

481 case MBEDTLS_SSL_FLUSH_BUFFERS: return "flush-buffers";

482 case MBEDTLS_SSL_HANDSHAKE_WRAPUP: return "handshake-wrapup";

483 case MBEDTLS_SSL_NEW_SESSION_TICKET: return "new-session-ticket";

484 case MBEDTLS_SSL_SERVER_HELLO_VERIFY_REQUEST_SENT: return "server-hello-verify-request-sent";

485 case MBEDTLS_SSL_HELLO_RETRY_REQUEST: return "hello-retry-request";

486 case MBEDTLS_SSL_ENCRYPTED_EXTENSIONS: return "encrypted-extensions";

487 case MBEDTLS_SSL_END_OF_EARLY_DATA: return "end-of-early-data";

488 case MBEDTLS_SSL_CLIENT_CERTIFICATE_VERIFY: return "client-certificate-verify";

489 case MBEDTLS_SSL_CLIENT_CCS_AFTER_SERVER_FINISHED: return "client-ccs-after-server-finished";

490 case MBEDTLS_SSL_CLIENT_CCS_BEFORE_2ND_CLIENT_HELLO: return "client-ccs-before-2nd-client-hello";

491 case MBEDTLS_SSL_SERVER_CCS_AFTER_SERVER_HELLO: return "server-ccs-after-server-hello";

492 case MBEDTLS_SSL_CLIENT_CCS_AFTER_CLIENT_HELLO: return "client-ccs-after-client-hello";

493 case MBEDTLS_SSL_SERVER_CCS_AFTER_HELLO_RETRY_REQUEST: return "server-ccs-after-hello-retry-request";

494 case MBEDTLS_SSL_HANDSHAKE_OVER: return "handshake-over";

495 case MBEDTLS_SSL_TLS1_3_NEW_SESSION_TICKET: return "tls1-3-new-session-ticket";

496 case MBEDTLS_SSL_TLS1_3_NEW_SESSION_TICKET_FLUSH: return "tls1-3-new-session-ticket-flush";

497 default: return "unknown";

498 }

499}

500

501static int tls_handshake_result(TlsConnectionData *conn, int error,

502 TlsDiagnostics *details)

503{

504 if (details) {

505 details->error_code = error;

506 details->handshake_state = tls_handshake_state_name(conn->ssl.MBEDTLS_PRIVATE(state));

507 details->verify_flags = mbedtls_ssl_get_verify_result(&conn->ssl);

508 if (error == 0) {

509 details->protocol = mbedtls_ssl_get_version(&conn->ssl);

510 details->cipher = mbedtls_ssl_get_ciphersuite(&conn->ssl);

511 }

512 }

513 if (error == 0) return SIGIL_TLS_HS_OK;

514 return error == MBEDTLS_ERR_SSL_TIMEOUT ? SIGIL_TLS_HS_TIMEOUT : SIGIL_TLS_HS_FAILED;

515}

516

517/*

518 * Run the TLS handshake on an already-connected conn->server_fd.

519 *

520 * With handshake_timeout_ms <= 0 (the default) this is byte-for-byte the

521 * original blocking handshake: blocking mbedtls_net_recv as the BIO and a

522 * loop that only retries on WANT_READ/WANT_WRITE.

523 *

524 * With a positive handshake_timeout_ms, the handshake's reads AND writes go

525 * through deadline-aware BIO callbacks that clamp every wait to the time

526 * remaining. This is the segment that connect-timeout-ms does NOT cover:

527 * once a peer has ACCEPTED the TCP connection the connect phase is over, and

528 * the handshake that follows was previously unbounded. A peer that accepts

529 * and then never sends a ServerHello wedged a production monitoring service

530 * for 55 days.

531 *

532 * The deadline is a TOTAL over the handshake. It is enforced inside the BIO

533 * rather than in the loop below, for the reason documented on those

534 * callbacks: a loop-level deadline is consulted once per handshake and a

535 * dripping peer walks straight through it.

536 *

537 * Everything is unwound before returning, so an established connection's

538 * subsequent tls-read and tls-write behave exactly as before. Only the

539 * handshake is bounded here.

540 */

541static int sigil_tls_run_handshake(TlsConnectionData *conn, long handshake_timeout_ms,

542 TlsDiagnostics *details)

543{

544 int ret;

545

546#ifndef _WIN32

547 if (handshake_timeout_ms > 0) {

548 conn->handshake_deadline_ms = sigil_tls_now_ms() + handshake_timeout_ms;

549 mbedtls_ssl_conf_read_timeout(&conn->conf, (uint32_t)handshake_timeout_ms);

550 mbedtls_ssl_set_bio(&conn->ssl, conn,

551 sigil_tls_bio_send, sigil_tls_bio_recv,

552 sigil_tls_bio_recv_timeout);

553

554 for (;;) {

555 ret = mbedtls_ssl_handshake(&conn->ssl);

556 if (ret == 0) {

557 break;

558 }

559 if (ret == MBEDTLS_ERR_SSL_TIMEOUT) {

560 break;

561 }

562 if (ret != MBEDTLS_ERR_SSL_WANT_READ &&

563 ret != MBEDTLS_ERR_SSL_WANT_WRITE) {

564 break;

565 }

566 /* WANT_* on a blocking BIO means the deadline is the only thing

567 * that can end this; check it so the retry cannot spin. */

568 if (conn->handshake_deadline_ms - sigil_tls_now_ms() <= 0) {

569 ret = MBEDTLS_ERR_SSL_TIMEOUT;

570 break;

571 }

572 }

573

574 /* Restore unbounded reads + the plain BIO for the session. */

575 conn->handshake_deadline_ms = 0;

576 mbedtls_ssl_conf_read_timeout(&conn->conf, 0);

577 mbedtls_ssl_set_bio(&conn->ssl, &conn->server_fd,

578 mbedtls_net_send, mbedtls_net_recv, NULL);

579 return tls_handshake_result(conn, ret, details);

580 }

581#else

582 (void)handshake_timeout_ms;

583#endif

584

585 mbedtls_ssl_set_bio(&conn->ssl, &conn->server_fd,

586 mbedtls_net_send, mbedtls_net_recv, NULL);

587

588 while ((ret = mbedtls_ssl_handshake(&conn->ssl)) != 0) {

589 if (ret != MBEDTLS_ERR_SSL_WANT_READ && ret != MBEDTLS_ERR_SSL_WANT_WRITE) {

590 return tls_handshake_result(conn, ret, details);

591 }

592 }

593 return tls_handshake_result(conn, 0, details);

594}

595

596/*

597 * Build the (status . connection-or-#f) pair returned by the /status

598 * variants. `status` is a short stable string, e.g. "connected",

599 * "handshake-timeout".

600 */

601static Value make_tls_status(SigilVM *vm, const char *status, Value conn)

602{

603 sigil__gc_push_temp_root(vm, conn);

604 Value status_val = sigil_make_string(vm, status, strlen(status));

605 sigil__gc_push_temp_root(vm, status_val);

606 Value result = sigil_cons(vm, status_val, conn);

607 sigil__gc_pop_temp_root(vm);

608 sigil__gc_pop_temp_root(vm);

609 return result;

610}

611

612/*

613 * Core of tls-connect. Returns the connection value, or SIGIL_FALSE on

614 * failure, and writes a short stable status string through *status_out

615 * ("connected", "tcp-connect-failed", "handshake-timeout", ...).

616 *

617 * Both tls-connect (which discards the status) and tls-connect/status

618 * (which surfaces it) run this, so the two can never drift apart.

619 */

620static Value tls_connect_core(SigilVM *vm, int argc, Value *args,

621 const char **status_out, TlsDiagnostics *details)

622{

623 *status_out = "tls-init-failed";

624

625 if (ensure_tls_initialized() < 0) {

626 return SIGIL_FALSE;

627 }

628

629 SigilString *host_str = (SigilString *)sigil_as_ptr(args[0]);

630 int port = (int)sigil_as_fixnum(args[1]);

631

632 /* Optional connect timeout (milliseconds); <= 0 or absent = blocking. */

633 long connect_timeout_ms = 0;

634 if (argc >= 3 && sigil_is_fixnum(args[2])) {

635 connect_timeout_ms = (long)sigil_as_fixnum(args[2]);

636 }

637

638 /* Optional handshake timeout (milliseconds); <= 0 or absent = blocking. */

639 long handshake_timeout_ms = 0;

640 if (argc >= 4 && sigil_is_fixnum(args[3])) {

641 handshake_timeout_ms = (long)sigil_as_fixnum(args[3]);

642 }

643

644 /* Null-terminate hostname */

645 char *hostname = malloc(host_str->byte_length + 1);

646 if (!hostname) return SIGIL_FALSE;

647 memcpy(hostname, host_str->data, host_str->byte_length);

648 hostname[host_str->byte_length] = '\0';

649

650 char port_str[16];

651 snprintf(port_str, sizeof(port_str), "%d", port);

652

653 /* Allocate connection structure */

654 TlsConnectionData *conn = calloc(1, sizeof(TlsConnectionData));

655 if (!conn) {

656 free(hostname);

657 return SIGIL_FALSE;

658 }

659

660 conn->closed = 0;

661 int ret;

662

663 /* Initialize mbedTLS structures */

664 mbedtls_net_init(&conn->server_fd);

665 mbedtls_ssl_init(&conn->ssl);

666 mbedtls_ssl_config_init(&conn->conf);

667 mbedtls_x509_crt_init(&conn->cacert);

668

669 /* Connect to server. With a positive connect timeout, use the bounded

670 * non-blocking path; otherwise the original blocking connect (default

671 * behavior unchanged). */

672#ifndef _WIN32

673 if (connect_timeout_ms > 0) {

674 ret = sigil_tls_connect_timeout(&conn->server_fd, hostname, port_str,

675 connect_timeout_ms);

676 } else {

677 ret = mbedtls_net_connect(&conn->server_fd, hostname, port_str,

678 MBEDTLS_NET_PROTO_TCP);

679 }

680#else

681 (void)connect_timeout_ms;

682 ret = mbedtls_net_connect(&conn->server_fd, hostname, port_str,

683 MBEDTLS_NET_PROTO_TCP);

684#endif

685 if (ret != 0) {

686 *status_out = "tcp-connect-failed";

687 goto cleanup_error;

688 }

689

690 /* Set up SSL configuration */

691 ret = mbedtls_ssl_config_defaults(&conn->conf,

692 MBEDTLS_SSL_IS_CLIENT,

693 MBEDTLS_SSL_TRANSPORT_STREAM,

694 MBEDTLS_SSL_PRESET_DEFAULT);

695 if (ret != 0) {

696 *status_out = "ssl-config-failed";

697 goto cleanup_error;

698 }

699

700 /* Configure certificate verification */

701 if (global_insecure_mode) {

702 /* SIGIL_TLS_INSECURE=1 - skip verification (for testing only) */

703 mbedtls_ssl_conf_authmode(&conn->conf, MBEDTLS_SSL_VERIFY_NONE);

704 } else if (global_cacert_loaded) {

705 /* Verify certificates against system CA bundle */

706 mbedtls_ssl_conf_authmode(&conn->conf, MBEDTLS_SSL_VERIFY_REQUIRED);

707 mbedtls_ssl_conf_ca_chain(&conn->conf, &global_cacert, NULL);

708 } else {

709 /* No CA certs available - fall back to no verification with warning */

710 mbedtls_ssl_conf_authmode(&conn->conf, MBEDTLS_SSL_VERIFY_NONE);

711 }

712 mbedtls_ssl_conf_rng(&conn->conf, mbedtls_ctr_drbg_random, &global_ctr_drbg);

713

714#ifdef SIGIL_TLS_DEBUG

715 mbedtls_ssl_conf_dbg(&conn->conf, tls_debug_callback, NULL);

716 mbedtls_debug_set_threshold(4);

717#endif

718

719 /* Set up SSL context */

720 ret = mbedtls_ssl_setup(&conn->ssl, &conn->conf);

721 if (ret != 0) {

722 *status_out = "ssl-setup-failed";

723 goto cleanup_error;

724 }

725

726 /* Set hostname for SNI (Server Name Indication) */

727 ret = mbedtls_ssl_set_hostname(&conn->ssl, hostname);

728 if (ret != 0) {

729 *status_out = "ssl-set-hostname-failed";

730 goto cleanup_error;

731 }

732

733 /* Perform TLS handshake (bounded when handshake_timeout_ms > 0). */

734 ret = sigil_tls_run_handshake(conn, handshake_timeout_ms, details);

735 if (ret == SIGIL_TLS_HS_TIMEOUT) {

736 *status_out = "handshake-timeout";

737 goto cleanup_error;

738 }

739 if (ret != SIGIL_TLS_HS_OK) {

740 *status_out = "handshake-failed";

741 goto cleanup_error;

742 }

743

744 free(hostname);

745 *status_out = "connected";

746 return make_tls_connection(vm, conn);

747

748cleanup_error:

749 mbedtls_net_free(&conn->server_fd);

750 mbedtls_ssl_free(&conn->ssl);

751 mbedtls_ssl_config_free(&conn->conf);

752 mbedtls_x509_crt_free(&conn->cacert);

753 free(conn);

754 free(hostname);

755 return SIGIL_FALSE;

756}

757

758/* Shared argument validation for tls-connect and tls-connect/status.

759 * Returns 0 on success, -1 when a VM type error has been raised. */

760static int tls_connect_check_args(SigilVM *vm, Value *args, const char *who)

761{

762 if (!sigil_is_string(args[0])) {

763 char msg[96];

764 snprintf(msg, sizeof(msg), "%s: expected string for hostname", who);

765 sigil__vm_error(vm, SIGIL_ERR_TYPE, msg);

766 return -1;

767 }

768 if (!sigil_is_fixnum(args[1])) {

769 char msg[96];

770 snprintf(msg, sizeof(msg), "%s: expected integer for port", who);

771 sigil__vm_error(vm, SIGIL_ERR_TYPE, msg);

772 return -1;

773 }

774 return 0;

775}

776

777/*

778 * tls-connect hostname port [connect-timeout-ms [handshake-timeout-ms]]

779 * -> tls-connection | #f

780 *

781 * Establish a TLS connection to the specified host and port.

782 * Returns a TLS connection object on success, #f on failure.

783 *

784 * The optional connect-timeout-ms (a positive integer) bounds the TCP

785 * connect phase via a non-blocking connect + select with try-next-address,

786 * so a blackholed address can't hang on the OS SYN timeout.

787 *

788 * The optional handshake-timeout-ms bounds the TLS HANDSHAKE, which the

789 * connect timeout does not reach: a peer that ACCEPTS the connection and

790 * then never sends a ServerHello leaves the connect phase already complete

791 * and the handshake read blocking forever. Both are omitted or <= 0 by

792 * default, keeping the original blocking behavior. Ignored on Windows.

793 *

794 * `tls-connect` collapses every failure to #f. Use `tls-connect/status`

795 * when you need to tell "the peer never answered" from "the peer refused".

796 */

797static Value native_tls_connect(SigilVM *vm, int argc, Value *args)

798{

799 const char *status = NULL;

800

801 if (tls_connect_check_args(vm, args, "tls-connect") < 0) {

802 return SIGIL_UNDEFINED;

803 }

804 return tls_connect_core(vm, argc, args, &status, NULL);

805}

806

807/*

808 * tls-connect/status hostname port [connect-timeout-ms [handshake-timeout-ms]]

809 * -> (status-string . tls-connection | #f)

810 *

811 * Same connection attempt as tls-connect, but reports WHY it failed:

812 *

813 * "connected" the pair's cdr is a live connection

814 * "tcp-connect-failed" never reached the peer

815 * "handshake-timeout" peer accepted, then went silent (bounded here)

816 * "handshake-failed" peer rejected us (cert, version, alert)

817 * "ssl-*-failed" local setup fault

818 *

819 * "handshake-timeout" is the case that has to stay distinguishable: a

820 * caller retries a silent peer differently from one that refused it.

821 */

822static Value native_tls_connect_status(SigilVM *vm, int argc, Value *args)

823{

824 const char *status = "tls-init-failed";

825

826 if (tls_connect_check_args(vm, args, "tls-connect/status") < 0) {

827 return SIGIL_UNDEFINED;

828 }

829

830 Value conn = tls_connect_core(vm, argc, args, &status, NULL);

831 return make_tls_status(vm, status, conn);

832}

833

834/* Values are rooted while subsequent strings/keywords allocate. */

835static Value tls_detail_string(SigilVM *vm, const char *text)

836{

837 return text ? sigil_make_string(vm, text, strlen(text)) : SIGIL_FALSE;

838}

839

840static Value make_tls_details(SigilVM *vm, const char *status, Value conn,

841 const TlsDiagnostics *details)

842{

843 char message[256];

844 if (details->error_code != 0)

845 mbedtls_strerror(details->error_code, message, sizeof(message));

846 const char *names[] = { "status", "connection", "error-code", "error-message",

847 "handshake-state", "protocol", "cipher", "verify-flags" };

848 Value pairs[16];

849 sigil__gc_push_temp_root(vm, conn);

850 for (int i = 0; i < 8; i++) {

851 pairs[i * 2] = sigil_intern_keyword(vm, names[i], strlen(names[i]));

852 sigil__gc_push_temp_root(vm, pairs[i * 2]);

853 Value value;

854 switch (i) {

855 case 0: value = tls_detail_string(vm, status); break;

856 case 1: value = conn; break;

857 case 2: value = sigil_fixnum(details->error_code); break;

858 case 3: value = tls_detail_string(vm, details->error_code ? message : NULL); break;

859 case 4: value = tls_detail_string(vm, details->handshake_state); break;

860 case 5: value = tls_detail_string(vm, details->protocol); break;

861 case 6: value = tls_detail_string(vm, details->cipher); break;

862 default: value = sigil_fixnum(details->verify_flags); break;

863 }

864 pairs[i * 2 + 1] = value;

865 sigil__gc_push_temp_root(vm, value);

866 }

867 Value result = sigil_dict_create(vm, 8, pairs);

868 for (int i = 0; i < 17; i++) sigil__gc_pop_temp_root(vm);

869 return result;

870}

871

872static Value native_tls_connect_details(SigilVM *vm, int argc, Value *args)

873{

874 const char *status = "tls-init-failed";

875 TlsDiagnostics details = {0};

876 if (tls_connect_check_args(vm, args, "tls-connect/details") < 0)

877 return SIGIL_UNDEFINED;

878 Value conn = tls_connect_core(vm, argc, args, &status, &details);

879 return make_tls_details(vm, status, conn, &details);

880}

881

882/*

883 * tls-read connection [max-bytes] -> string | #f | eof-object

884 * Read data from TLS connection.

885 * Returns string with data, #f on error, or eof-object if connection closed.

886 */

887static Value native_tls_read(SigilVM *vm, int argc, Value *args)

888{

889 if (!is_tls_connection(args[0])) {

890 sigil__vm_error(vm, SIGIL_ERR_TYPE, "tls-read: expected tls-connection");

891 return SIGIL_UNDEFINED;

892 }

893

894 TlsConnectionData *conn = as_tls_connection(args[0]);

895 if (conn->closed) {

896 sigil__vm_error(vm, SIGIL_ERR_IO, "tls-read: connection is closed");

897 return SIGIL_UNDEFINED;

898 }

899

900 int max_bytes = 4096;

901 if (argc >= 2 && sigil_is_fixnum(args[1])) {

902 max_bytes = (int)sigil_as_fixnum(args[1]);

903 if (max_bytes <= 0) max_bytes = 4096;

904 }

905

906 char *buf = malloc(max_bytes);

907 if (!buf) return SIGIL_FALSE;

908

909 int ret = mbedtls_ssl_read(&conn->ssl, (unsigned char *)buf, max_bytes);

910

911 if (ret == MBEDTLS_ERR_SSL_WANT_READ || ret == MBEDTLS_ERR_SSL_WANT_WRITE) {

912 free(buf);

913 return sigil_make_string(vm, "", 0); /* Non-blocking, no data available */

914 }

915

916 if (ret == MBEDTLS_ERR_SSL_PEER_CLOSE_NOTIFY || ret == 0) {

917 free(buf);

918 return SIGIL_EOF; /* Connection closed */

919 }

920

921 if (ret < 0) {

922 free(buf);

923 return SIGIL_FALSE; /* Error */

924 }

925

926 Value result = sigil_make_string(vm, buf, ret);

927 free(buf);

928 return result;

929}

930

931/*

932 * tls-read-bytevector connection [max-bytes] -> bytevector | #f | eof-object

933 * Read raw bytes from TLS connection into a bytevector.

934 * Unlike tls-read (which returns a UTF-8 string), this preserves raw bytes

935 * without any encoding interpretation. Essential for binary protocols.

936 */

937static Value native_tls_read_bytevector(SigilVM *vm, int argc, Value *args)

938{

939 if (!is_tls_connection(args[0])) {

940 sigil__vm_error(vm, SIGIL_ERR_TYPE, "tls-read-bytevector: expected tls-connection");

941 return SIGIL_UNDEFINED;

942 }

943

944 TlsConnectionData *conn = as_tls_connection(args[0]);

945 if (conn->closed) {

946 sigil__vm_error(vm, SIGIL_ERR_IO, "tls-read-bytevector: connection is closed");

947 return SIGIL_UNDEFINED;

948 }

949

950 int max_bytes = 4096;

951 if (argc >= 2 && sigil_is_fixnum(args[1])) {

952 max_bytes = (int)sigil_as_fixnum(args[1]);

953 if (max_bytes <= 0) max_bytes = 4096;

954 }

955

956 char *buf = malloc(max_bytes);

957 if (!buf) return SIGIL_FALSE;

958

959 int ret = mbedtls_ssl_read(&conn->ssl, (unsigned char *)buf, max_bytes);

960

961 if (ret == MBEDTLS_ERR_SSL_WANT_READ || ret == MBEDTLS_ERR_SSL_WANT_WRITE) {

962 free(buf);

963 return sigil_make_bytevector(vm, 0); /* Non-blocking, no data available */

964 }

965

966 if (ret == MBEDTLS_ERR_SSL_PEER_CLOSE_NOTIFY || ret == 0) {

967 free(buf);

968 return SIGIL_EOF; /* Connection closed */

969 }

970

971 if (ret < 0) {

972 free(buf);

973 return SIGIL_FALSE; /* Error */

974 }

975

976 Value result = sigil_make_bytevector(vm, (size_t)ret);

977 SigilBytevector *bv = (SigilBytevector *)sigil_as_ptr(result);

978 memcpy(bv->data, buf, ret);

979 free(buf);

980 return result;

981}

982

983/*

984 * tls-write connection data [start [end]] -> integer | #f

985 *

986 * Write data to a TLS connection. Returns the number of bytes written, or

987 * #f on error.

988 *

989 * BLOCKING connection (the default): retries WANT_READ/WANT_WRITE until the

990 * whole buffer is written, exactly as before.

991 *

992 * NON-BLOCKING connection (after tls-set-non-blocking!): returns the number

993 * of bytes actually committed, which may be 0, instead of spinning. The old

994 * behaviour on a non-blocking socket was a `continue` on WANT_WRITE, i.e. a

995 * busy loop that never returned and never yielded — unbounded AND hot. A

996 * caller can now poll against a deadline. A 0 return means "nothing was

997 * accepted, retry the SAME slice", which is what mbedTLS requires after

998 * WANT_WRITE.

999 *

1000 * The optional [start] and [end] byte offsets let a write loop resend the

1001 * tail of a buffer without copying it each time, keeping a large body O(n)

1002 * instead of O(n^2). This mirrors socket-write.

1003 */

1004static Value native_tls_write(SigilVM *vm, int argc, Value *args)

1005{

1006 if (!is_tls_connection(args[0])) {

1007 sigil__vm_error(vm, SIGIL_ERR_TYPE, "tls-write: expected tls-connection");

1008 return SIGIL_UNDEFINED;

1009 }

1010

1011 TlsConnectionData *conn = as_tls_connection(args[0]);

1012 if (conn->closed) {

1013 sigil__vm_error(vm, SIGIL_ERR_IO, "tls-write: connection is closed");

1014 return SIGIL_UNDEFINED;

1015 }

1016

1017 const char *data;

1018 size_t len;

1019

1020 if (sigil_is_string(args[1])) {

1021 SigilString *s = (SigilString *)sigil_as_ptr(args[1]);

1022 data = s->data;

1023 len = s->byte_length;

1024 } else if (sigil_is_bytevector(args[1])) {

1025 SigilBytevector *bv = (SigilBytevector *)sigil_as_ptr(args[1]);

1026 data = (const char *)bv->data;

1027 len = bv->length;

1028 } else {

1029 sigil__vm_error(vm, SIGIL_ERR_TYPE, "tls-write: expected string or bytevector");

1030 return SIGIL_UNDEFINED;

1031 }

1032

1033 /* Optional [start] and [end] byte offsets, clamped into the buffer. */

1034 size_t start = 0;

1035 size_t end = len;

1036 if (argc >= 3 && sigil_is_fixnum(args[2])) {

1037 long s = (long)sigil_as_fixnum(args[2]);

1038 if (s < 0) s = 0;

1039 start = (size_t)s > len ? len : (size_t)s;

1040 }

1041 if (argc >= 4 && sigil_is_fixnum(args[3])) {

1042 long e = (long)sigil_as_fixnum(args[3]);

1043 if (e < 0) e = 0;

1044 end = (size_t)e > len ? len : (size_t)e;

1045 }

1046 if (end < start) end = start;

1047

1048 data += start;

1049 len = end - start;

1050

1051 int ret;

1052 size_t total_written = 0;

1053

1054 while (total_written < len) {

1055 ret = mbedtls_ssl_write(&conn->ssl,

1056 (const unsigned char *)data + total_written,

1057 len - total_written);

1058

1059 if (ret == MBEDTLS_ERR_SSL_WANT_READ || ret == MBEDTLS_ERR_SSL_WANT_WRITE) {

1060 if (conn->nonblocking) {

1061 /* Hand control back so the caller can enforce a deadline

1062 * (and let other tasks run) rather than spinning here. */

1063 break;

1064 }

1065 continue; /* Blocking: retry, as before. */

1066 }

1067

1068 if (ret < 0) {

1069 /* Report bytes already COMMITTED rather than collapsing to #f:

1070 * they are on the wire, and a caller that resent them would

1071 * corrupt the stream. With nothing committed, #f as before. */

1072 if (total_written > 0) {

1073 break;

1074 }

1075 return SIGIL_FALSE; /* Error */

1076 }

1077

1078 total_written += ret;

1079 }

1080

1081 return sigil_fixnum(total_written);

1082}

1083

1084/*

1085 * tls-close connection -> boolean

1086 * Close a TLS connection. Returns #t on success.

1087 */

1088static Value native_tls_close(SigilVM *vm, int argc, Value *args)

1089{

1090 (void)argc;

1091

1092 if (!is_tls_connection(args[0])) {

1093 sigil__vm_error(vm, SIGIL_ERR_TYPE, "tls-close: expected tls-connection");

1094 return SIGIL_UNDEFINED;

1095 }

1096

1097 TlsConnectionData *conn = as_tls_connection(args[0]);

1098 if (conn->closed) {

1099 return SIGIL_TRUE; /* Already closed */

1100 }

1101

1102 mbedtls_ssl_close_notify(&conn->ssl);

1103 mbedtls_net_free(&conn->server_fd);

1104 mbedtls_ssl_free(&conn->ssl);

1105 mbedtls_ssl_config_free(&conn->conf);

1106 mbedtls_x509_crt_free(&conn->cacert);

1107

1108 conn->closed = 1;

1109

1110 return SIGIL_TRUE;

1111}

1112

1113/*

1114 * tls-closed? connection -> boolean

1115 * Check if TLS connection is closed.

1116 */

1117static Value native_tls_closedp(SigilVM *vm, int argc, Value *args)

1118{

1119 (void)argc;

1120

1121 if (!is_tls_connection(args[0])) {

1122 sigil__vm_error(vm, SIGIL_ERR_TYPE, "tls-closed?: expected tls-connection");

1123 return SIGIL_UNDEFINED;

1124 }

1125

1126 TlsConnectionData *conn = as_tls_connection(args[0]);

1127 return sigil_bool(conn->closed);

1128}

1129

1130/*

1131 * tls-set-non-blocking! tls-connection [enable] -> boolean

1132 * Set the underlying socket to non-blocking mode.

1133 * enable defaults to #t if not provided.

1134 */

1135static Value native_tls_set_non_blocking(SigilVM *vm, int argc, Value *args)

1136{

1137 if (!is_tls_connection(args[0])) {

1138 sigil__vm_error(vm, SIGIL_ERR_TYPE, "tls-set-non-blocking!: expected tls-connection");

1139 return SIGIL_UNDEFINED;

1140 }

1141

1142 TlsConnectionData *conn = as_tls_connection(args[0]);

1143 if (conn->closed) {

1144 return SIGIL_FALSE;

1145 }

1146

1147 int enable = (argc < 2) ? 1 : sigil_is_truthy(args[1]);

1148 int fd = conn->server_fd.fd;

1149

1150#ifdef _WIN32

1151 u_long mode = enable ? 1 : 0;

1152 if (ioctlsocket(fd, FIONBIO, &mode) != 0) return SIGIL_FALSE;

1153 conn->nonblocking = enable;

1154 return SIGIL_TRUE;

1155#else

1156 int flags = fcntl(fd, F_GETFL, 0);

1157 if (flags == -1) return SIGIL_FALSE;

1158

1159 if (enable) {

1160 flags |= O_NONBLOCK;

1161 } else {

1162 flags &= ~O_NONBLOCK;

1163 }

1164

1165 if (fcntl(fd, F_SETFL, flags) == -1) return SIGIL_FALSE;

1166 /* Recorded only after the fd actually changed mode, so the flag can

1167 * never claim a mode the socket is not in. */

1168 conn->nonblocking = enable;

1169 return SIGIL_TRUE;

1170#endif

1171}

1172

1173/*

1174 * Core of tls-upgrade, shared with tls-upgrade/status. Assumes the

1175 * arguments have already been validated.

1176 */

1177static Value tls_upgrade_core(SigilVM *vm, int argc, Value *args,

1178 const char **status_out, TlsDiagnostics *details)

1179{

1180 *status_out = "tls-init-failed";

1181

1182 if (ensure_tls_initialized() < 0) {

1183 return SIGIL_FALSE;

1184 }

1185

1186 /* Extract fd from socket foreign data (fd is first int field of SocketData) */

1187 int *socket_data = (int *)sigil_foreign_data(args[0]);

1188 int existing_fd = socket_data[0];

1189 int closed = socket_data[2]; /* closed is third int field */

1190

1191 if (closed || existing_fd < 0) {

1192 sigil__vm_error(vm, SIGIL_ERR_IO, "tls-upgrade: socket is closed");

1193 return SIGIL_UNDEFINED;

1194 }

1195

1196 /* Mark the original socket as closed so it won't close the fd on GC */

1197 socket_data[2] = 1; /* closed = 1 */

1198

1199 /* Optional handshake timeout (milliseconds); <= 0 or absent = blocking. */

1200 long handshake_timeout_ms = 0;

1201 if (argc >= 3 && sigil_is_fixnum(args[2])) {

1202 handshake_timeout_ms = (long)sigil_as_fixnum(args[2]);

1203 }

1204

1205 SigilString *host_str = (SigilString *)sigil_as_ptr(args[1]);

1206

1207 /* Null-terminate hostname */

1208 char *hostname = malloc(host_str->byte_length + 1);

1209 if (!hostname) return SIGIL_FALSE;

1210 memcpy(hostname, host_str->data, host_str->byte_length);

1211 hostname[host_str->byte_length] = '\0';

1212

1213 /* Allocate connection structure */

1214 TlsConnectionData *conn = calloc(1, sizeof(TlsConnectionData));

1215 if (!conn) {

1216 free(hostname);

1217 return SIGIL_FALSE;

1218 }

1219

1220 conn->closed = 0;

1221 int ret;

1222

1223 /* Initialize mbedTLS structures */

1224 mbedtls_net_init(&conn->server_fd);

1225 mbedtls_ssl_init(&conn->ssl);

1226 mbedtls_ssl_config_init(&conn->conf);

1227 mbedtls_x509_crt_init(&conn->cacert);

1228

1229 /* Use the existing fd instead of creating a new connection */

1230 conn->server_fd.fd = existing_fd;

1231

1232 /* Set up SSL configuration */

1233 ret = mbedtls_ssl_config_defaults(&conn->conf,

1234 MBEDTLS_SSL_IS_CLIENT,

1235 MBEDTLS_SSL_TRANSPORT_STREAM,

1236 MBEDTLS_SSL_PRESET_DEFAULT);

1237 if (ret != 0) {

1238 *status_out = "ssl-config-failed";

1239 goto cleanup_error;

1240 }

1241

1242 /* Configure certificate verification */

1243 if (global_insecure_mode) {

1244 mbedtls_ssl_conf_authmode(&conn->conf, MBEDTLS_SSL_VERIFY_NONE);

1245 } else if (global_cacert_loaded) {

1246 mbedtls_ssl_conf_authmode(&conn->conf, MBEDTLS_SSL_VERIFY_REQUIRED);

1247 mbedtls_ssl_conf_ca_chain(&conn->conf, &global_cacert, NULL);

1248 } else {

1249 mbedtls_ssl_conf_authmode(&conn->conf, MBEDTLS_SSL_VERIFY_NONE);

1250 }

1251 mbedtls_ssl_conf_rng(&conn->conf, mbedtls_ctr_drbg_random, &global_ctr_drbg);

1252

1253#ifdef SIGIL_TLS_DEBUG

1254 mbedtls_ssl_conf_dbg(&conn->conf, tls_debug_callback, NULL);

1255 mbedtls_debug_set_threshold(4);

1256#endif

1257

1258 /* Set up SSL context */

1259 ret = mbedtls_ssl_setup(&conn->ssl, &conn->conf);

1260 if (ret != 0) {

1261 *status_out = "ssl-setup-failed";

1262 goto cleanup_error;

1263 }

1264

1265 /* Set hostname for SNI */

1266 ret = mbedtls_ssl_set_hostname(&conn->ssl, hostname);

1267 if (ret != 0) {

1268 *status_out = "ssl-set-hostname-failed";

1269 goto cleanup_error;

1270 }

1271

1272 /* Perform TLS handshake on the existing connection (bounded when

1273 * handshake_timeout_ms > 0). An upgraded socket is ALREADY connected,

1274 * so every byte of its handshake sits past the connect phase — the

1275 * unbounded window here is strictly wider than tls-connect's. */

1276 ret = sigil_tls_run_handshake(conn, handshake_timeout_ms, details);

1277 if (ret == SIGIL_TLS_HS_TIMEOUT) {

1278 *status_out = "handshake-timeout";

1279 goto cleanup_error;

1280 }

1281 if (ret != SIGIL_TLS_HS_OK) {

1282 *status_out = "handshake-failed";

1283 goto cleanup_error;

1284 }

1285

1286 free(hostname);

1287 *status_out = "connected";

1288 return make_tls_connection(vm, conn);

1289

1290cleanup_error:

1291 /* We took ownership of the fd (the socket object was marked closed

1292 * above), so we own closing it. Closing it directly rather than through

1293 * mbedtls_net_free keeps mbedTLS's own bookkeeping out of a path where

1294 * server_fd may never have been handed to it. */

1295 if (conn->server_fd.fd >= 0) {

1296#ifdef _WIN32

1297 closesocket(conn->server_fd.fd);

1298#else

1299 close(conn->server_fd.fd);

1300#endif

1301 }

1302 conn->server_fd.fd = -1; /* Prevent double-close in mbedtls_net_free */

1303 mbedtls_net_free(&conn->server_fd);

1304 mbedtls_ssl_free(&conn->ssl);

1305 mbedtls_ssl_config_free(&conn->conf);

1306 mbedtls_x509_crt_free(&conn->cacert);

1307 free(conn);

1308 free(hostname);

1309 return SIGIL_FALSE;

1310}

1311

1312/* Shared argument validation for tls-upgrade and tls-upgrade/status.

1313 * Returns 0 on success, -1 when a VM type error has been raised. */

1314static int tls_upgrade_check_args(SigilVM *vm, Value *args, const char *who)

1315{

1316 char msg[96];

1317

1318 if (!sigil_is_foreign(args[0])) {

1319 snprintf(msg, sizeof(msg), "%s: expected socket", who);

1320 sigil__vm_error(vm, SIGIL_ERR_TYPE, msg);

1321 return -1;

1322 }

1323

1324 Value socket_tag = sigil_intern_symbol(vm, "socket", 6);

1325 if (sigil_foreign_type(args[0]) != socket_tag) {

1326 snprintf(msg, sizeof(msg), "%s: expected socket", who);

1327 sigil__vm_error(vm, SIGIL_ERR_TYPE, msg);

1328 return -1;

1329 }

1330

1331 if (!sigil_is_string(args[1])) {

1332 snprintf(msg, sizeof(msg), "%s: expected string for hostname", who);

1333 sigil__vm_error(vm, SIGIL_ERR_TYPE, msg);

1334 return -1;

1335 }

1336 return 0;

1337}

1338

1339/*

1340 * tls-upgrade socket hostname [handshake-timeout-ms] -> tls-connection | #f

1341 * Upgrade an existing TCP socket to a TLS connection via STARTTLS.

1342 * Takes ownership of the socket's file descriptor. The original socket

1343 * object should not be used after this call.

1344 *

1345 * The optional handshake-timeout-ms bounds the handshake. Omitted or <= 0

1346 * keeps the original blocking handshake. Ignored on Windows.

1347 */

1348static Value native_tls_upgrade(SigilVM *vm, int argc, Value *args)

1349{

1350 const char *status = NULL;

1351

1352 if (tls_upgrade_check_args(vm, args, "tls-upgrade") < 0) {

1353 return SIGIL_UNDEFINED;

1354 }

1355 return tls_upgrade_core(vm, argc, args, &status, NULL);

1356}

1357

1358/*

1359 * tls-upgrade/status socket hostname [handshake-timeout-ms]

1360 * -> (status-string . tls-connection | #f)

1361 *

1362 * Same upgrade as tls-upgrade, reporting why it failed. Statuses match

1363 * tls-connect/status, minus the connect-phase ones.

1364 */

1365static Value native_tls_upgrade_status(SigilVM *vm, int argc, Value *args)

1366{

1367 const char *status = "tls-init-failed";

1368

1369 if (tls_upgrade_check_args(vm, args, "tls-upgrade/status") < 0) {

1370 return SIGIL_UNDEFINED;

1371 }

1372

1373 Value conn = tls_upgrade_core(vm, argc, args, &status, NULL);

1374 return make_tls_status(vm, status, conn);

1375}

1376

1377static Value native_tls_upgrade_details(SigilVM *vm, int argc, Value *args)

1378{

1379 const char *status = "tls-init-failed";

1380 TlsDiagnostics details = {0};

1381 if (tls_upgrade_check_args(vm, args, "tls-upgrade/details") < 0)

1382 return SIGIL_UNDEFINED;

1383 Value conn = tls_upgrade_core(vm, argc, args, &status, &details);

1384 return make_tls_details(vm, status, conn, &details);

1385}

1386

1387/*

1388 * Hook implementations for TLS integration with socket layer.

1389 * These are registered with sigil-lib during module init.

1390 */

1391

1392/* Get the underlying file descriptor from a TLS connection. */

1393static int tls_get_fd_impl(Value v)

1394{

1395 if (!is_tls_connection(v)) return -1;

1396 TlsConnectionData *conn = as_tls_connection(v);

1397 if (conn->closed) return -1;

1398 return conn->server_fd.fd;

1399}

1400

1401/* Check if a value is a TLS connection. */

1402static int tls_is_connection_impl(Value v)

1403{

1404 return is_tls_connection(v);

1405}

1406

1407/*

1408 * Helper macro for module-scoped registration with export

1409 */

1410#define REGISTER_AND_EXPORT(name, func, arity, doc) \

1411 sigil_module_register_native(vm, name, func, arity, doc); \

1412 sigil_module_export(vm, name)

1413

1414/*

1415 * Initialize the (sigil tls) module.

1416 * This is called at VM startup.

1417 */

1418void sigil__init_sigil_tls_module(SigilVM *vm)

1419{

1420 /* Initialize TLS connection type tag */

1421 tls_connection_type_tag = sigil_intern_symbol(vm, "tls-connection", 14);

1422

1423 /* Register hooks so socket-select can work with TLS connections */

1424 sigil__register_tls_hooks(tls_get_fd_impl, tls_is_connection_impl);

1425

1426 SigilModule *module = sigil_begin_module(vm, "(sigil tls)");

1427 if (!module) return;

1428

1429 /* Type predicate */

1430 REGISTER_AND_EXPORT("tls-connection?", native_tls_connectionp,

1431 SIGIL_ARITY_EXACT(1), "Check if value is a TLS connection");

1432

1433 /* Connection operations */

1434 REGISTER_AND_EXPORT("tls-connect/details", native_tls_connect_details,

1435 SIGIL_ARITY_RANGE(2, 4), "Connect to TLS with per-attempt diagnostics");

1436 REGISTER_AND_EXPORT("tls-connect", native_tls_connect,

1437 SIGIL_ARITY_RANGE(2, 4), "Connect to TLS server");

1438 REGISTER_AND_EXPORT("tls-connect/status", native_tls_connect_status,

1439 SIGIL_ARITY_RANGE(2, 4),

1440 "Connect to TLS server, reporting (status . conn|#f)");

1441 REGISTER_AND_EXPORT("tls-read", native_tls_read,

1442 SIGIL_ARITY_RANGE(1, 2), "Read from TLS connection");

1443 REGISTER_AND_EXPORT("tls-read-bytevector", native_tls_read_bytevector,

1444 SIGIL_ARITY_RANGE(1, 2), "Read raw bytes from TLS connection");

1445 REGISTER_AND_EXPORT("tls-write", native_tls_write,

1446 SIGIL_ARITY_RANGE(2, 4), "Write to TLS connection");

1447 REGISTER_AND_EXPORT("tls-close", native_tls_close,

1448 SIGIL_ARITY_EXACT(1), "Close TLS connection");

1449 REGISTER_AND_EXPORT("tls-closed?", native_tls_closedp,

1450 SIGIL_ARITY_EXACT(1), "Check if TLS connection is closed");

1451 REGISTER_AND_EXPORT("tls-set-non-blocking!", native_tls_set_non_blocking,

1452 SIGIL_ARITY_RANGE(1, 2), "Set TLS connection to non-blocking mode");

1453

1454 /* STARTTLS support */

1455 REGISTER_AND_EXPORT("tls-upgrade/details", native_tls_upgrade_details,

1456 SIGIL_ARITY_RANGE(2, 3), "Upgrade to TLS with per-attempt diagnostics");

1457 REGISTER_AND_EXPORT("tls-upgrade", native_tls_upgrade,

1458 SIGIL_ARITY_RANGE(2, 3), "Upgrade existing TCP socket to TLS connection");

1459 REGISTER_AND_EXPORT("tls-upgrade/status", native_tls_upgrade_status,

1460 SIGIL_ARITY_RANGE(2, 3),

1461 "Upgrade a TCP socket to TLS, reporting (status . conn|#f)");

1462

1463 sigil_end_module(vm);

1464}

1465

1466#undef REGISTER_AND_EXPORT

1467

1468#endif /* !__EMSCRIPTEN__ */