commit db364d86f0a4db5758e7323db5fb778d147b08d3
parent d82d917979c6a962296378ba7e873bc4e9ceaf97
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 10 Jun 2014 13:33:18 +0100
distro-build: split vbox control to separate module
original commit: cbc734e75bf9425e90a1bb80b207c4b01c25b861
Diffstat:
1 file changed, 18 insertions(+), 92 deletions(-)
diff --git a/pkgs/distro-build-pkgs/distro-build-server/drive-clients.rkt b/pkgs/distro-build-pkgs/distro-build-server/drive-clients.rkt
@@ -14,7 +14,8 @@
distro-build/url-options
distro-build/display-time
distro-build/readme
- "email.rkt")
+ "email.rkt"
+ "vbox.rkt")
;; See "config.rkt" for an overview.
@@ -106,8 +107,22 @@
;; ----------------------------------------
;; Managing VirtualBox machines
-(define VBoxManage (find-executable-path "VBoxManage"))
-(define use-headless? #t)
+(define (start-client c max-vm)
+ (define vbox (get-opt c '#:vbox))
+ (when vbox
+ (start-vbox-vm vbox
+ #:max-vms max-vm
+ #:dry-run? dry-run)))
+
+(define (stop-client c)
+ (define vbox (get-opt c '#:vbox))
+ (when vbox
+ (stop-vbox-vm vbox)))
+
+;; ----------------------------------------
+
+(define scp (find-executable-path "scp"))
+(define ssh (find-executable-path "ssh"))
(define (system*/show exe . args)
(displayln (apply ~a #:separator " "
@@ -123,95 +138,6 @@
[else
(apply system* exe args)]))
-(define (system*/string . args)
- (define s (open-output-string))
- (parameterize ([current-output-port s])
- (apply system* args))
- (get-output-string s))
-
-(define (vbox-state vbox)
- (define s (system*/string VBoxManage "showvminfo" vbox))
- (define m (regexp-match #rx"(?m:^State:[ ]*([a-z]+(?: [a-z]+)*))" s))
- (define state (and m (string->symbol (cadr m))))
- (case state
- [(|powered off| aborted) 'off]
- [(running saved paused) state]
- [(restoring) (vbox-state vbox)]
- [else
- (eprintf "~a\n" s)
- (error 'vbox-state "could not get virtual machine status: ~s" vbox)]))
-
-(define (vbox-control vbox what)
- (system* VBoxManage "controlvm" vbox what))
-
-(define (vbox-start vbox)
- (apply system* VBoxManage "startvm" vbox
- (if use-headless?
- '("--type" "headless")
- null))
- ;; wait for the machine to get going:
- (let loop ([n 0])
- (unless (eq? 'running (vbox-state vbox))
- (unless (= n 20)
- (sleep 0.5)
- (loop (add1 n))))))
-
-(define call-with-vbox-lock
- (let ([s (make-semaphore 1)]
- [lock-cust (current-custodian)])
- (lambda (thunk)
- (define t (current-thread))
- (define ready (make-semaphore))
- (define done (make-semaphore))
- (parameterize ([current-custodian lock-cust])
- (thread (lambda ()
- (semaphore-wait s)
- (semaphore-post ready)
- (sync t done)
- (semaphore-post s))))
- (sync ready)
- (thunk)
- (semaphore-post done))))
-
-(define (start-client c max-vm)
- (define vbox (get-opt c '#:vbox))
- (define (check-count)
- (define s (system*/string VBoxManage "list" "runningvms"))
- (unless ((length (string-split s "\n")) . < . max-vm)
- (error 'start-client "too many virtual machines running (>= ~a) to start: ~s"
- max-vm
- (client-name c))))
- (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")]
- [(off saved) (call-with-vbox-lock
- (lambda ()
- (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 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)))))
-
-;; ----------------------------------------
-
-(define scp (find-executable-path "scp"))
-(define ssh (find-executable-path "ssh"))
-
(define (ssh-script host port user server-port kind . cmds)
(for/and ([cmd (in-list cmds)])
(when cmd (display-time))
