Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Fetching contributors…
Cannot retrieve contributors at this time
245 lines (204 sloc) 7.95 KB
#! /usr/bin/env gsi
;; Copyright (c) 2011-2012 by Marc Feeley, All Rights Reserved.
;; This program allows execution of commands on a remote host. The
;; "remote host" may be a real computer or a VM running locally in
;; VirtualBox. In the latter case, the VM is started, configured for
;; ssh, and then terminated when the commands terminate. The commands
;; are a sequence of Scheme expressions to execute. The commands can
;; include calls to the following procedures, which all return #t if
;; they executed without error:
;; (sh <command>) local shell command execution
;; (ssh <timeout-in-seconds> <command>) remote shell command execution
;; (scp-to <timeout-in-seconds> <src> <dst>) copy local <src> to remote <dst>
;; (scp-from <timeout-in-seconds> <src> <dst>) copy remote <src> to local <dst>
;; Usage: ./remote-connect <host> <password> <commands>
(define debug? #f)
(define (main host pw commands)
(remote-connect host pw commands))
(define (remote-connect host pw commands)
(define (err)
(exit 1))
(let* ((alias (assoc host host-aliases))
(h (if alias (cadr alias) host))
(vbox-vm (assoc h vbox-vms)))
(if vbox-vm
(set! hostname "localhost")
(set! username (list-ref vbox-vm 1))
(set! password (if (equal? pw "") (list-ref vbox-vm 2) pw))
(set! ssh-port (list-ref vbox-vm 3)))
(set! hostname h)
(set! username
(if (and alias (>= (length alias) 3))
(caddr alias)
(set! password
(if (and (equal? pw "") alias (>= (length alias) 4))
(cadddr alias)
(if (equal? password "?")
(print "\nPassword for " username "@" hostname ": ")
(set! password (read-line))
(print "\n")))
(set! ssh-port
(if (and alias (>= (length alias) 5))
(car (cddddr alias))
(if (equal? password "")
(set! password #f))
(end-vbox-vm vbox-vm)
(if (not (start-vbox-vm vbox-vm))
(eval (cons 'begin (with-input-from-string commands read-all)))
(if (not (end-vbox-vm vbox-vm))
(define hostname #f)
(define username #f)
(define password #f)
(define ssh-port #f)
(define host-aliases
'(("macosx" "Snow-Leopard-x86-VM1")
("windows" "Windows-7-Ultimate-x86-VM1")
("farm" "" "gambit" "?" 22)
("localhost" "localhost")
;; Name of the VM and username, password and port to connect to the VM
;; with ssh. Note that the password need not be hidden because the
;; VirtualBox VMs are run locally.
(define vbox-vms
'(("Snow-Leopard-x86-VM1" "administrator" "pass999word" 2211)
("Snow-Leopard-x86-VM2" "administrator" "pass999word" 2212)
("Snow-Leopard-x86-VM3" "administrator" "pass999word" 2213)
("Snow-Leopard-x86-VM4" "administrator" "pass999word" 2214)
("Windows-7-Ultimate-x86-VM1" "Admin" "pass999word" 2221)
("Windows-7-Ultimate-x86-VM2" "Admin" "pass999word" 2222)
("Windows-7-Ultimate-x86-VM3" "Admin" "pass999word" 2223)
("Windows-7-Ultimate-x86-VM4" "Admin" "pass999word" 2224)
(define (ssh-options scp?)
(append (if password
(list "-o" "UserKnownHostsFile=/dev/null"
"-o" "StrictHostKeyChecking=no"
"-o" "PreferredAuthentications=keyboard-interactive,password")
(list (if scp? "-P" "-p") (number->string ssh-port))))
(define start-marker "575e2a05-9d7b-448b-ab91-1adbb2a93fd7")
(define (expect str port echo?)
(define (same-prefix? prefix lst)
(if (null? prefix)
(if (null? lst)
(if (char=? (car prefix) (car lst))
(same-prefix? (cdr prefix) (cdr lst))
(if debug? (set! echo? #t))
(let ((rev-str (reverse (string->list str))))
(let loop ((lst '()))
(if (same-prefix? rev-str lst)
(list->string (reverse lst))
(let ((c (read-char port)))
(if (char? c)
(if echo? (display c))
(loop (cons c lst)))
(define (send output port)
(if debug? (print output))
(print port: port output)
(force-output port))
(define (end-process port echo?)
(if debug? (set! echo? #t))
(let* ((output (read-line port #f))
(output (if (string? output) output "")))
(if echo? (print output)) ;; echo command output
(close-port port)
(if (= 0 (process-status port))
(if (not echo?) (print output))
(define (send-password port)
(if password
(expect "assword:" port #f)
(send (list password "\n") port))))
(define (sh cmd)
(= 0 (shell-command cmd)))
(define (ssh timeout command)
(let ((port
(list path: "ssh"
arguments: (append (ssh-options #f)
(list (string-append username "@" hostname)
(string-append "echo " start-marker
";" command)))
output-eol-encoding: 'cr
pseudo-terminal: #t))))
(input-port-timeout-set! port timeout) ;; must login within this time
(send-password port)
(if (expect (string-append start-marker "\n") port #f)
(input-port-timeout-set! port +inf.0)
(end-process port #t))
(close-port port)
(define (scp-to timeout src dst)
(let ((port
(list path: "scp"
arguments: (append (ssh-options #t)
(list src
(string-append username "@" hostname ":" dst)))
output-eol-encoding: 'cr
pseudo-terminal: #t))))
(input-port-timeout-set! port timeout) ;; must login and copy within this time
(send-password port)
(end-process port #f)))
(define (scp-from timeout src dst)
(let ((port
(list path: "scp"
arguments: (append (ssh-options #t)
(list (string-append username "@" hostname ":" src)
output-eol-encoding: 'cr
pseudo-terminal: #t))))
(input-port-timeout-set! port timeout) ;; must login and copy within this time
(send-password port)
(end-process port #f)))
(define (start-vbox-vm vbox-vm)
(if vbox-vm
(let ((vm-name (list-ref vbox-vm 0)))
(and (sh (string-append "VBoxManage modifyvm \""
"\" --natpf1 \"ssh,tcp,localhost,"
(number->string ssh-port)
(if (sh (string-append "VBoxManage startvm --type headless \""
(thread-sleep! 70) ;; allow some time for VM to boot up
(end-vbox-vm vbox-vm)
(define (end-vbox-vm vbox-vm)
(if vbox-vm
(let ((vm-name (list-ref vbox-vm 0)))
(sh (string-append "VBoxManage controlvm \""
"\" poweroff"
" > /dev/null 2>&1"))
(sh (string-append "VBoxManage modifyvm \""
"\" --natpf1 delete \"ssh\""
" > /dev/null 2>&1")))))
Jump to Line
Something went wrong with that request. Please try again.