test/integration/live-timeouts-main.sgl

1;;; Live positive controls for the blocking-segment bounds.

2;;;

3;;; Run by test/integration/run-timeout-tests.sh, which stands up the

4;;; servers and passes their ports in the environment.

5;;;

6;;; Named `-main.sgl` rather than `test-*.sgl` deliberately: `sigil test`

7;;; globs test/**/test-*.sgl, so a `test-` name here would be picked up by a

8;;; bare `sigil test` and fail with no servers running. The other files in

9;;; this directory follow the same convention for the same reason.

10;;;

11;;; WHY THIS FILE EXISTS. Every in-suite test of the bounds asserts a

12;;; FAILURE: a stalled peer must give up on time. Not one of them would

13;;; notice if the bounds broke every SUCCESSFUL request, because a client

14;;; that could no longer complete a TLS handshake at all would satisfy all

15;;; of them. The whole point here is the other direction: real servers,

16;;; bounds armed, requests must still work.

17;;;

18;;; The HTTPS case is the load-bearing one. The handshake bound is new code

19;;; in the middle of every outbound TLS connection in the estate.

21(import (sigil test)

22 (sigil core)

23 (sigil time)

24 (sigil tls)

25 (sigil http client)

26 (sigil http response))

28(define (env-port name)

29 (let ((v (getenv name)))

30 (and v (string->number v))))

32(define http-port (env-port "SIGIL_HTTP_TEST_HTTP_PORT"))

33(define tls-port (env-port "SIGIL_HTTP_TEST_TLS_PORT"))

34(define drip-port (env-port "SIGIL_HTTP_TEST_DRIP_PORT"))

36(define (http-url port path)

37 (string-append "http://127.0.0.1:" (number->string port) path))

39(define (https-url port path)

40 (string-append "https://127.0.0.1:" (number->string port) path))

42(define (seconds-of thunk)

43 (let* ((t0 (current-second))

44 (v (thunk)))

45 (cons (- (current-second) t0) v)))

47;; A missing port is a HARNESS FAILURE, not a reason to skip. A test that

48;; quietly passes because it never ran is the exact failure mode these

49;; bounds exist to eliminate.

50(test-group "live timeout positive controls"

52 (test "harness: all three servers were configured"

53 (assert-true (and http-port tls-port drip-port)))

55 ;; --- Default behaviour is unchanged --------------------------------

57 (test "plain http with NO timeout arguments still works"

58 (let ((res (http-get (http-url http-port "/"))))

59 (assert-true (http-response? res))

60 (assert-equal 200 (http-response-status res))))

62 (test "https with NO timeout arguments still works"

63 ;; The handshake bound must be genuinely opt-in. With no arguments the

64 ;; original blocking handshake has to run and succeed.

65 (let ((res (http-get (https-url tls-port "/"))))

66 (assert-true (http-response? res))

67 (assert-equal 200 (http-response-status res))))

69 ;; --- The bounds do not break healthy requests ----------------------

71 (test "https with the handshake bound ARMED still completes a real handshake"

72 (let* ((measured (seconds-of

73 (lambda () (http-get (https-url tls-port "/")

74 connect-timeout: 5 timeout: 5))))

75 (elapsed (car measured))

76 (res (cdr measured)))

77 (assert-true (http-response? res))

78 (assert-equal 200 (http-response-status res))

79 ;; Promptly, not just eventually: a bound that made every handshake

80 ;; wait out its deadline before succeeding would still return 200.

81 (assert-true (< elapsed 2))))

83 (test "plain http with both bounds armed still works"

84 (let ((res (http-get (http-url http-port "/")

85 connect-timeout: 5 timeout: 5)))

86 (assert-true (http-response? res))

87 (assert-equal 200 (http-response-status res))))

89 (test "a POST body still arrives intact through the bounded write loop"

90 ;; The write path is no longer one blocking call; it is a partial-write

91 ;; loop over byte offsets. An off-by-one there would corrupt or truncate

92 ;; the body while every timeout test stayed green. The server echoes the

93 ;; body length back.

94 (let* ((body (make-string 100000 #\z))

95 (res (http-post (http-url http-port "/echo-length") body

96 connect-timeout: 5 timeout: 10)))

97 (assert-true (http-response? res))

98 (assert-equal 200 (http-response-status res))

99 (assert-equal "100000" (http-response-body res))))

100

101 (test "a POST body still arrives intact over TLS"

102 (let* ((body (make-string 100000 #\z))

103 (res (http-post (https-url tls-port "/echo-length") body

104 connect-timeout: 5 timeout: 10)))

105 (assert-true (http-response? res))

106 (assert-equal 200 (http-response-status res))

107 (assert-equal "100000" (http-response-body res))))

108

109 (test "a partial write resumes at the right offset"

110 ;; The write is no longer one blocking call; it is a loop over byte

111 ;; offsets that resumes after a partial send. Every OTHER test of that

112 ;; loop asserts only that it TIMED OUT, so an off-by-one in the resume

113 ;; (passing the remaining length as `end`, say) would corrupt or truncate

114 ;; bodies while the whole suite stayed green.

115 ;;

116 ;; 4 MiB is above the measured EAGAIN threshold on this host (~2.6 MiB),

117 ;; so partial writes definitely occur, and the server is draining, so the

118 ;; loop definitely completes. The echoed length is the correctness check.

119 (let* ((body (make-string (* 4 1024 1024) #\w))

120 (res (http-post (http-url http-port "/echo-length") body

121 connect-timeout: 10 timeout: 30)))

122 (assert-true (http-response? res))

123 (assert-equal 200 (http-response-status res))

124 (assert-equal "4194304" (http-response-body res))))

125

126 ;; --- The handshake bound, against BOTH stall geometries -------------

127

128 (test "tls-connect/status reports connected for a live peer"

129 ;; The only place in either repo that asserts the "connected" status.

130 ;; Without it, `*status_out = "connected"` could be deleted from

131 ;; tls_connect_core and every other test would still pass.

132 (let ((r (tls-connect/status "127.0.0.1" tls-port 5000 5000)))

133 (assert-equal "connected" (car r))

134 (assert-true (cdr r))

135 (tls-close (cdr r))))

136

137 (test "the handshake bound fires against a DRIPPING peer, not just a silent one"

138 ;; THE CONTROL MY FIRST RIG WAS MISSING, and the reason the first version

139 ;; of this bound was wrong.

140 ;;

141 ;; A peer that sends NOTHING cannot distinguish a per-read bound from a

142 ;; per-handshake one: both fire. This peer sends a valid TLS record

143 ;; header declaring a 16384-byte body and then drips one byte every

144 ;; 600 ms. Against a per-read bound each byte restarts the clock:

145 ;; measured at 13.06 s for a 1000 ms bound, and never firing at all while

146 ;; the drip continued. Against a total bound it fires on time.

147 (let* ((measured (seconds-of

148 (lambda () (tls-connect/status "127.0.0.1" drip-port

149 1000 1000))))

150 (elapsed (car measured))

151 (r (cdr measured)))

152 ;; It must be a TIMEOUT, not a protocol rejection. If the drip peer's

153 ;; header were malformed the client would bail instantly with

154 ;; "handshake-failed" and this test would prove nothing.

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

156 (assert-false (cdr r))

157 ;; It must have WAITED, so we know bytes were arriving and being

158 ;; consumed rather than the connection failing outright.

159 (assert-true (>= elapsed 0.5))

160 ;; And it must not have waited much past its own deadline. This is the

161 ;; assertion that fails on a per-read bound: 13.06 s against 1 s.

162 (assert-true (< elapsed 4))))

163

164 (test "http-fetch-bytes still returns the body byte-for-byte"

165 ;; http-fetch-bytes now sets the connection non-blocking so its own idle

166 ;; deadlines can fire. If that broke its reads, this returns short.

167 (let ((r (http-fetch-bytes 'GET (http-url http-port "/bytes") timeout: 10)))

168 (assert-true (dict? r))

169 (assert-equal 200 (dict-ref r status: #f))

170 (assert-equal 65536 (bytevector-length (dict-ref r body: #f))))))

171

172(run-tests)