distro-build: split vbox control to separate module
This commit is contained in:
Matthew Flatt
parent
3ded9ea003
commit
cbc734e75b
|
|
@ -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))
|
||||
|
|
|
|||
96
pkgs/distro-build-pkgs/distro-build-server/vbox.rkt
Normal file
96
pkgs/distro-build-pkgs/distro-build-server/vbox.rkt
Normal file
|
|
@ -0,0 +1,96 @@
|
|||
#lang racket/base
|
||||
(require racket/system
|
||||
racket/string)
|
||||
|
||||
(provide start-vbox-vm
|
||||
stop-vbox-vm)
|
||||
|
||||
(define VBoxManage (find-executable-path "VBoxManage"))
|
||||
(define use-headless? #t)
|
||||
|
||||
(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 (printf/flush fmt . args)
|
||||
(apply printf fmt args)
|
||||
(flush-output))
|
||||
|
||||
(define (start-vbox-vm vbox
|
||||
#:max-vms [max-vm 1]
|
||||
#:dry-run? [dry-run? #f]
|
||||
#:log-status [log-status printf/flush])
|
||||
(define (check-count)
|
||||
(define s (system*/string VBoxManage "list" "runningvms"))
|
||||
(unless ((length (string-split s "\n")) . < . max-vm)
|
||||
(error 'start-vbox "too many virtual machines running (>= ~a) to start: ~s"
|
||||
max-vm
|
||||
vbox)))
|
||||
(log-status "Starting VirtualBox machine ~s\n" vbox)
|
||||
(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-vbox "could not get virtual machine started: ~s" vbox))
|
||||
;; pause a little to let the VM get networking ready, etc.
|
||||
(sleep 3)))
|
||||
|
||||
(define (stop-vbox-vm vbox
|
||||
#:dry-run? [dry-run? #f]
|
||||
#:log-status [log-status printf/flush])
|
||||
(log-status "Stopping VirtualBox machine ~s\n" vbox)
|
||||
(unless dry-run?
|
||||
(vbox-control vbox "savestate")
|
||||
(unless (eq? (vbox-state vbox) 'saved)
|
||||
(error 'start-vbox "virtual machine isn't in the expected saved state: ~s" vbox))))
|
||||
Loading…
Reference in New Issue
Block a user