make installers: fixes for parallel mode and timeouts

The `parallel` form in a site configuration was working only
with leaf machines; now, it should be fixed for `sequential`
nested under `parallel`.

Also, fix timeout handling and reporting of failures.

pkgs/distro-build/drive-clients.rkt

@@ -22,6 +22,7 @@
 
 (define default-release? #f)
 (define default-clean? #f)
+(define dry-run #f)
 
 (define snapshot-install-name "snapshot")
 
@@ -35,6 +36,12 @@
     (set! default-release? #t)]
    [("--clean") "Erase client directories before building"
     (set! default-clean? #t)]
+   [("--dry-run") mode
+    ("Don't actually use the clients;"
+     " <mode> can be `ok', `fail', `error', `stuck', or `frozen'")
+    (unless (member mode '("ok" "fail" "error" "stuck" "frozen"))
+      (raise-user-error 'drive-clients "bad dry-run mode: ~a" mode))
+    (set! dry-run (string->symbol mode))]
    #:args (config-file config-mode 
                        server server-port server-hosts pkgs doc-search
                        dist-name dist-base dist-dir)
@@ -105,7 +112,14 @@
                     (map (lambda (p) (if (path? p) (path->string p) p)) 
                          (cons exe args))))
   (flush-output)
-  (apply system* exe args))
+  (case dry-run
+    [(ok) #t]
+    [(fail) #f]
+    [(error) (error "error")]
+    [(stuck) (semaphore-wait (make-semaphore))]
+    [(frozen) (break-enabled #f) (semaphore-wait (make-semaphore))]
+    [else
+     (apply system* exe args)]))
 
 (define (system*/string . args)
   (define s (open-output-string))
@@ -168,6 +182,7 @@
   (when vbox
     (printf "Starting VirtualBox machine ~s\n" vbox)
     (flush-output)
+    (unless dry-run
       (case (vbox-state vbox)
         [(running) (void)]
         [(paused) (vbox-control vbox "resume")]
@@ -176,18 +191,19 @@
                         (check-count)
                         (vbox-start vbox)))])
       (unless (eq? (vbox-state vbox) 'running)
-      (error 'start-client "could not get virtual machine started: ~s" (client-name c))))
+        (error 'start-client "could not get virtual machine started: ~s" (client-name c)))
-  ;; pause a little to let the VM get networkign ready, etc.
+      ;; pause a little to let the VM get networking ready, etc.
-  (sleep 3))
+      (sleep 3))))
 
 (define (stop-client c)
   (define vbox (get-opt c '#:vbox))
   (when vbox
     (printf "Stopping VirtualBox machine ~s\n" vbox)
     (flush-output)
+    (unless dry-run
       (vbox-control vbox "savestate")
       (unless (eq? (vbox-state vbox) 'saved)
-      (error 'start-client "virtual machine isn't in the expected saved state: ~s" c))))
+        (error 'start-client "virtual machine isn't in the expected saved state: ~s" c)))))
 
 ;; ----------------------------------------
 
@@ -410,11 +426,15 @@
 ;; ----------------------------------------
 
 (define stop? #f)
-(define failures null)
-(define failures-sema (make-semaphore 1))
 
-(define (limit-and-report-failure c timeout-factor thunk)
+(define failures (make-hasheq))
-  (unless stop?
+(define (record-failure name)
+  ;; relies on atomicity of `eq?'-based hash table:
+  (hash-set! failures (string->symbol name) #t))
+
+(define (limit-and-report-failure c timeout-factor
+                                  shutdown report-fail
+                                  thunk)
   (define cust (make-custodian))
   (define timeout (or (get-opt c '#:timeout)
                       (* 30 60)))
@@ -430,39 +450,52 @@
                (break-thread orig-thread)
                (sleep 1)
                ;; force quit:
-                 (custodian-shutdown-all cust)))
+               (report-fail)
+               (shutdown)))
      (with-handlers ([exn? (lambda (exn)
                              (when (exn:break? exn)
+                               ;; This is useful only when everything is
+                               ;; sequential, which is the only time that
+                               ;; we'll get break events that aren't timeouts:
                                (unless timeout?
                                  (set! stop? #t)))
                              (log-error "~a failed..." (client-name c))
                              (log-error (exn-message exn))
+                             (report-fail)
                              #f)])
        (thunk)))
-     (custodian-shutdown-all cust))))
+   (custodian-shutdown-all cust)))
 
-(define (client-thread c sequential? thunk)
+(define (client-thread c all-seq? proc)
   (unless stop?
     (define log-dir (build-path "build" "log"))
     (define log-file (build-path log-dir (client-name c)))
     (make-directory* log-dir)
     (printf "Logging build: ~a\n" log-file)
     (flush-output)
-    (define (go)
+    (define cust (make-custodian))
+    (define (go shutdown)
       (define p (open-output-file log-file
                                   #:exists 'truncate/replace))
       (file-stream-buffer-mode p 'line)
+      (define (report-fail)
+        (record-failure (client-name c))
+        (printf "Build FAILED for ~s\n" (client-name c)))
       (unless (parameterize ([current-output-port p]
                              [current-error-port p])
-                (thunk))
+                (proc shutdown report-fail))
-        (call-with-semaphore
+        (report-fail))
-         failures-sema
+      (display-time))
-         (lambda ()
-           (set! failures (cons (client-name c) failures))))
-        (printf "Build FAILED for ~s\n" (client-name c))))
     (cond
-     [sequential? (go) (thread void)]
+     [all-seq? 
-     [else (thread go)])))
+      (go (lambda () (exit 1)))
+      (thread void)]
+     [else
+      (parameterize ([current-custodian cust])
+        (thread
+         (lambda ()
+           (go (lambda ()
+                 (custodian-shutdown-all cust))))))])))
 
 ;; ----------------------------------------
 
@@ -470,32 +503,39 @@
 (display-time)
 
 (void
+ (sync
   (let loop ([config config]
-            [mode 'sequential]
+             [all-seq? #t] ; Ctl-C handling is better if nothing is in parallel
              [opts (hasheq)])
-   (unless stop?
+    (cond
+     [stop? (thread void)]
+     [else
       (case (site-config-tag config)
-       [(parallel sequential)
+        [(parallel)
          (define new-opts (merge-options opts config))
          (define ts
-          (map (lambda (c) (loop c
+           (map (lambda (c) (loop c #f new-opts))
-                                 (site-config-tag config)
-                                 new-opts))
                 (get-content config)))
-        (define (wait)
+         (thread
+          (lambda ()
             (for ([t (in-list ts)])
-            (sync t)))
+              (sync t))))]
-        (cond
+        [(sequential)
-         [(eq? mode 'sequential) (wait) (thread void)]
+         (define new-opts (merge-options opts config))
-         [else (thread wait)])]
+         (define (go)
+           (for-each (lambda (c) (sync (loop c all-seq? new-opts)))
+                     (get-content config)))
+         (if all-seq?
+             (begin (go) (thread void))
+             (thread go))]
         [else 
          (define c (merge-options opts config))
          (client-thread
           c
-         (eq? mode 'sequential)
+          all-seq?
-         (lambda ()
+          (lambda (shutdown report-fail)
             (limit-and-report-failure
-            c 2
+             c 2 shutdown report-fail
              (lambda ()
                (sleep (get-opt c '#:pause-before 0))
                ;; start client, if a VM:
@@ -504,15 +544,16 @@
                ;; can more likely stop the client:
                (begin0
                 (limit-and-report-failure
-                c 1
+                 c 1 shutdown report-fail
                  (lambda () (client-build c)))
                 ;; stop client, if a VM:
                 (stop-client c)
-               (sleep (get-opt c '#:pause-after 0)))))))]))))
+                (sleep (get-opt c '#:pause-after 0)))))))])]))))
 
 (display-time)
 (define end-seconds (current-seconds))
 
+(unless stop?
   (let ([opts (merge-options (hasheq) config)])
     (let ([to-email (get-opt opts '#:email-to null)])
       (unless (null? to-email)
@@ -521,5 +562,5 @@
                                (get-opt opts key def))
                     (get-opt opts '#:build-stamp (current-stamp))
                     start-seconds end-seconds
-                  failures)
+                    (hash-map failures (lambda (k v) (symbol->string k))))
-      (display-time))))
+        (display-time)))))