suzanne.soy/distro-build
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

distro-build: split vbox control to separate module

Browse Source 
original commit: cbc734e75bf9425e90a1bb80b207c4b01c25b861
This commit is contained in:
Matthew Flatt 2014-06-10 13:33:18 +01:00
parent d82d917979
commit db364d86f0
1 changed files with 18 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
pkgs/distro-build-pkgs/distro-build-server/drive-clients.rkt
View File

@ -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))