Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

245 lines (204 sloc) 8.138 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
(begin
(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)))
(begin
(set! hostname h)
(set! username
(if (and alias (>= (length alias) 3))
(caddr alias)
(user-name)))
(set! password
(if (and (equal? pw "") alias (>= (length alias) 4))
(cadddr alias)
pw))
(if (equal? password "?")
(begin
(print "\nPassword for " username "@" hostname ": ")
(set! password (read-line))
(print "\n")))
(set! ssh-port
(if (and alias (>= (length alias) 5))
(car (cddddr alias))
22))))
(if (equal? password "")
(set! password #f))
(end-vbox-vm vbox-vm)
(if (not (start-vbox-vm vbox-vm))
(err)
(begin
(eval (cons 'begin (with-input-from-string commands read-all)))
(if (not (end-vbox-vm vbox-vm))
(err))))))
(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" "frontal.iro.umontreal.ca" "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)
#t
(if (null? lst)
#f
(if (char=? (car prefix) (car lst))
(same-prefix? (cdr prefix) (cdr lst))
#f))))
(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)
(begin
(if echo? (display c))
(loop (cons c lst)))
#f))))))
(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))
#t
(begin
(if (not echo?) (print output))
#f))))
(define (send-password port)
(if password
(begin
(expect "assword:" port #f)
(send (list password "\n") port))))
(define (sh cmd)
(= 0 (shell-command cmd)))
(define (ssh timeout command)
(let ((port
(open-process
(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)
(begin
(input-port-timeout-set! port +inf.0)
(end-process port #t))
(begin
(close-port port)
#f))))
(define (scp-to timeout src dst)
(let ((port
(open-process
(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
(open-process
(list path: "scp"
arguments: (append (ssh-options #t)
(list (string-append username "@" hostname ":" src)
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 (start-vbox-vm vbox-vm)
(if vbox-vm
(let ((vm-name (list-ref vbox-vm 0)))
(and (sh (string-append "VBoxManage modifyvm \""
vm-name
"\" --natpf1 \"ssh,tcp,localhost,"
(number->string ssh-port)
",,22\""))
(if (sh (string-append "VBoxManage startvm --type headless \""
vm-name
"\""))
(begin
(thread-sleep! 70) ;; allow some time for VM to boot up
#t)
(begin
(end-vbox-vm vbox-vm)
#f))))
#t))
(define (end-vbox-vm vbox-vm)
(if vbox-vm
(let ((vm-name (list-ref vbox-vm 0)))
(sh (string-append "VBoxManage controlvm \""
vm-name
"\" poweroff"
" > /dev/null 2>&1"))
(sh (string-append "VBoxManage modifyvm \""
vm-name
"\" --natpf1 delete \"ssh\""
" > /dev/null 2>&1")))))
Jump to Line
Something went wrong with that request. Please try again.