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.
(cherry picked from commit 266e4ab119)
This commit is contained in:
Matthew Flatt
Ryan Culpepper
parent
9d6e629a2a
commit
d08ff9c217
|
|
@ -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))))
|
||||
;; pause a little to let the VM get networkign ready, etc.
|
||||
(sleep 3))
|
||||
(error 'start-client "could not get virtual machine started: ~s" (client-name c)))
|
||||
;; pause a little to let the VM get networking ready, etc.
|
||||
(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)
|
||||
(unless stop?
|
||||
(define failures (make-hasheq))
|
||||
(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))
|
||||
(call-with-semaphore
|
||||
failures-sema
|
||||
(lambda ()
|
||||
(set! failures (cons (client-name c) failures))))
|
||||
(printf "Build FAILED for ~s\n" (client-name c))))
|
||||
(proc shutdown report-fail))
|
||||
(report-fail))
|
||||
(display-time))
|
||||
(cond
|
||||
[sequential? (go) (thread void)]
|
||||
[else (thread go)])))
|
||||
[all-seq?
|
||||
(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
|
||||
(site-config-tag config)
|
||||
new-opts))
|
||||
(map (lambda (c) (loop c #f new-opts))
|
||||
(get-content config)))
|
||||
(define (wait)
|
||||
(thread
|
||||
(lambda ()
|
||||
(for ([t (in-list ts)])
|
||||
(sync t)))
|
||||
(cond
|
||||
[(eq? mode 'sequential) (wait) (thread void)]
|
||||
[else (thread wait)])]
|
||||
(sync t))))]
|
||||
[(sequential)
|
||||
(define new-opts (merge-options opts config))
|
||||
(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)
|
||||
(lambda ()
|
||||
all-seq?
|
||||
(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)
|
||||
(display-time))))
|
||||
(hash-map failures (lambda (k v) (symbol->string k))))
|
||||
(display-time)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user