src/sigil/tls.sgl — sigil-tls

1;;; (sigil tls) - TLS/SSL Connections

2;;;

3;;; Secure TCP connections using mbedTLS. Supports TLS 1.2 and TLS 1.3 client

4;;; connections with system CA certificate verification.

5;;;

6;;; ```scheme

7;;; (import (sigil tls))

8;;;

9;;; (let ((conn (tls-connect "example.com" 443)))

10;;; (tls-write conn "GET / HTTP/1.1\r\nHost: example.com\r\n\r\n")

11;;; (display (tls-read conn))

12;;; (tls-close conn))

13;;; ```

15(define-library (sigil tls)

16 (export

17 tls-connection?

18 tls-connect

19 tls-connect/status

20 tls-connect/details

21 tls-read

22 tls-read-bytevector

23 tls-write

24 tls-close

25 tls-closed?

26 tls-set-non-blocking!

27 tls-upgrade

28 tls-upgrade/status

29 tls-upgrade/details)

31 (begin

33 ;;; Check if value is a TLS connection object.

34 (define-native (tls-connection? value)

35 (: any? -> boolean?))

37 ;;; Establish a TLS connection to the specified host and port.

38 ;;;

39 ;;; Returns a TLS connection object on success, #f on failure.

40 ;;; Certificates are verified against system CA certificates by default.

41 ;;; Set SIGIL_TLS_INSECURE=1 to skip verification (testing only).

42 ;;;

43 ;;; An optional `connect-timeout-ms` (positive integer milliseconds)

44 ;;; bounds the TCP connect phase: the underlying connect is made

45 ;;; non-blocking and each resolved address is tried with `select`

46 ;;; under a shared deadline, so a blackholed address cannot hang on

47 ;;; the OS SYN-retransmit timeout. Omitted or <= 0 keeps the original

48 ;;; blocking connect (default behavior unchanged). Ignored on Windows.

49 ;;;

50 ;;; A further optional `handshake-timeout-ms` bounds the TLS HANDSHAKE.

51 ;;; The connect timeout does not reach it: once a peer has ACCEPTED the

52 ;;; TCP connection the connect phase is over, and a peer that then never

53 ;;; sends a ServerHello previously blocked the handshake read forever.

54 ;;; Under Sigil's cooperative scheduler that freezes the whole process,

55 ;;; so this is the difference between a failed request and a dead

56 ;;; service.

57 ;;;

58 ;;; The bound is a TOTAL over the handshake, not a per-read one. That

59 ;;; distinction is the whole value: a per-read bound is defeated by a

60 ;;; peer that DRIPS rather than one that goes silent, because mbedTLS

61 ;;; restarts its read timeout on every partial read. Measured against an

62 ;;; earlier build, one byte every 600 ms made a 1000 ms per-read bound

63 ;;; take 13 s to fire, and never fire at all while the drip continued.

64 ;;;

65 ;;; Omitted or <= 0 keeps the original blocking handshake.

66 ;;;

67 ;;; ```scheme

68 ;;; (tls-connect "example.com" 443) ; => tls-connection | #f

69 ;;; (tls-connect "example.com" 443 10000) ; 10s connect timeout

70 ;;; (tls-connect "example.com" 443 10000 10000) ; + 10s handshake timeout

71 ;;; ```

72 (define-native (tls-connect hostname port . timeouts-ms)

73 (: string? integer? -> any?))

75 ;;; Like `tls-connect`, but returns `(status . connection-or-#f)` so a

76 ;;; caller can tell WHY the attempt failed instead of seeing one flat #f.

77 ;;;

78 ;;; Statuses: `"connected"`, `"tcp-connect-failed"`,

79 ;;; `"handshake-timeout"`, `"handshake-failed"`, `"ssl-config-failed"`,

80 ;;; `"ssl-setup-failed"`, `"ssl-set-hostname-failed"`,

81 ;;; `"tls-init-failed"`.

82 ;;;

83 ;;; `"handshake-timeout"` (the peer accepted and then went silent) and

84 ;;; `"handshake-failed"` (the peer rejected us) are different facts and

85 ;;; are retried differently, so they are kept apart.

86 ;;;

87 ;;; ```scheme

88 ;;; (let ((r (tls-connect/status "example.com" 443 10000 10000)))

89 ;;; (if (cdr r) (use-connection (cdr r)) (log-failure (car r))))

90 ;;; ```

91 (define-native (tls-connect/status hostname port . timeouts-ms)

92 (: string? integer? -> pair?))

94 ;;; Connect with per-attempt handshake diagnostics.

95 ;;;

96 ;;; Takes the same arguments and deadlines as tls-connect/status.

97 ;;; Returns a dictionary with status:, connection:, error-code:,

98 ;;; error-message:, handshake-state:, protocol:, cipher:, verify-flags:.

99 ;;; The connection is #f on failure; close a successful one with tls-close.

100 ;;; Error codes/messages are mbedTLS handshake errors, with 0/#f when no

101 ;;; handshake error is available. Consult status: for pre-handshake failures.

102 ;;; Handshake state is #f before a handshake, otherwise a diagnostic state

103 ;;; name (not a stable application error category). Protocol and cipher are

104 ;;; populated only after success. Verify flags are mbedTLS X.509 flags;

105 ;;; they do not establish verification when insecure mode was requested.

106 ;;; Each result owns its details; later attempts cannot overwrite it.

107 (define-native (tls-connect/details hostname port . timeouts-ms)

108 (: string? integer? -> dict?))

109

110 ;;; Read data from a TLS connection.

111 ;;;

112 ;;; Returns a string with data, #f on error, or eof-object if the

113 ;;; connection was closed by the peer. An optional max-bytes argument

114 ;;; controls the buffer size (default 4096).

115 ;;;

116 ;;; ```scheme

117 ;;; (tls-read conn) ; => string | #f | eof-object

118 ;;; (tls-read conn 8192) ; read up to 8192 bytes

119 ;;; ```

120 (define-native (tls-read connection . max-bytes)

121 (: any? -> any?))

122

123 ;;; Read raw bytes from a TLS connection into a bytevector.

124 ;;;

125 ;;; Like `tls-read` but returns a bytevector instead of a string,

126 ;;; preserving raw bytes without encoding interpretation.

127 ;;;

128 ;;; ```scheme

129 ;;; (tls-read-bytevector conn) ; => bytevector | #f | eof-object

130 ;;; (tls-read-bytevector conn 8192) ; read up to 8192 bytes

131 ;;; ```

132 (define-native (tls-read-bytevector connection . max-bytes)

133 (: any? -> any?))

134

135 ;;; Write data to a TLS connection.

136 ;;;

137 ;;; Accepts a string or bytevector. Returns the number of bytes

138 ;;; written, or #f on error.

139 ;;;

140 ;;; On a BLOCKING connection (the default) this writes the whole buffer

141 ;;; before returning, exactly as before.

142 ;;;

143 ;;; On a NON-BLOCKING connection (see `tls-set-non-blocking!`) it returns

144 ;;; the number of bytes actually committed, which may be `0`, so a caller

145 ;;; can poll against a deadline. Previously a non-blocking connection made

146 ;;; this spin in a hot loop that never returned, so a peer that stopped

147 ;;; reading could pin a CPU forever. A `0` return means retry the SAME

148 ;;; slice; a positive return means those bytes are committed and the next

149 ;;; call should start after them.

150 ;;;

151 ;;; The optional `start` and `end` byte offsets let a write loop resend

152 ;;; the tail of a buffer without copying it, keeping a large body O(n)

153 ;;; rather than O(n^2). This mirrors `socket-write`.

154 ;;;

155 ;;; ```scheme

156 ;;; (tls-write conn "GET / HTTP/1.1\r\n\r\n") ; => integer | #f

157 ;;; (tls-write conn body 4096) ; write from byte 4096 on

158 ;;; ```

159 (define-native (tls-write connection data . start-end)

160 (: any? (any-of string? bytevector?) -> (any-of integer? boolean?)))

161

162 ;;; Close a TLS connection.

163 ;;;

164 ;;; Sends a close notification and frees resources. Returns #t.

165 (define-native (tls-close connection)

166 (: any? -> boolean?))

167

168 ;;; Check if a TLS connection is closed.

169 (define-native (tls-closed? connection)

170 (: any? -> boolean?))

171

172 ;;; Set the underlying socket to non-blocking mode.

173 ;;;

174 ;;; Enable defaults to #t if not provided. Returns #t on success.

175 ;;;

176 ;;; ```scheme

177 ;;; (tls-set-non-blocking! conn) ; enable non-blocking

178 ;;; (tls-set-non-blocking! conn #f) ; disable non-blocking

179 ;;; ```

180 (define-native (tls-set-non-blocking! connection . enable)

181 (: any? -> boolean?))

182

183 ;;; Upgrade an existing TCP socket to a TLS connection.

184 ;;;

185 ;;; Performs a TLS handshake on an existing socket connection (STARTTLS).

186 ;;; Takes ownership of the socket's file descriptor; the original socket

187 ;;; should not be used after this call.

188 ;;;

189 ;;; The optional `handshake-timeout-ms` bounds the handshake. An upgraded

190 ;;; socket is already connected, so ALL of its handshake sits past the

191 ;;; connect phase — the unbounded window here is strictly wider than

192 ;;; `tls-connect`'s. Omitted or <= 0 keeps the original blocking

193 ;;; handshake. Ignored on Windows.

194 ;;;

195 ;;; ```scheme

196 ;;; (tls-upgrade sock "mail.example.com") ; => tls-connection | #f

197 ;;; (tls-upgrade sock "mail.example.com" 10000) ; 10s handshake bound

198 ;;; ```

199 (define-native (tls-upgrade socket hostname . handshake-timeout-ms)

200 (: any? string? -> any?))

201

202 ;;; Like `tls-upgrade`, but returns `(status . connection-or-#f)`.

203 ;;; Statuses match `tls-connect/status` minus the connect-phase ones.

204 (define-native (tls-upgrade/status socket hostname . handshake-timeout-ms)

205 (: any? string? -> pair?))

206

207 ;;; Upgrade an existing socket, returning the same diagnostic dictionary

208 ;;; as tls-connect/details. Takes the same arguments as tls-upgrade/status

209 ;;; and owns the socket even when the handshake fails.

210 (define-native (tls-upgrade/details socket hostname . handshake-timeout-ms)

211 (: any? string? -> dict?))))