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

remote-shell: new package for ssh and VirtualBox utilities

Browse Source 
Extracted from "meta/pkg-build" and "distro-build".
This commit is contained in:
Matthew Flatt 2014-07-29 09:12:49 +01:00
parent 41e7d346d1
commit 807537e219
15 changed files with 530 additions and 200 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -14,8 +14,8 @@
distro-build/url-options
distro-build/display-time
distro-build/readme
"email.rkt"
"vbox.rkt")
remote-shell/vbox
"email.rkt")
;; See "config.rkt" for an overview.

3
pkgs/distro-build-pkgs/distro-build-server/info.rkt
View File

@ -8,7 +8,8 @@
"ds-store-lib"
"net-lib"
"scribble-html-lib"
"plt-web-lib"))
"plt-web-lib"
"remote-shell-lib"))
(define build-deps '("at-exp-lib"))
(define pkg-desc "server-side part of \"distro-build\"")

4
pkgs/plt-services/info.rkt
View File

@ -13,6 +13,7 @@
"distro-build"
"honu"
"gui-pkg-manager"
"remote-shell"
;; Actual dependencies:
"eli-tester"
@ -27,7 +28,8 @@
"compatibility-lib"
"plt-web"
"web-server-lib"
"rackunit-lib"))
"rackunit-lib"
"remote-shell-lib"))
(define pkg-desc "Miscellaneous management and maintenance tools used by the Racket development team")

119
pkgs/plt-services/meta/pkg-build/main.rkt
View File

@ -13,13 +13,13 @@
file/untgz
file/tar
file/gzip
distro-build/vbox
remote-shell/vbox
remote-shell/ssh
web-server/servlet-env
(only-in scribble/html a td tr #%top)
"download.rkt"
"union-find.rkt"
"thread.rkt"
"ssh.rkt"
"status.rkt"
"extract-doc.rkt"
"summary.rkt")
@ -59,7 +59,7 @@
;; - tier-based selection of packages on conflict
;; - support for running tests
(struct vm remote (name init-snapshot installed-snapshot))
(struct vm (host user dir name init-snapshot installed-snapshot))
;; Each VM must provide at least an ssh server and `tar`, it must have
;; any system libraries installed that are needed for building
@ -215,9 +215,6 @@
;; Port to use on host machine for catalog server:
#:server-port [server-port 18333])
(current-timeout timeout)
(current-tunnel-port server-port)
(unless (and (list? vms)
((length vms) . >= . 1)
(andmap vm? vms))
@ -270,9 +267,17 @@
(~a "\"" s "\""))
(define (at-vm vm dest)
(~a (remote-user+host vm) ":" dest))
(at-remote (vm-remote vm) dest))
(define (cd-racket vm) (~a "cd " (q (vm-dir vm)) "/racket"))
(define (cd-racket vm) (~a "cd " (q (remote-dir vm)) "/racket"))
(define (vm-remote vm)
(remote #:host (vm-host vm)
#:user (vm-user vm)
#:env (list (cons "PLTUSERHOME"
(~a (vm-dir vm) "/user")))
#:timeout timeout
#:remote-tunnels (list (cons server-port server-port))))
;; ----------------------------------------
(define installer-table-path (build-path work-dir "table.rktd"))
@ -350,59 +355,60 @@
(dynamic-wind
(lambda () (start-vbox-vm (vm-name vm)))
(lambda ()
(make-sure-host-is-ready vm)
(define rt (vm-remote vm))
(make-sure-remote-is-ready rt)
;; ----------------------------------------
(status "Fixing time at ~a\n" (vm-name vm))
(ssh vm "sudo date --set=" (q (parameterize ([date-display-format 'rfc2822])
(ssh rt "sudo date --set=" (q (parameterize ([date-display-format 'rfc2822])
(date->string (seconds->date (current-seconds)) #t))))
;; ----------------------------------------
(define there-dir (remote-dir vm))
(define there-dir (vm-dir vm))
(status "Preparing directory ~a\n" there-dir)
(ssh vm "rm -rf " (~a (q there-dir) "/*"))
(ssh vm "mkdir -p " (q there-dir))
(ssh vm "mkdir -p " (q (~a there-dir "/user")))
(ssh vm "mkdir -p " (q (~a there-dir "/built")))
(ssh rt "rm -rf " (~a (q there-dir) "/*"))
(ssh rt "mkdir -p " (q there-dir))
(ssh rt "mkdir -p " (q (~a there-dir "/user")))
(ssh rt "mkdir -p " (q (~a there-dir "/built")))
(scp vm (build-path installer-dir installer-name) (at-vm vm there-dir))
(scp rt (build-path installer-dir installer-name) (at-vm vm there-dir))
(ssh vm "cd " (q there-dir) " && " " sh " (q installer-name) " --in-place --dest ./racket")
(ssh rt "cd " (q there-dir) " && " " sh " (q installer-name) " --in-place --dest ./racket")
;; VM-side helper modules:
(scp vm pkg-adds-rkt (at-vm vm (~a there-dir "/pkg-adds.rkt")))
(scp vm pkg-list-rkt (at-vm vm (~a there-dir "/pkg-list.rkt")))
(scp rt pkg-adds-rkt (at-vm vm (~a there-dir "/pkg-adds.rkt")))
(scp rt pkg-list-rkt (at-vm vm (~a there-dir "/pkg-list.rkt")))
;; ----------------------------------------
(status "Setting catalogs at ~a\n" (vm-name vm))
(ssh vm (cd-racket vm)
(ssh rt (cd-racket vm)
" && bin/raco pkg config -i --set catalogs "
" http://localhost:" server-port "/built/catalog/"
" http://localhost:" server-port "/archive/catalog/")
" http://localhost:" (~a server-port) "/built/catalog/"
" http://localhost:" (~a server-port) "/archive/catalog/")
;; ----------------------------------------
(unless (null? extra-packages)
(status "Extra package installs at ~a\n" (vm-name vm))
(ssh vm (cd-racket vm)
(ssh rt (cd-racket vm)
" && bin/raco pkg install -i --auto"
" " (apply ~a #:separator " " extra-packages)))
(when one-time?
;; ----------------------------------------
(status "Getting installed packages\n")
(ssh vm (cd-racket vm)
(ssh rt (cd-racket vm)
" && bin/racket ../pkg-list.rkt > ../pkg-list.rktd")
(scp vm (at-vm vm (~a there-dir "/pkg-list.rktd"))
(scp rt (at-vm vm (~a there-dir "/pkg-list.rktd"))
(build-path work-dir "install-list.rktd"))
;; ----------------------------------------
(status "Stashing installation docs\n")
(ssh vm (cd-racket vm)
(ssh rt (cd-racket vm)
" && bin/racket ../pkg-adds.rkt --all > ../pkg-adds.rktd")
(ssh vm (cd-racket vm)
(ssh rt (cd-racket vm)
" && tar zcf ../install-doc.tgz doc")
(scp vm (at-vm vm (~a there-dir "/pkg-adds.rktd"))
(scp rt (at-vm vm (~a there-dir "/pkg-adds.rktd"))
(build-path work-dir "install-adds.rktd"))
(scp vm (at-vm vm (~a there-dir "/install-doc.tgz"))
(scp rt (at-vm vm (~a there-dir "/install-doc.tgz"))
(build-path work-dir "install-doc.tgz")))
(void))
@ -670,7 +676,7 @@
#:exists 'truncate/replace
(lambda (o) (write-string (pkg-checksum pkg) o))))
(define there-dir (remote-dir vm))
(define there-dir (vm-dir vm))
(for ([pkg (in-list flat-pkgs)])
(define f (build-path install-success-dir (txt pkg)))
@ -680,18 +686,19 @@
(dynamic-wind
(lambda () (start-vbox-vm (vm-name vm) #:max-vms (length vms)))
(lambda ()
(make-sure-host-is-ready vm)
(define rt (vm-remote vm))
(make-sure-remote-is-ready rt)
(define ok?
(and
;; Try to install:
(ssh #:show-time? #t
vm (cd-racket vm)
rt (cd-racket vm)
" && bin/raco pkg install -u --auto"
(if one-pkg "" " --fail-fast")
" " pkgs-str
#:mode 'result
#:failure-dest failure-dest
#:success-dest install-success-dest)
#:failure-log failure-dest
#:success-log install-success-dest)
;; Copy success log for other packages in the group:
(for ([pkg (in-list (cdr flat-pkgs))])
(copy-file install-success-dest
@ -702,9 +709,9 @@
;; built, since we want built packages to be consistent with a binary
;; installation.
(ssh #:show-time? #t
vm (cd-racket vm)
rt (cd-racket vm)
" && bin/racket ../pkg-list.rkt --user > ../user-list.rktd")
(scp vm (at-vm vm (~a there-dir "/user-list.rktd"))
(scp rt (at-vm vm (~a there-dir "/user-list.rktd"))
(build-path work-dir "user-list.rktd"))
(define new-pkgs (call-with-input-file*
(build-path work-dir "user-list.rktd")
@ -721,11 +728,11 @@
(define deps-ok?
(and ok?
(ssh #:show-time? #t
vm (cd-racket vm)
rt (cd-racket vm)
" && bin/raco setup -nxiID --check-pkg-deps --pkgs "
" " pkgs-str
#:mode 'result
#:failure-dest deps-failure-dest)))
#:failure-log deps-failure-dest)))
(when (and ok? one-pkg (not deps-ok?))
;; Copy dependency-failure log for other packages in the group:
(for ([pkg (in-list (cdr flat-pkgs))])
@ -738,18 +745,18 @@
;; dependent packages), then try to save generated documentation
;; even on failure. We'll put it in the "dumpster".
(or ok? one-pkg)
(ssh vm (cd-racket vm)
(ssh rt (cd-racket vm)
" && bin/racket ../pkg-adds.rkt " pkgs-str
" > ../pkg-adds.rktd"
#:mode 'result
#:failure-dest (and ok? failure-dest))
#:failure-log (and ok? failure-dest))
(for/and ([pkg (in-list flat-pkgs)])
(ssh vm (cd-racket vm)
(ssh rt (cd-racket vm)
" && bin/raco pkg create --from-install --built"
" --dest " there-dir "/built"
" " pkg
#:mode 'result
#:failure-dest (and ok? failure-dest)))))
#:failure-log (and ok? failure-dest)))))
(cond
[(and ok? doc-ok? (or deps-ok? one-pkg))
(for ([pkg (in-list flat-pkgs)])
@ -757,11 +764,11 @@
(delete-file (pkg-failure-dest pkg)))
(when (and deps-ok? (file-exists? (pkg-deps-failure-dest pkg)))
(delete-file (pkg-deps-failure-dest pkg)))
(scp vm (at-vm vm (~a there-dir "/built/" pkg ".zip"))
(scp rt (at-vm vm (~a there-dir "/built/" pkg ".zip"))
built-pkgs-dir)
(scp vm (at-vm vm (~a there-dir "/built/" pkg ".zip.CHECKSUM"))
(scp rt (at-vm vm (~a there-dir "/built/" pkg ".zip.CHECKSUM"))
built-pkgs-dir)
(scp vm (at-vm vm (~a there-dir "/pkg-adds.rktd"))
(scp rt (at-vm vm (~a there-dir "/pkg-adds.rktd"))
(build-path built-dir "adds" (format "~a-adds.rktd" pkg)))
(define deps-msg (if deps-ok? "" ", but problems with dependency declarations"))
(call-with-output-file*
@ -783,15 +790,15 @@
(save-checksum pkg))
;; Keep any docs that might have been built:
(for ([pkg (in-list flat-pkgs)])
(scp vm (at-vm vm (~a there-dir "/built/" pkg ".zip"))
(scp rt (at-vm vm (~a there-dir "/built/" pkg ".zip"))
dumpster-pkgs-dir
#:mode 'ignore-failure)
(scp vm (at-vm vm (~a there-dir "/built/" pkg ".zip.CHECKSUM"))
#:mode 'result)
(scp rt (at-vm vm (~a there-dir "/built/" pkg ".zip.CHECKSUM"))
dumpster-pkgs-dir
#:mode 'ignore-failure)
(scp vm (at-vm vm (~a there-dir "/pkg-adds.rktd"))
#:mode 'result)
(scp rt (at-vm vm (~a there-dir "/pkg-adds.rktd"))
(build-path dumpster-adds-dir (format "~a-adds.rktd" pkg))
#:mode 'ignore-failure)))
#:mode 'result)))
(substatus "*** failed ***\n")])
ok?)
(lambda ()
@ -1036,19 +1043,21 @@
(define vm (car vms))
(restore-vbox-snapshot (vm-name vm) (vm-installed-snapshot vm))
(define rt (vm-remote vm))
;; Get fully installed docs for non-conflicting packages:
(dynamic-wind
(lambda () (start-vbox-vm (vm-name vm)))
(lambda ()
(make-sure-host-is-ready vm)
(define rt (vm-remote vm))
(make-sure-remote-is-ready rt)
(ssh #:show-time? #t
vm (cd-racket vm)
rt (cd-racket vm)
" && bin/raco pkg install -i --auto"
" " (apply ~a #:separator " " no-conflict-doc-pkg-list))
(ssh vm (cd-racket vm)
(ssh rt (cd-racket vm)
" && tar zcf ../all-doc.tgz doc")
(scp vm (at-vm vm (~a (remote-dir vm) "/all-doc.tgz"))
(scp rt (at-vm vm (~a (vm-dir vm) "/all-doc.tgz"))
(build-path work-dir "all-doc.tgz")))
(lambda ()
(stop-vbox-vm (vm-name vm) #:save-state? #f)))

131
pkgs/plt-services/meta/pkg-build/ssh.rkt
View File

@ -1,131 +0,0 @@
#lang racket/base
(require racket/system
racket/format
racket/port
racket/date)
(provide (struct-out remote)
ssh
scp
remote-user+host
current-timeout
current-tunnel-port
make-sure-host-is-ready)
(struct remote (host user dir))
(define current-timeout (make-parameter 600))
(define current-tunnel-port (make-parameter 18333))
(define scp-exe (find-executable-path "scp"))
(define ssh-exe (find-executable-path "ssh"))
(define (remote-user+host remote)
(if (not (equal? (remote-user remote) ""))
(~a (remote-user remote) "@" (remote-host remote))
(remote-host remote)))
(define (system*/show exe . args)
(displayln (apply ~a #:separator " "
(map (lambda (p) (if (path? p) (path->string p) p))
(cons exe args))))
(flush-output)
(apply system* exe args))
(define (ssh remote
#:mode [mode 'auto]
#:failure-dest [failure-dest #f]
#:success-dest [success-dest #f]
#:show-time? [show-time? #f]
. args)
(define cmd
(list "/usr/bin/env" (~a "PLTUSERHOME=" (remote-dir remote) "/user")
"/bin/sh" "-c" (apply ~a args)))
(define saved (and (or failure-dest success-dest)
(open-output-bytes)))
(define (tee o1 o2)
(cond
[(not o1)
(values o2 void)]
[else
(define-values (i o) (make-pipe 4096))
(values o
(let ([t (thread (lambda ()
(copy-port i o1 o2)))])
(lambda ()
(close-output-port o)
(sync t))))]))
(define-values (stdout sync-out) (tee saved (current-output-port)))
(define-values (stderr sync-err) (tee saved (current-error-port)))
(define timeout? #f)
(define orig-thread (current-thread))
(define timeout (current-timeout))
(define timeout-thread
(thread (lambda ()
(sleep timeout)
(set! timeout? #t)
(break-thread orig-thread))))
(define (show-time)
(when show-time?
(printf "The time is now ~a\n"
(date->string (seconds->date (current-seconds)) #t))))
(define ok?
(parameterize ([current-output-port stdout]
[current-error-port stderr])
(with-handlers ([exn? (lambda (exn)
(cond
[timeout?
(eprintf "~a\n" (exn-message exn))
(eprintf "Timeout after ~a seconds\n" timeout)
#f]
[else (raise exn)]))])
(show-time)
(begin0
(if (and (equal? (remote-host remote) "localhost")
(equal? (remote-user remote) ""))
(apply system*/show cmd)
(apply system*/show ssh-exe
;; create tunnel to connect back to server:
"-R" (~a (current-tunnel-port)
":localhost:"
(current-tunnel-port))
(remote-user+host remote)
;; ssh needs an extra level of quoting
;; relative to sh:
(for/list ([arg (in-list cmd)])
(~a "'"
(regexp-replace* #rx"'" arg "'\"'\"'")
"'"))))
(kill-thread timeout-thread)
(show-time)))))
(sync-out)
(sync-err)
(let ([dest (if ok? success-dest failure-dest)])
(when dest
(call-with-output-file*
dest
#:exists 'truncate/replace
(lambda (o) (write-bytes (get-output-bytes saved) o)))))
(case mode
[(result) ok?]
[else
(unless ok?
(error "failed"))]))
(define (scp remote src dest #:mode [mode 'auto])
(unless (system*/show scp-exe src dest)
(case mode
[(ignore-failure) (void)]
[else (error "failed")])))
(define (make-sure-host-is-ready remote)
(let loop ([tries 3])
(unless (ssh remote
"echo hello"
#:mode (if (zero? tries) 'auto 'result))
(sleep 1)
(loop (sub1 tries)))))

1
pkgs/plt-services/meta/props
View File

@ -1136,6 +1136,7 @@ path/s is either such a string or a list of them.
"pkgs/redex-pkgs/redex-examples/redex/examples/racket-machine/randomized-tests.rkt" drdr:timeout 300
"pkgs/redex-pkgs/redex-test/redex/tests/run-tests.rkt" drdr:timeout 360
"pkgs/redex-pkgs/redex-test/redex/tests/ryr-test.rkt" drdr:timeout 200 drdr:random #t
"pkgs/remote-shell-pkgs" responsible (mflatt)
"pkgs/sandbox-lib" responsible (eli)
"pkgs/scheme-lib" responsible (mflatt)
"pkgs/scheme-lib/scheme/match.rkt" responsible (samth)

11
pkgs/remote-shell-pkgs/remote-shell-doc/LICENSE.txt Normal file
View File

@ -0,0 +1,11 @@
remote-shell-doc
Copyright (c) 2010-2014 PLT Design Inc.
This package is distributed under the GNU Lesser General Public
License (LGPL). This means that you can link Racket into proprietary
applications, provided you follow the rules stated in the LGPL. You
can also modify this package; if you distribute a modified version,
you must distribute it under the terms of the LGPL, which in
particular means that you must release the source code for the
modified software. See http://www.gnu.org/copyleft/lesser.html
for more information.

15
pkgs/remote-shell-pkgs/remote-shell-doc/info.rkt Normal file
View File

@ -0,0 +1,15 @@
#lang info
(define collection "remote-shell")
(define deps '("base"))
(define build-deps '("racket-doc"
"remote-shell-lib"
"scribble-lib"))
(define pkg-desc "documentation part of \"remote-shell\"")
(define pkg-authors '(mflatt))
(define scribblings '(("remote-shell.scrbl" (multi-page))))

192
pkgs/remote-shell-pkgs/remote-shell-doc/remote-shell.scrbl Normal file
View File

@ -0,0 +1,192 @@
#lang scribble/manual
@(require (for-label racket/base
racket/contract
remote-shell/ssh
remote-shell/vbox))
@title{Remote Shells and Virtual Machines}
The @filepath{remote-shell} collection provides tools for running
shell commands on a remote or virtual machine, including tools for
starting, stopping, and managing VirtualBox virtual-machine instances.
@table-of-contents[]
@; ----------------------------------------
@section{Remote Shells}
@defmodule[remote-shell/ssh]
@defproc[(remote? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a remote-host representation
produced by @racket[remote], @racket[#f] otherwise.}
@defproc[(remote [#:host host string?]
[#:user user string? ""]
[#:env env (listof (cons/c string? string?)) '()]
[#:remote-tunnels remote-tunnels (listof (cons/c (integer-in 1 65535)
(integer-in 1 65535)))
null]
[#:timeout timeout-secs real? 600])
remote?]{
Creates a representation of a remote host. The @racket[host] argument
specifies the host for an @exec{ssh} connection. If @racket[user] is
empty, then the current user name is used for the remote host.
The @racket[env] argument specifies environment variables to set
before running any command on the remote host.
The @racket[remote-tunnels] argument specifies ports to tunnel from
the remote host back to the local host. The first port number in each
pair is the port number on the remote host, and the second port number
is the port that it tunnels to on the local host.
The @racket[timeout] argument specifies a timeout after which a remote
command will be considered failed.}
@defproc[(ssh [remote remote?]
[command (or/c string? path-string?)]
[#:mode mode (or/c 'error 'result 'output) 'error]
[#:failure-log failure-dest (or/c #f path-string?) #f]
[#:success-log success-dest (or/c #f path-string?) #f]
[#:show-time? show-time? any/c #f])
(or/c void? boolean? (cons/c boolean? bytes?))]{
Runs a shell command at @racket[remote], were the @racket[command]s
are concatenated (with no additional spaces) to specify the remote
shell command. The remote command is implemented with @exec{ssh} as
found by @racket[find-system-path].
If @racket[mode] is @racket['error], then the result is
@racket[(void)] or an exception is raised if the remote command fails
with an connection error, an error exit code, or by timing out. If
@racket[mode] is @racket['result], then the result is @racket[#t] for
success or @racket[#f] for failure. If @racket[mode] is
@racket['cons], then the result is a pair containing whether the
command succeeded and a byte string for the command's output
(including error output).
If @racket[failure-dest] is not @racket[#f], then if the command
fails, the remote output (including error output) is recorded to the
specified file. If @racket[success-dest] is not @racket[#f], then if
the command fails, the remote output (including error output) is
recorded to the specified file.}
@defproc[(scp [remote remote?]
[source path-string?]
[dest path-string?]
[#:mode mode (or/c 'error 'result 'output) 'error])
(or/c void? boolean?)]{
Copies a file to/from a remote host. Use @racket[at-remote] to form
either the @racket[source] or @racket[dest] argument. The remote
command is implemented with @exec{scp} as found by
@racket[find-system-path].
If @racket[mode] is @racket['error], then the result is
@racket[(void)] or an exception is raised if the remote command
fails. If @racket[mode] is @racket['result], then the result is
@racket[#t] for success or @racket[#f] for failure.}
@defproc[(at-remote [remote remote?]
[path path-string?])
string?]{
Combines @racket[remote] and @racket[path] to form an argument for
@racket[scp] to specify a path at the remote host.}
@defproc[(make-sure-remote-is-ready [remote remote?]
[#:tries tries exact-nonnegative-integer? 3])
void?]{
Runs a simple command at @racket[remote] to check that it receives
connections, trying up to @racket[tries] times.}
@; ----------------------------------------
@section{Managing VirtualBox Machines}
@defmodule[remote-shell/vbox]
@defproc[(start-vbox-vm [name string?]
[#:max-vms max-vms real? 1]
[#:log-status log-status (string? #:rest any/c . -> . any) printf]
[#:pause-seconds pause-seconds real? 3]
[#:dry-run? dry-run? any/c #f])
void?]{
Starts a VirtualBox virtual machine @racket[name] that is in a saved,
powered off, or running state (where a running machine continues to
run).
The start will fail if @racket[max-vms] virtual machines are already
currently running. This limit is a precaution against starting too
many virtual-machine instances, which can overwhelm the host operating
system.
The @racket[log-status] argument is used to report actions and status
information.
After the machine is started, @racket[start-vbox-vm] pauses for the
amount of time specified by @racket[pause-seconds], which gives the
virtual machine time to find its bearings.
If @racket[dry-run] is @racket[#t], then the machine is not actually
started, but status information is written using @racket[log-status]
to report the action that would have been taken.}
@defproc[(stop-vbox-vm [name string?]
[#:save-state? save-state? any/c #t]
[#:log-status log-status (string? #:rest any/c . -> . any) printf]
[#:dry-run? dry-run? any/c #f])
void?]{
Stops a VirtualBox virtual machine @racket[name] that is in a running
state. If @racket[save-state?] is true, then the machine is put into
saved state, otherwise the current machine state is discarded and the
machine is powered off.
The @racket[log-status] argument is used to report actions and status
information.
If @racket[dry-run] is @racket[#t], then the machine is not actually
started, but status information is written using @racket[log-status]
to report the action that would have been taken.}
@defproc[(take-vbox-snapshot [name string?]
[snapshot-name string?])
void?]{
Takes a snapshot of a virtual machine (which may be running), creating
the snapshot named @racket[snapshot-name].}
@defproc[(restore-vbox-snapshot [name string?]
[snapshot-name string?])
void?]{
Changes the current state of a virtual machine to be the one recorded
as @racket[snapshot-name]. The virtual machine must not be running.}
@defproc[(delete-vbox-snapshot [name string?]
[snapshot-name string?])
void?]{
Deletes @racket[snapshot-name] for the virtual machine @racket[name].}
@defproc[(exists-vbox-snapshot? [name string?]
[snapshot-name string?])
boolean?]{
Reports whether @racket[snapshot-name] exists for the virtual machine
@racket[name].}

11
pkgs/remote-shell-pkgs/remote-shell-lib/LICENSE.txt Normal file
View File

@ -0,0 +1,11 @@
remote-shell-lib
Copyright (c) 2010-2014 PLT Design Inc.
This package is distributed under the GNU Lesser General Public
License (LGPL). This means that you can link Racket into proprietary
applications, provided you follow the rules stated in the LGPL. You
can also modify this package; if you distribute a modified version,
you must distribute it under the terms of the LGPL, which in
particular means that you must release the source code for the
modified software. See http://www.gnu.org/copyleft/lesser.html
for more information.

10
pkgs/remote-shell-pkgs/remote-shell-lib/info.rkt Normal file
View File

@ -0,0 +1,10 @@
#lang info
(define collection "remote-shell")
(define deps '("base"))
(define build-deps '())
(define pkg-desc "implementation (no documentation) part of \"remote-shell\"")
(define pkg-authors '(mflatt))

172
pkgs/remote-shell-pkgs/remote-shell-lib/ssh.rkt Normal file
View File

@ -0,0 +1,172 @@
#lang racket/base
(require racket/system
racket/format
racket/port
racket/date
racket/contract)
(provide remote?
(contract-out
(rename create-remote remote
((#:host string?)
(#:user string?
#:env (listof (cons/c string? string?))
#:timeout real?
#:remote-tunnels (listof (cons/c (integer-in 1 65535)
(integer-in 1 65535))))
. ->* . remote?))
[ssh ((remote?)
(#:mode (or/c 'error 'result 'output)
#:failure-log (or/c #f path-string?)
#:success-log (or/c #f path-string?)
#:show-time? any/c)
#:rest (listof (or/c string? path-string?))
. ->* . any)]
[scp ((remote? path-string? path-string?)
(#:mode (or/c 'error 'result))
. ->* .
void?)]
[make-sure-remote-is-ready ((remote?)
(#:tries exact-nonnegative-integer?)
. ->* .
void?)]
[at-remote (remote? path-string? . -> . string?)]))
(struct remote (host user timeout remote-tunnels env)
#:constructor-name make-remote)
(define create-remote
(let ()
(define (remote #:host host
#:user [user ""]
#:timeout [timeout 600]
#:remote-tunnels [remote-tunnels null]
#:env [env null])
(make-remote host user timeout remote-tunnels env))
remote))
(define scp-exe (find-executable-path "scp"))
(define ssh-exe (find-executable-path "ssh"))
(define (remote-user+host remote)
(if (not (equal? (remote-user remote) ""))
(~a (remote-user remote) "@" (remote-host remote))
(remote-host remote)))
(define (at-remote remote path)
(~a (remote-user+host remote) ":" path))
(define (system*/show exe . args)
(displayln (apply ~a #:separator " "
(map (lambda (p) (if (path? p) (path->string p) p))
(cons exe args))))
(flush-output)
(apply system* exe args))
(define (ssh remote
#:mode [mode 'error]
#:failure-log [failure-dest #f]
#:success-log [success-dest #f]
#:show-time? [show-time? #f]
. args)
(define cmd
(append
(list "/usr/bin/env")
(for/list ([e (in-list (remote-env remote))])
(~a (car e) "=" (cdr e)))
(list
"/bin/sh" "-c" (apply ~a args))))
(define saved (and (or failure-dest success-dest)
(open-output-bytes)))
(define (tee o1 o2)
(cond
[(not o1)
(values o2 void)]
[else
(define-values (i o) (make-pipe 4096))
(values o
(let ([t (thread (lambda ()
(copy-port i o1 o2)))])
(lambda ()
(close-output-port o)
(sync t))))]))
(define-values (stdout sync-out) (tee saved (current-output-port)))
(define-values (stderr sync-err) (tee saved (current-error-port)))
(define timeout? #f)
(define orig-thread (current-thread))
(define timeout (remote-timeout remote))
(define timeout-thread
(thread (lambda ()
(sleep timeout)
(set! timeout? #t)
(break-thread orig-thread))))
(define (show-time)
(when show-time?
(printf "The time is now ~a\n"
(date->string (seconds->date (current-seconds)) #t))))
(define ok?
(parameterize ([current-output-port stdout]
[current-error-port stderr])
(with-handlers ([exn? (lambda (exn)
(cond
[timeout?
(eprintf "~a\n" (exn-message exn))
(eprintf "Timeout after ~a seconds\n" timeout)
#f]
[else (raise exn)]))])
(show-time)
(begin0
(if (and (equal? (remote-host remote) "localhost")
(equal? (remote-user remote) ""))
(apply system*/show cmd)
(apply system*/show ssh-exe
(append
;; create tunnels to connect back to server:
(apply
append
(for/list ([tunnel (in-list (remote-remote-tunnels remote))])
(list "-R" (~a (car tunnel) ":localhost:" (cdr tunnel)))))
(list (remote-user+host remote))
;; ssh needs an extra level of quoting
;; relative to sh:
(for/list ([arg (in-list cmd)])
(~a "'"
(regexp-replace* #rx"'" arg "'\"'\"'")
"'")))))
(kill-thread timeout-thread)
(show-time)))))
(sync-out)
(sync-err)
(let ([dest (if ok? success-dest failure-dest)])
(when dest
(call-with-output-file*
dest
#:exists 'truncate/replace
(lambda (o) (write-bytes (get-output-bytes saved) o)))))
(case mode
[(result) ok?]
[(output) (cons ok? (get-output-bytes saved))]
[else
(unless ok?
(error 'ssh "failed"))]))
(define (scp remote src dest #:mode [mode 'error])
(define ok? (system*/show scp-exe src dest))
(case mode
[(result) ok?]
[else
(unless ok?
(error 'scp "failed"))]))
(define (make-sure-remote-is-ready remote
#:tries [tries 3])
(let loop ([tries tries])
(unless (ssh remote
"echo hello"
#:mode (if (zero? tries) 'error 'result))
(sleep 1)
(loop (sub1 tries)))))

36
pkgs/distro-build-pkgs/distro-build-server/vbox.rkt → pkgs/remote-shell-pkgs/remote-shell-lib/vbox.rkt
View File

@ -1,14 +1,29 @@
#lang racket/base
(require racket/system
racket/string)
racket/string
racket/contract)
(provide start-vbox-vm
stop-vbox-vm
take-vbox-snapshot
restore-vbox-snapshot
delete-vbox-snapshot
exists-vbox-snapshot?)
(provide
(contract-out
[start-vbox-vm
((string?)
(#:max-vms real?
#:dry-run? any/c
#:log-status (string? #:rest any/c . -> . any)
#:pause-seconds real?)
. ->* .
void?)]
[stop-vbox-vm
((string?)
(#:save-state? any/c
#:dry-run? any/c
#:log-status (string? #:rest any/c . -> . any))
. ->* .
void?)]
[take-vbox-snapshot (string? string? . -> . void?)]
[restore-vbox-snapshot (string? string? . -> . void?)]
[delete-vbox-snapshot (string? string? . -> . void?)]
[exists-vbox-snapshot? (string? string? . -> . boolean?)]))
(define VBoxManage (find-executable-path "VBoxManage"))
(define use-headless? #t)
@ -71,7 +86,8 @@
(define (start-vbox-vm vbox
#:max-vms [max-vm 1]
#:dry-run? [dry-run? #f]
#:log-status [log-status printf/flush])
#:log-status [log-status printf/flush]
#:pause-seconds [pause-seconds 3])
(define (check-count)
(define s (system*/string VBoxManage "list" "runningvms"))
(unless ((length (string-split s "\n")) . < . max-vm)
@ -90,7 +106,7 @@
(unless (eq? (vbox-state vbox) 'running)
(error 'start-vbox-vm "could not get virtual machine started: ~s" vbox))
;; pause a little to let the VM get networking ready, etc.
(sleep 3)))
(sleep pause-seconds)))
(define (stop-vbox-vm vbox
#:save-state? [save-state? #t]

11
pkgs/remote-shell-pkgs/remote-shell/LICENSE.txt Normal file
View File

@ -0,0 +1,11 @@
remote-shell
Copyright (c) 2010-2014 PLT Design Inc.
This package is distributed under the GNU Lesser General Public
License (LGPL). This means that you can link Racket into proprietary
applications, provided you follow the rules stated in the LGPL. You
can also modify this package; if you distribute a modified version,
you must distribute it under the terms of the LGPL, which in
particular means that you must release the source code for the
modified software. See http://www.gnu.org/copyleft/lesser.html
for more information.

10
pkgs/remote-shell-pkgs/remote-shell/info.rkt Normal file
View File

@ -0,0 +1,10 @@
#lang info
(define collection 'multi)
(define deps '("remote-shell-lib" "remote-shell-doc"))
(define implies '("remote-shell-lib" "remote-shell-doc"))
(define pkg-desc "Tools for running on remote and virtual-machine hosts")
(define pkg-authors '(mflatt))