ci: scale more timeouts in http mats

GitHub Actions macOS test builds continue to generate spurious test
failures that waste our time. Try logging the actual time used when
we are running with scale-timeout enabled.

src/swish/http.ms

@@ -776,7 +776,7 @@
   (let-values ([(ip op) (connect-tcp "127.0.0.1" (get-http-port))])
     (put-bytevector op (string->utf8 "Malformed Request\r\n\r\n"))
     (flush-output-port op)
-    (receive (after 10 (throw 'no-child-log))
+    (test:receive (after 10 (throw 'no-child-log))
       [`(<child-end> [reason #(http-unhandled-input ,x)])
        (assert (string=? (utf8->string x) "Malformed Request"))])
     (close-port op))
@@ -792,7 +792,7 @@
       (spawn&link
        (lambda ()
          (send me `#(read ,(utf8->string (get-bytevector-all ip)))))))
-    (receive (after 100 (throw 'timeout))
+    (test:receive (after 100 (throw 'timeout))
       [#(read ,x)
        (unless (string=? x
                  (string-append
@@ -807,7 +807,7 @@
         [fail-msg `#(accept-tcp-failed "listener" "who" "errno")])
     (link http)
     (send http fail-msg)
-    (receive (after 100 (throw 'timeout))
+    (test:receive (after 100 (throw 'timeout))
       [`(EXIT ,@http ,@fail-msg) 'ok])))
 
 (http-mat http-respond ()
@@ -1058,7 +1058,7 @@
           (match ls
             [() 'ok]
             [(,n . ,rest)
-             (receive (after 100 (throw `#(failed-to-read-data ,n)))
+             (test:receive (after 100 (throw `#(failed-to-read-data ,n)))
                [#(read ,@n) (lp rest)])])))
 
       (check-loopback '(9 8 7 6 5))
@@ -1387,14 +1387,14 @@
         (send pid msg)
         (check c s)))
     (define (check-crash c s)
-      (receive (after 100 (throw 'no-client-close))
+      (test:receive (after 100 (throw 'no-client-close))
         [#(ws:closed ,@c 1011 "") 'ok])
-      (receive (after 100 (throw 'no-child-log))
+      (test:receive (after 100 (throw 'no-child-log))
         [`(<child-end> [pid ,@s] [reason crashed]) 'ok]))
     (define (check-normal c s)
-      (receive (after 100 (throw 'no-client-close))
+      (test:receive (after 100 (throw 'no-client-close))
         [#(ws:closed ,@c 1000 "") 'ok])
-      (receive (after 100 (throw 'no-child-log))
+      (test:receive (after 100 (throw 'no-child-log))
         [`(<child-end> [pid ,@s] [reason normal]) 'ok]))
     (do-test #f 'crash check-crash)
     (do-test #t 'crash check-crash)

src/swish/testing.ss

@@ -49,6 +49,7 @@
    start-event-mgr
    start-silent-event-mgr
    system-mat
+   test:receive
    )
   (import
    (chezscheme)
@@ -347,6 +348,30 @@
               [stderr (receive [#(stderr ,@os-pid ,lines) lines])]
               [exit-status exit-status])])))))
 
+  (define-syntax (test:receive x)
+    (define (en-guarde cl)
+      (syntax-case cl ()
+        [(pattern (guard g) b1 b2 ...)
+         (eq? (datum guard) 'guard)
+         cl]
+        [(pattern b1 b2 ...)
+         #'(pattern (guard #t) b1 b2 ...)]))
+    (syntax-case x ()
+      [(_ (after timeout t1 t2 ...) clause ...)
+       (and (eq? (datum after) 'after) (getenv "TIMEOUT_SCALE_FACTOR"))
+       (with-syntax ([(quote #(at offset fn)) (find-source x)]
+                     [(n ...) (iota (length (datum (clause ...))))]
+                     [((pattern guard b1 b2 ...) ...)
+                      (map en-guarde #'(clause ...))])
+         #'(let* ([raw-timeout timeout]
+                  [start (erlang:now)])
+             (define (report where)
+               (fprintf (console-error-port) "hit clause ~s at ~a:~s after ~s ms [raw timeout ~s]\n"
+                 where fn offset (- (erlang:now) start) raw-timeout))
+             (receive (after (scale-timeout raw-timeout) (report 'timeout) t1 t2 ...)
+               [pattern guard (report n) b1 b2 ...] ...)))]
+      [(_ e ...) #'(receive e ...)]))
+
   (define (scale-timeout timeout)
     (define scale-factor
       (or (cond
@@ -547,5 +572,4 @@
               [() (getenv var)]
               [(x) (when (string? x) (putenv var x))])))
          ...)]))
-
   )