test/test-tls.sgl — sigil-tls

1(import (sigil test)

2 (sigil tls)

3 (sigil socket)

4 (sigil time)

5 (only (sigil math) inexact))

7;; ============================================================

8;; Type predicates

9;; ============================================================

11(test-group "type predicates"

12 (test "tls-connection? returns #f for string"

13 (assert-false (tls-connection? "hello")))

15 (test "tls-connection? returns #f for number"

16 (assert-false (tls-connection? 42)))

18 (test "tls-connection? returns #f for list"

19 (assert-false (tls-connection? '(1 2 3))))

21 (test "tls-connection? returns #f for boolean"

22 (assert-false (tls-connection? #f)))

24 (test "tls-connection? returns #f for plain TCP socket"

25 (let ((sock (tcp-listen 0)))

26 (assert-false (tls-connection? sock))

27 (socket-close sock))))

29;; ============================================================

30;; Connection failure handling

31;; ============================================================

33(test-group "connection failure handling"

34 (test "tls-connect to closed port returns #f"

35 (assert-false (tls-connect "127.0.0.1" 1)))

37 (test "tls-connect to invalid host returns #f"

38 (assert-false (tls-connect "invalid-host-that-does-not-exist.test" 443))))

40;; ============================================================

41;; Error paths (wrong argument types)

42;; ============================================================

44(test-group "error paths"

45 (test "tls-connect with non-string hostname raises error"

46 (assert-error (tls-connect 42 443)))

48 (test "tls-connect with non-integer port raises error"

49 (assert-error (tls-connect "localhost" "443")))

51 (test "tls-read with non-connection raises error"

52 (assert-error (tls-read "not-a-connection")))

54 (test "tls-write with non-connection raises error"

55 (assert-error (tls-write "not-a-connection" "data")))

57 (test "tls-close with non-connection raises error"

58 (assert-error (tls-close "not-a-connection"))))

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.

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)))

81(define (stall-port sock)

82 (cadr (socket-local-address sock)))

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))))

93 ;; NOT TESTED HERE: the "connected" status, and the bound holding against a

94 ;; peer that DRIPS rather than going silent. Both need a live TLS peer,

95 ;; which this suite cannot stand up in-process, and both are covered by

96 ;; sigil-http's test/integration/run-timeout-tests.sh:

97 ;; "tls-connect/status reports connected for a live peer" and "the

98 ;; handshake bound fires against a DRIPPING peer, not just a silent one".

99 ;;

100 ;; Said out loud because an earlier version of this file had a test here

101 ;; claiming to guard the "connected" direction which in fact repeated the

102 ;; failing call above verbatim. It asserted that a REFUSED connection is

103 ;; not reported as connected, which is not the same claim at all, and

104 ;; `*status_out = "connected"` could have been deleted from the C with all

105 ;; 20 tests still green.

106

107 (test "handshake timeout bounds an accept-and-stall peer"

108 (let* ((server (tcp-listen 0))

109 (port (stall-port server)))

110 (let* ((measured (elapsed-seconds

111 (lambda () (tls-connect "127.0.0.1" port 1000 1000))))

112 (dt (car measured))

113 (conn (cdr measured)))

114 (socket-close server)

115 ;; It must FAIL (the peer never completed a handshake) ...

116 (assert-false conn)

117 ;; ... and it must fail on roughly the deadline, not merely

118 ;; eventually. Pre-fix this call does not return at all; the upper

119 ;; bound is what makes this a timeout assertion rather than an

120 ;; "an error appeared" assertion.

121 (assert-true (>= dt 0.5))

122 (assert-true (<= dt 5.0)))))

123

124 (test "handshake timeout is reported as handshake-timeout, not a generic failure"

125 (let* ((server (tcp-listen 0))

126 (port (stall-port server))

127 (r (tls-connect/status "127.0.0.1" port 1000 1000)))

128 (socket-close server)

129 (assert-equal "handshake-timeout" (car r))

130 (assert-false (cdr r))))

131

132 (test "the deadline scales with the argument"

133 ;; A bound that ignores its argument would satisfy the test above.

134 ;; Two different deadlines must produce two different waits.

135 (let* ((server (tcp-listen 0))

136 (port (stall-port server))

137 (short (car (elapsed-seconds

138 (lambda () (tls-connect "127.0.0.1" port 1000 300)))))

139 (long (car (elapsed-seconds

140 (lambda () (tls-connect "127.0.0.1" port 1000 2000))))))

141 (socket-close server)

142 (assert-true (< short 1.0))

143 (assert-true (> long 1.5))

144 (assert-true (> long short))))

145

146 (test "tls-upgrade honours a handshake timeout on an already-connected socket"

147 ;; tls-upgrade's handshake is strictly MORE exposed than tls-connect's:

148 ;; the socket is connected before the call, so every handshake byte is

149 ;; past the connect phase. Bound it on its own rig.

150 (let* ((server (tcp-listen 0))

151 (port (stall-port server))

152 (client (tcp-connect "127.0.0.1" port)))

153 (assert-true (socket? client))

154 (let* ((measured (elapsed-seconds

155 (lambda () (tls-upgrade client "localhost" 1000))))

156 (dt (car measured))

157 (conn (cdr measured)))

158 (socket-close server)

159 (assert-false conn)

160 (assert-true (>= dt 0.5))

161 (assert-true (<= dt 5.0)))))

162

163 (test "a peer that answers with non-TLS bytes is handshake-failed, not handshake-timeout"

164 ;; POSITIVE CONTROL FOR THE BOUND ITSELF. Everything above asserts a

165 ;; timeout; a bound that reported "handshake-timeout" for every failure

166 ;; would satisfy all of it. Here the peer DOES answer, immediately, with

167 ;; bytes that are not a TLS record. With the deadline armed at 2s the

168 ;; call must come back fast AND with the other status.

169 (let* ((server (tcp-listen 0))

170 (port (stall-port server))

171 (client (tcp-connect "127.0.0.1" port))

172 (peer (tcp-accept server)))

173 (assert-true (socket? client))

174 (assert-true (socket? peer))

175 ;; Queued before the upgrade, so no second task is needed to send it.

176 (socket-write peer "NOT-A-TLS-RECORD\r\n\r\n")

177 (let* ((measured (elapsed-seconds

178 (lambda () (tls-upgrade/status client "localhost" 2000))))

179 (dt (car measured))

180 (r (cdr measured)))

181 (socket-close peer)

182 (socket-close server)

183 (assert-equal "handshake-failed" (car r))

184 (assert-false (cdr r))

185 ;; Promptly: it did not sit out the deadline.

186 (assert-true (< dt 1.0)))))

187

188 (test "tls-upgrade/status reports handshake-timeout"

189 (let* ((server (tcp-listen 0))

190 (port (stall-port server))

191 (client (tcp-connect "127.0.0.1" port))

192 (r (tls-upgrade/status client "localhost" 1000)))

193 (socket-close server)

194 (assert-equal "handshake-timeout" (car r))

195 (assert-false (cdr r)))))

196

197(run-tests)

198

199

200(test-group "per-attempt handshake diagnostics"

201 (test "details distinguish a failed TCP connect from a handshake"

202 (let ((result (tls-connect/details "127.0.0.1" 1 1000 1000)))

203 (assert-equal "tcp-connect-failed" (dict-ref result status:))

204 (assert-false (dict-ref result connection:))

205 (assert-false (dict-ref result handshake-state:))

206 (assert-false (dict-ref result protocol:))))

207

208 (test "stalled handshake preserves its raw timeout and phase"

209 (let* ((listener (tcp-listen 0))

210 (result (tls-connect/details "127.0.0.1" (stall-port listener) 1000 100)))

211 (socket-close listener)

212 (assert-equal "handshake-timeout" (dict-ref result status:))

213 (assert-false (dict-ref result connection:))

214 (assert-equal -26624 (dict-ref result error-code:))

215 (assert-true (string? (dict-ref result error-message:)))

216 (assert-equal "server-hello" (dict-ref result handshake-state:))

217 (tls-connect/details "127.0.0.1" 1 1000 1000)

218 (assert-equal -26624 (dict-ref result error-code:))))

219

220 (test "upgrade details preserve the handshake deadline and own the socket"

221 (let* ((listener (tcp-listen 0))

222 (socket (tcp-connect "127.0.0.1" (stall-port listener)))

223 (result (tls-upgrade/details socket "localhost" 100)))

224 (socket-close listener)

225 (assert-equal "handshake-timeout" (dict-ref result status:))

226 (assert-equal -26624 (dict-ref result error-code:))

227 (assert-false (dict-ref result connection:))

228 (assert-error (tls-upgrade/details socket "localhost" 100)))))