Commit58f34a86Recorded4 Aug 2026Repositorysigil-tls
tls: bound the TLS handshake, and say when it timed out
Message
connect-timeout-ms stops at the moment the peer accepts. Everything after that -- the whole handshake -- was an unbounded blocking read. A peer that accepts a connection and then never sends a ServerHello left the caller parked in read() forever, which under Sigil's cooperative scheduler freezes the entire process rather than failing one request.
tls-connect and tls-upgrade take an optional handshake-timeout-ms. When set, handshake reads go through mbedtls_net_recv_timeout under a deadline covering the whole handshake, not each read, so a peer dripping bytes cannot extend it. The read timeout is unwound before the connection is handed back, so an established connection reads exactly as before. Omitted or <= 0 keeps the original blocking handshake.
tls-connect/status and tls-upgrade/status report (status . conn-or-#f), so "handshake-timeout" (the peer went silent) stays distinguishable from "handshake-failed" (the peer refused us). Those are retried differently and a single flat #f cannot express the difference.
Also closes an fd leak on the tls-upgrade failure path: the socket object is marked closed before the handshake, so nothing else owned that descriptor. Previously unreachable in practice; a bounded handshake makes it reachable.
Changed
native/tls.c | 384 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-------------------------------
src/sigil/tls.sgl | 57 ++++++++++++++++++++++----
test/test-tls.sgl | 107 ++++++++++++++++++++++++++++++++++++++++++++++++-
3 files changed, 473 insertions(+), 75 deletions(-)Diff
native/tls.cmodified
@@ -335,28 +335,125 @@ static int sigil_tls_connect_timeout(mbedtls_net_context *ctx,
335
#endif /* !_WIN32 */ 336
337
/*−338
* tls-connect hostname port [connect-timeout-ms] -> tls-connection | #f−339
* Establish a TLS connection to the specified host and port.−340
* Returns a TLS connection object on success, #f on failure.+338
* Handshake outcomes, shared by tls-connect and tls-upgrade. 339
*−342
* The optional connect-timeout-ms (a positive integer) bounds the TCP−343
* connect phase via a non-blocking connect + select with try-next-address,−344
* so a blackholed address can't hang on the OS SYN timeout. Omitted or <= 0−345
* keeps the original blocking mbedtls_net_connect (default behavior−346
* unchanged). On Windows the timeout is ignored (blocking connect).+340
* TIMEOUT is deliberately distinct from FAILED: "the peer never answered"+341
* and "the peer refused us" are different facts, and a caller retries them+342
* differently. Folding them together is what let a stalled handshake read+343
* as an ordinary connection failure. 344
*/−348
static Value native_tls_connect(SigilVM *vm, int argc, Value *args)+345
#define SIGIL_TLS_HS_OK 0+346
#define SIGIL_TLS_HS_TIMEOUT 1+347
#define SIGIL_TLS_HS_FAILED 2+348
+349
/*+350
* Run the TLS handshake on an already-connected conn->server_fd.+351
*+352
* With handshake_timeout_ms <= 0 (the default) this is byte-for-byte the+353
* original blocking handshake: blocking mbedtls_net_recv as the BIO and a+354
* loop that only retries on WANT_READ/WANT_WRITE.+355
*+356
* With a positive handshake_timeout_ms, handshake reads are driven through+357
* mbedtls_net_recv_timeout, which selects on the socket and returns+358
* MBEDTLS_ERR_SSL_TIMEOUT when nothing arrives. This is the segment that+359
* connect-timeout-ms does NOT cover: once a peer has ACCEPTED the TCP+360
* connection, the connect phase is over and the handshake read that follows+361
* was previously unbounded. A peer that accepts and then never sends a+362
* ServerHello wedged a production monitoring service for 55 days.+363
*+364
* The deadline is on the WHOLE handshake, not per read: each iteration+365
* re-budgets the remaining time, so a peer dripping one byte just under the+366
* interval cannot extend the wait indefinitely.+367
*+368
* The read timeout is unwound before returning, so an established+369
* connection's subsequent tls-read calls behave exactly as before. Only the+370
* handshake is bounded here.+371
*/+372
static int sigil_tls_run_handshake(TlsConnectionData *conn, long handshake_timeout_ms) 373
{−350
(void)argc;+374
int ret; 375
−352
if (!sigil_is_string(args[0])) {−353
sigil__vm_error(vm, SIGIL_ERR_TYPE, "tls-connect: expected string for hostname");−354
return SIGIL_UNDEFINED;+376
#ifndef _WIN32+377
if (handshake_timeout_ms > 0) {+378
int outcome = SIGIL_TLS_HS_OK;+379
long deadline = sigil_tls_now_ms() + handshake_timeout_ms;+380
+381
mbedtls_ssl_set_bio(&conn->ssl, &conn->server_fd,+382
mbedtls_net_send, mbedtls_net_recv,+383
mbedtls_net_recv_timeout);+384
+385
for (;;) {+386
long remaining = deadline - sigil_tls_now_ms();+387
if (remaining <= 0) {+388
outcome = SIGIL_TLS_HS_TIMEOUT;+389
break;+390
}+391
mbedtls_ssl_conf_read_timeout(&conn->conf, (uint32_t)remaining);+392
+393
ret = mbedtls_ssl_handshake(&conn->ssl);+394
if (ret == 0) {+395
break;+396
}+397
if (ret == MBEDTLS_ERR_SSL_TIMEOUT) {+398
outcome = SIGIL_TLS_HS_TIMEOUT;+399
break;+400
}+401
if (ret != MBEDTLS_ERR_SSL_WANT_READ &&+402
ret != MBEDTLS_ERR_SSL_WANT_WRITE) {+403
outcome = SIGIL_TLS_HS_FAILED;+404
break;+405
}+406
}+407
+408
/* Restore unbounded reads + the plain BIO for the session. */+409
mbedtls_ssl_conf_read_timeout(&conn->conf, 0);+410
mbedtls_ssl_set_bio(&conn->ssl, &conn->server_fd,+411
mbedtls_net_send, mbedtls_net_recv, NULL);+412
return outcome; 413
}−356
if (!sigil_is_fixnum(args[1])) {−357
sigil__vm_error(vm, SIGIL_ERR_TYPE, "tls-connect: expected integer for port");−358
return SIGIL_UNDEFINED;+414
#else+415
(void)handshake_timeout_ms;+416
#endif+417
+418
mbedtls_ssl_set_bio(&conn->ssl, &conn->server_fd,+419
mbedtls_net_send, mbedtls_net_recv, NULL);+420
+421
while ((ret = mbedtls_ssl_handshake(&conn->ssl)) != 0) {+422
if (ret != MBEDTLS_ERR_SSL_WANT_READ && ret != MBEDTLS_ERR_SSL_WANT_WRITE) {+423
return SIGIL_TLS_HS_FAILED;+424
} 425
}+426
return SIGIL_TLS_HS_OK;+427
}+428
+429
/*+430
* Build the (status . connection-or-#f) pair returned by the /status+431
* variants. `status` is a short stable string, e.g. "connected",+432
* "handshake-timeout".+433
*/+434
static Value make_tls_status(SigilVM *vm, const char *status, Value conn)+435
{+436
Value status_val = sigil_make_string(vm, status, strlen(status));+437
sigil__gc_push_temp_root(vm, status_val);+438
sigil__gc_push_temp_root(vm, conn);+439
Value result = sigil_cons(vm, status_val, conn);+440
sigil__gc_pop_temp_root(vm);+441
sigil__gc_pop_temp_root(vm);+442
return result;+443
}+444
+445
/*+446
* Core of tls-connect. Returns the connection value, or SIGIL_FALSE on+447
* failure, and writes a short stable status string through *status_out+448
* ("connected", "tcp-connect-failed", "handshake-timeout", ...).+449
*+450
* Both tls-connect (which discards the status) and tls-connect/status+451
* (which surfaces it) run this, so the two can never drift apart.+452
*/+453
static Value tls_connect_core(SigilVM *vm, int argc, Value *args,+454
const char **status_out)+455
{+456
*status_out = "tls-init-failed"; 457
458
if (ensure_tls_initialized() < 0) { 459
return SIGIL_FALSE;@@ -371,6 +468,12 @@ static Value native_tls_connect(SigilVM *vm, int argc, Value *args)
468
connect_timeout_ms = (long)sigil_as_fixnum(args[2]); 469
} 470
+471
/* Optional handshake timeout (milliseconds); <= 0 or absent = blocking. */+472
long handshake_timeout_ms = 0;+473
if (argc >= 4 && sigil_is_fixnum(args[3])) {+474
handshake_timeout_ms = (long)sigil_as_fixnum(args[3]);+475
}+476
477
/* Null-terminate hostname */ 478
char *hostname = malloc(host_str->byte_length + 1); 479
if (!hostname) return SIGIL_FALSE;@@ -389,7 +492,6 @@ static Value native_tls_connect(SigilVM *vm, int argc, Value *args)
492
493
conn->closed = 0; 494
int ret;−392
const char *error_stage = NULL; 495
496
/* Initialize mbedTLS structures */ 497
mbedtls_net_init(&conn->server_fd);@@ -414,7 +516,7 @@ static Value native_tls_connect(SigilVM *vm, int argc, Value *args)
516
MBEDTLS_NET_PROTO_TCP); 517
#endif 518
if (ret != 0) {−417
error_stage = "TCP connect";+519
*status_out = "tcp-connect-failed"; 520
goto cleanup_error; 521
} 522
@@ -424,7 +526,7 @@ static Value native_tls_connect(SigilVM *vm, int argc, Value *args)
526
MBEDTLS_SSL_TRANSPORT_STREAM, 527
MBEDTLS_SSL_PRESET_DEFAULT); 528
if (ret != 0) {−427
error_stage = "SSL config defaults";+529
*status_out = "ssl-config-failed"; 530
goto cleanup_error; 531
} 532
@@ -450,30 +552,30 @@ static Value native_tls_connect(SigilVM *vm, int argc, Value *args)
552
/* Set up SSL context */ 553
ret = mbedtls_ssl_setup(&conn->ssl, &conn->conf); 554
if (ret != 0) {−453
error_stage = "SSL setup";+555
*status_out = "ssl-setup-failed"; 556
goto cleanup_error; 557
} 558
559
/* Set hostname for SNI (Server Name Indication) */ 560
ret = mbedtls_ssl_set_hostname(&conn->ssl, hostname); 561
if (ret != 0) {−460
error_stage = "SSL set hostname";+562
*status_out = "ssl-set-hostname-failed"; 563
goto cleanup_error; 564
} 565
−464
/* Set I/O functions */−465
mbedtls_ssl_set_bio(&conn->ssl, &conn->server_fd,−466
mbedtls_net_send, mbedtls_net_recv, NULL);−467
−468
/* Perform TLS handshake */−469
while ((ret = mbedtls_ssl_handshake(&conn->ssl)) != 0) {−470
if (ret != MBEDTLS_ERR_SSL_WANT_READ && ret != MBEDTLS_ERR_SSL_WANT_WRITE) {−471
error_stage = "TLS handshake";−472
goto cleanup_error;−473
}+566
/* Perform TLS handshake (bounded when handshake_timeout_ms > 0). */+567
ret = sigil_tls_run_handshake(conn, handshake_timeout_ms);+568
if (ret == SIGIL_TLS_HS_TIMEOUT) {+569
*status_out = "handshake-timeout";+570
goto cleanup_error;+571
}+572
if (ret != SIGIL_TLS_HS_OK) {+573
*status_out = "handshake-failed";+574
goto cleanup_error; 575
} 576
577
free(hostname);+578
*status_out = "connected"; 579
return make_tls_connection(vm, conn); 580
581
cleanup_error:@@ -486,6 +588,82 @@ cleanup_error:
588
return SIGIL_FALSE; 589
} 590
+591
/* Shared argument validation for tls-connect and tls-connect/status.+592
* Returns 0 on success, -1 when a VM type error has been raised. */+593
static int tls_connect_check_args(SigilVM *vm, Value *args, const char *who)+594
{+595
if (!sigil_is_string(args[0])) {+596
char msg[96];+597
snprintf(msg, sizeof(msg), "%s: expected string for hostname", who);+598
sigil__vm_error(vm, SIGIL_ERR_TYPE, msg);+599
return -1;+600
}+601
if (!sigil_is_fixnum(args[1])) {+602
char msg[96];+603
snprintf(msg, sizeof(msg), "%s: expected integer for port", who);+604
sigil__vm_error(vm, SIGIL_ERR_TYPE, msg);+605
return -1;+606
}+607
return 0;+608
}+609
+610
/*+611
* tls-connect hostname port [connect-timeout-ms [handshake-timeout-ms]]+612
* -> tls-connection | #f+613
*+614
* Establish a TLS connection to the specified host and port.+615
* Returns a TLS connection object on success, #f on failure.+616
*+617
* The optional connect-timeout-ms (a positive integer) bounds the TCP+618
* connect phase via a non-blocking connect + select with try-next-address,+619
* so a blackholed address can't hang on the OS SYN timeout.+620
*+621
* The optional handshake-timeout-ms bounds the TLS HANDSHAKE, which the+622
* connect timeout does not reach: a peer that ACCEPTS the connection and+623
* then never sends a ServerHello leaves the connect phase already complete+624
* and the handshake read blocking forever. Both are omitted or <= 0 by+625
* default, keeping the original blocking behavior. Ignored on Windows.+626
*+627
* `tls-connect` collapses every failure to #f. Use `tls-connect/status`+628
* when you need to tell "the peer never answered" from "the peer refused".+629
*/+630
static Value native_tls_connect(SigilVM *vm, int argc, Value *args)+631
{+632
const char *status = NULL;+633
+634
if (tls_connect_check_args(vm, args, "tls-connect") < 0) {+635
return SIGIL_UNDEFINED;+636
}+637
return tls_connect_core(vm, argc, args, &status);+638
}+639
+640
/*+641
* tls-connect/status hostname port [connect-timeout-ms [handshake-timeout-ms]]+642
* -> (status-string . tls-connection | #f)+643
*+644
* Same connection attempt as tls-connect, but reports WHY it failed:+645
*+646
* "connected" the pair's cdr is a live connection+647
* "tcp-connect-failed" never reached the peer+648
* "handshake-timeout" peer accepted, then went silent (bounded here)+649
* "handshake-failed" peer rejected us (cert, version, alert)+650
* "ssl-*-failed" local setup fault+651
*+652
* "handshake-timeout" is the case that has to stay distinguishable: a+653
* caller retries a silent peer differently from one that refused it.+654
*/+655
static Value native_tls_connect_status(SigilVM *vm, int argc, Value *args)+656
{+657
const char *status = "tls-init-failed";+658
+659
if (tls_connect_check_args(vm, args, "tls-connect/status") < 0) {+660
return SIGIL_UNDEFINED;+661
}+662
+663
Value conn = tls_connect_core(vm, argc, args, &status);+664
return make_tls_status(vm, status, conn);+665
}+666
667
/* 668
* tls-read connection [max-bytes] -> string | #f | eof-object 669
* Read data from TLS connection.@@ -729,31 +907,13 @@ static Value native_tls_set_non_blocking(SigilVM *vm, int argc, Value *args)
907
} 908
909
/*−732
* tls-upgrade socket hostname -> tls-connection | #f−733
* Upgrade an existing TCP socket to a TLS connection via STARTTLS.−734
* Takes ownership of the socket's file descriptor. The original socket−735
* object should not be used after this call.+910
* Core of tls-upgrade, shared with tls-upgrade/status. Assumes the+911
* arguments have already been validated. 912
*/−737
static Value native_tls_upgrade(SigilVM *vm, int argc, Value *args)+913
static Value tls_upgrade_core(SigilVM *vm, int argc, Value *args,+914
const char **status_out) 915
{−739
(void)argc;−740
−741
/* Validate socket argument - must be a foreign object with "socket" type tag */−742
if (!sigil_is_foreign(args[0])) {−743
sigil__vm_error(vm, SIGIL_ERR_TYPE, "tls-upgrade: expected socket");−744
return SIGIL_UNDEFINED;−745
}−746
−747
Value socket_tag = sigil_intern_symbol(vm, "socket", 6);−748
if (sigil_foreign_type(args[0]) != socket_tag) {−749
sigil__vm_error(vm, SIGIL_ERR_TYPE, "tls-upgrade: expected socket");−750
return SIGIL_UNDEFINED;−751
}−752
−753
if (!sigil_is_string(args[1])) {−754
sigil__vm_error(vm, SIGIL_ERR_TYPE, "tls-upgrade: expected string for hostname");−755
return SIGIL_UNDEFINED;−756
}+916
*status_out = "tls-init-failed"; 917
918
if (ensure_tls_initialized() < 0) { 919
return SIGIL_FALSE;@@ -772,6 +932,12 @@ static Value native_tls_upgrade(SigilVM *vm, int argc, Value *args)
932
/* Mark the original socket as closed so it won't close the fd on GC */ 933
socket_data[2] = 1; /* closed = 1 */ 934
+935
/* Optional handshake timeout (milliseconds); <= 0 or absent = blocking. */+936
long handshake_timeout_ms = 0;+937
if (argc >= 3 && sigil_is_fixnum(args[2])) {+938
handshake_timeout_ms = (long)sigil_as_fixnum(args[2]);+939
}+940
941
SigilString *host_str = (SigilString *)sigil_as_ptr(args[1]); 942
943
/* Null-terminate hostname */@@ -805,6 +971,7 @@ static Value native_tls_upgrade(SigilVM *vm, int argc, Value *args)
971
MBEDTLS_SSL_TRANSPORT_STREAM, 972
MBEDTLS_SSL_PRESET_DEFAULT); 973
if (ret != 0) {+974
*status_out = "ssl-config-failed"; 975
goto cleanup_error; 976
} 977
@@ -827,32 +994,44 @@ static Value native_tls_upgrade(SigilVM *vm, int argc, Value *args)
994
/* Set up SSL context */ 995
ret = mbedtls_ssl_setup(&conn->ssl, &conn->conf); 996
if (ret != 0) {+997
*status_out = "ssl-setup-failed"; 998
goto cleanup_error; 999
} 1000
1001
/* Set hostname for SNI */ 1002
ret = mbedtls_ssl_set_hostname(&conn->ssl, hostname); 1003
if (ret != 0) {+1004
*status_out = "ssl-set-hostname-failed"; 1005
goto cleanup_error; 1006
} 1007
−839
/* Set I/O functions */−840
mbedtls_ssl_set_bio(&conn->ssl, &conn->server_fd,−841
mbedtls_net_send, mbedtls_net_recv, NULL);−842
−843
/* Perform TLS handshake on existing connection */−844
while ((ret = mbedtls_ssl_handshake(&conn->ssl)) != 0) {−845
if (ret != MBEDTLS_ERR_SSL_WANT_READ && ret != MBEDTLS_ERR_SSL_WANT_WRITE) {−846
goto cleanup_error;−847
}+1008
/* Perform TLS handshake on the existing connection (bounded when+1009
* handshake_timeout_ms > 0). An upgraded socket is ALREADY connected,+1010
* so every byte of its handshake sits past the connect phase — the+1011
* unbounded window here is strictly wider than tls-connect's. */+1012
ret = sigil_tls_run_handshake(conn, handshake_timeout_ms);+1013
if (ret == SIGIL_TLS_HS_TIMEOUT) {+1014
*status_out = "handshake-timeout";+1015
goto cleanup_error;+1016
}+1017
if (ret != SIGIL_TLS_HS_OK) {+1018
*status_out = "handshake-failed";+1019
goto cleanup_error; 1020
} 1021
1022
free(hostname);+1023
*status_out = "connected"; 1024
return make_tls_connection(vm, conn); 1025
1026
cleanup_error:−854
/* Don't call mbedtls_net_free - it would close the fd which we took ownership of */−855
conn->server_fd.fd = -1; /* Prevent double-close */+1027
/* We took ownership of the fd (the socket object was marked closed+1028
* above), so we own closing it. Closing it directly rather than through+1029
* mbedtls_net_free keeps mbedTLS's own bookkeeping out of a path where+1030
* server_fd may never have been handed to it. */+1031
if (conn->server_fd.fd >= 0) {+1032
close(conn->server_fd.fd);+1033
}+1034
conn->server_fd.fd = -1; /* Prevent double-close in mbedtls_net_free */ 1035
mbedtls_net_free(&conn->server_fd); 1036
mbedtls_ssl_free(&conn->ssl); 1037
mbedtls_ssl_config_free(&conn->conf);@@ -862,6 +1041,71 @@ cleanup_error:
1041
return SIGIL_FALSE; 1042
} 1043
+1044
/* Shared argument validation for tls-upgrade and tls-upgrade/status.+1045
* Returns 0 on success, -1 when a VM type error has been raised. */+1046
static int tls_upgrade_check_args(SigilVM *vm, Value *args, const char *who)+1047
{+1048
char msg[96];+1049
+1050
if (!sigil_is_foreign(args[0])) {+1051
snprintf(msg, sizeof(msg), "%s: expected socket", who);+1052
sigil__vm_error(vm, SIGIL_ERR_TYPE, msg);+1053
return -1;+1054
}+1055
+1056
Value socket_tag = sigil_intern_symbol(vm, "socket", 6);+1057
if (sigil_foreign_type(args[0]) != socket_tag) {+1058
snprintf(msg, sizeof(msg), "%s: expected socket", who);+1059
sigil__vm_error(vm, SIGIL_ERR_TYPE, msg);+1060
return -1;+1061
}+1062
+1063
if (!sigil_is_string(args[1])) {+1064
snprintf(msg, sizeof(msg), "%s: expected string for hostname", who);+1065
sigil__vm_error(vm, SIGIL_ERR_TYPE, msg);+1066
return -1;+1067
}+1068
return 0;+1069
}+1070
+1071
/*+1072
* tls-upgrade socket hostname [handshake-timeout-ms] -> tls-connection | #f+1073
* Upgrade an existing TCP socket to a TLS connection via STARTTLS.+1074
* Takes ownership of the socket's file descriptor. The original socket+1075
* object should not be used after this call.+1076
*+1077
* The optional handshake-timeout-ms bounds the handshake. Omitted or <= 0+1078
* keeps the original blocking handshake. Ignored on Windows.+1079
*/+1080
static Value native_tls_upgrade(SigilVM *vm, int argc, Value *args)+1081
{+1082
const char *status = NULL;+1083
+1084
if (tls_upgrade_check_args(vm, args, "tls-upgrade") < 0) {+1085
return SIGIL_UNDEFINED;+1086
}+1087
return tls_upgrade_core(vm, argc, args, &status);+1088
}+1089
+1090
/*+1091
* tls-upgrade/status socket hostname [handshake-timeout-ms]+1092
* -> (status-string . tls-connection | #f)+1093
*+1094
* Same upgrade as tls-upgrade, reporting why it failed. Statuses match+1095
* tls-connect/status, minus the connect-phase ones.+1096
*/+1097
static Value native_tls_upgrade_status(SigilVM *vm, int argc, Value *args)+1098
{+1099
const char *status = "tls-init-failed";+1100
+1101
if (tls_upgrade_check_args(vm, args, "tls-upgrade/status") < 0) {+1102
return SIGIL_UNDEFINED;+1103
}+1104
+1105
Value conn = tls_upgrade_core(vm, argc, args, &status);+1106
return make_tls_status(vm, status, conn);+1107
}+1108
1109
/* 1110
* Hook implementations for TLS integration with socket layer. 1111
* These are registered with sigil-lib during module init.@@ -910,7 +1154,10 @@ void sigil__init_sigil_tls_module(SigilVM *vm)
1154
1155
/* Connection operations */ 1156
REGISTER_AND_EXPORT("tls-connect", native_tls_connect,−913
SIGIL_ARITY_RANGE(2, 3), "Connect to TLS server");+1157
SIGIL_ARITY_RANGE(2, 4), "Connect to TLS server");+1158
REGISTER_AND_EXPORT("tls-connect/status", native_tls_connect_status,Showing the first 500 of 517 diff lines for this file. This diff is INCOMPLETE; read the file or clone the repository for the rest.
src/sigil/tls.sglmodified
@@ -16,13 +16,15 @@
16
(export 17
tls-connection? 18
tls-connect+19
tls-connect/status 20
tls-read 21
tls-read-bytevector 22
tls-write 23
tls-close 24
tls-closed? 25
tls-set-non-blocking!−25
tls-upgrade)+26
tls-upgrade+27
tls-upgrade/status) 28
29
(begin 30
@@ -43,13 +45,42 @@
45
;;; the OS SYN-retransmit timeout. Omitted or <= 0 keeps the original 46
;;; blocking connect (default behavior unchanged). Ignored on Windows. 47
;;;+48
;;; A further optional `handshake-timeout-ms` bounds the TLS HANDSHAKE.+49
;;; The connect timeout does not reach it: once a peer has ACCEPTED the+50
;;; TCP connection the connect phase is over, and a peer that then never+51
;;; sends a ServerHello previously blocked the handshake read forever.+52
;;; Under Sigil's cooperative scheduler that freezes the whole process,+53
;;; so this is the difference between a failed request and a dead+54
;;; service. The bound covers the whole handshake, not each read.+55
;;; Omitted or <= 0 keeps the original blocking handshake.+56
;;; 57
;;; ```scheme−47
;;; (tls-connect "example.com" 443) ; => tls-connection | #f−48
;;; (tls-connect "example.com" 443 10000) ; 10s connect timeout+58
;;; (tls-connect "example.com" 443) ; => tls-connection | #f+59
;;; (tls-connect "example.com" 443 10000) ; 10s connect timeout+60
;;; (tls-connect "example.com" 443 10000 10000) ; + 10s handshake timeout 61
;;; ```−50
(define-native (tls-connect hostname port . connect-timeout-ms)+62
(define-native (tls-connect hostname port . timeouts-ms) 63
(: string? integer? -> any?)) 64
+65
;;; Like `tls-connect`, but returns `(status . connection-or-#f)` so a+66
;;; caller can tell WHY the attempt failed instead of seeing one flat #f.+67
;;;+68
;;; Statuses: `"connected"`, `"tcp-connect-failed"`,+69
;;; `"handshake-timeout"`, `"handshake-failed"`, `"ssl-config-failed"`,+70
;;; `"ssl-setup-failed"`, `"ssl-set-hostname-failed"`,+71
;;; `"tls-init-failed"`.+72
;;;+73
;;; `"handshake-timeout"` (the peer accepted and then went silent) and+74
;;; `"handshake-failed"` (the peer rejected us) are different facts and+75
;;; are retried differently, so they are kept apart.+76
;;;+77
;;; ```scheme+78
;;; (let ((r (tls-connect/status "example.com" 443 10000 10000)))+79
;;; (if (cdr r) (use-connection (cdr r)) (log-failure (car r))))+80
;;; ```+81
(define-native (tls-connect/status hostname port . timeouts-ms)+82
(: string? integer? -> pair?))+83
84
;;; Read data from a TLS connection. 85
;;; 86
;;; Returns a string with data, #f on error, or eof-object if the@@ -113,8 +144,20 @@
144
;;; Takes ownership of the socket's file descriptor; the original socket 145
;;; should not be used after this call. 146
;;;+147
;;; The optional `handshake-timeout-ms` bounds the handshake. An upgraded+148
;;; socket is already connected, so ALL of its handshake sits past the+149
;;; connect phase — the unbounded window here is strictly wider than+150
;;; `tls-connect`'s. Omitted or <= 0 keeps the original blocking+151
;;; handshake. Ignored on Windows.+152
;;; 153
;;; ```scheme−117
;;; (tls-upgrade sock "mail.example.com") ; => tls-connection | #f+154
;;; (tls-upgrade sock "mail.example.com") ; => tls-connection | #f+155
;;; (tls-upgrade sock "mail.example.com" 10000) ; 10s handshake bound 156
;;; ```−119
(define-native (tls-upgrade socket hostname)−120
(: any? string? -> any?))))+157
(define-native (tls-upgrade socket hostname . handshake-timeout-ms)+158
(: any? string? -> any?))+159
+160
;;; Like `tls-upgrade`, but returns `(status . connection-or-#f)`.+161
;;; Statuses match `tls-connect/status` minus the connect-phase ones.+162
(define-native (tls-upgrade/status socket hostname . handshake-timeout-ms)+163
(: any? string? -> pair?))))test/test-tls.sglmodified
@@ -1,6 +1,8 @@
1
(import (sigil test) 2
(sigil tls)−3
(sigil socket))+3
(sigil socket)+4
(sigil time)+5
(only (sigil math) inexact)) 6
7
;; ============================================================ 8
;; Type predicates@@ -55,4 +57,107 @@
57
(test "tls-close with non-connection raises error" 58
(assert-error (tls-close "not-a-connection")))) 59
+60
;; ============================================================+61
;; Handshake timeout+62
;; ============================================================+63
;;+64
;; THE STALL RIG. `tcp-listen` and then NEVER `tcp-accept`: the kernel+65
;; completes the TCP three-way handshake from the listen backlog, so the+66
;; client's connect() SUCCEEDS and the socket reaches ESTABLISHED. The+67
;; client then blocks reading a ServerHello that will never arrive.+68
;;+69
;; That is the shape that wedged a production monitoring service for 55+70
;; days, and the reason it matters here: because connect() has already+71
;; succeeded, `connect-timeout-ms` provably CANNOT fire against this rig.+72
;; Any bound observed below therefore comes from the handshake timeout and+73
;; from nothing else.+74
+75
(define (elapsed-seconds thunk)+76
(let* ((t0 (current-jiffy))+77
(result (thunk))+78
(dt (/ (inexact (- (current-jiffy) t0)) (jiffies-per-second))))+79
(cons dt result)))+80
+81
(define (stall-port sock)+82
(cadr (socket-local-address sock)))+83
+84
(test-group "handshake timeout"+85
;; POSITIVE CONTROL for the status API: it can report a NON-timeout+86
;; status. Without this, "handshake-timeout" below could just be the only+87
;; string the function ever produces.+88
(test "tls-connect/status reports tcp-connect-failed for a closed port"+89
(let ((r (tls-connect/status "127.0.0.1" 1 1000 1000)))+90
(assert-equal "tcp-connect-failed" (car r))+91
(assert-false (cdr r))))+92
+93
(test "tls-connect/status reports connected only with a live peer"+94
;; Guards the other direction: "connected" is not produced by a failure.+95
(let ((r (tls-connect/status "127.0.0.1" 1 1000 1000)))+96
(assert-false (equal? "connected" (car r)))))+97
+98
(test "handshake timeout bounds an accept-and-stall peer"+99
(let* ((server (tcp-listen 0))+100
(port (stall-port server)))+101
(let* ((measured (elapsed-seconds+102
(lambda () (tls-connect "127.0.0.1" port 1000 1000))))+103
(dt (car measured))+104
(conn (cdr measured)))+105
(socket-close server)+106
;; It must FAIL (the peer never completed a handshake) ...+107
(assert-false conn)+108
;; ... and it must fail on roughly the deadline, not merely+109
;; eventually. Pre-fix this call does not return at all; the upper+110
;; bound is what makes this a timeout assertion rather than an+111
;; "an error appeared" assertion.+112
(assert-true (>= dt 0.5))+113
(assert-true (<= dt 5.0)))))+114
+115
(test "handshake timeout is reported as handshake-timeout, not a generic failure"+116
(let* ((server (tcp-listen 0))+117
(port (stall-port server))+118
(r (tls-connect/status "127.0.0.1" port 1000 1000)))+119
(socket-close server)+120
(assert-equal "handshake-timeout" (car r))+121
(assert-false (cdr r))))+122
+123
(test "the deadline scales with the argument"+124
;; A bound that ignores its argument would satisfy the test above.+125
;; Two different deadlines must produce two different waits.+126
(let* ((server (tcp-listen 0))+127
(port (stall-port server))+128
(short (car (elapsed-seconds+129
(lambda () (tls-connect "127.0.0.1" port 1000 300)))))+130
(long (car (elapsed-seconds+131
(lambda () (tls-connect "127.0.0.1" port 1000 2000))))))+132
(socket-close server)+133
(assert-true (< short 1.0))+134
(assert-true (> long 1.5))+135
(assert-true (> long short))))+136
+137
(test "tls-upgrade honours a handshake timeout on an already-connected socket"+138
;; tls-upgrade's handshake is strictly MORE exposed than tls-connect's:+139
;; the socket is connected before the call, so every handshake byte is+140
;; past the connect phase. Bound it on its own rig.+141
(let* ((server (tcp-listen 0))+142
(port (stall-port server))+143
(client (tcp-connect "127.0.0.1" port)))+144
(assert-true (socket? client))+145
(let* ((measured (elapsed-seconds+146
(lambda () (tls-upgrade client "localhost" 1000))))+147
(dt (car measured))+148
(conn (cdr measured)))+149
(socket-close server)+150
(assert-false conn)+151
(assert-true (>= dt 0.5))+152
(assert-true (<= dt 5.0)))))+153
+154
(test "tls-upgrade/status reports handshake-timeout"+155
(let* ((server (tcp-listen 0))+156
(port (stall-port server))+157
(client (tcp-connect "127.0.0.1" port))+158
(r (tls-upgrade/status client "localhost" 1000)))+159
(socket-close server)+160
(assert-equal "handshake-timeout" (car r))+161
(assert-false (cdr r)))))+162
163
(run-tests)