prebuilt/remote-connect

   1 #! /usr/bin/env gsi
   2
   3 ;; Copyright (c) 2011-2012 by Marc Feeley, All Rights Reserved.
   4
   5 ;; This program allows execution of commands on a remote host.  The
   6 ;; "remote host" may be a real computer or a VM running locally in
   7 ;; VirtualBox.  In the latter case, the VM is started, configured for
   8 ;; ssh, and then terminated when the commands terminate.  The commands
   9 ;; are a sequence of Scheme expressions to execute.  The commands can
  10 ;; include calls to the following procedures, which all return #t if
  11 ;; they executed without error:
  12 ;;
  13 ;;  (sh <command>)                              local shell command execution
  14 ;;  (ssh <timeout-in-seconds> <command>)        remote shell command execution
  15 ;;  (scp-to <timeout-in-seconds> <src> <dst>)   copy local <src> to remote <dst>
  16 ;;  (scp-from <timeout-in-seconds> <src> <dst>) copy remote <src> to local <dst>
  17 ;;
  18 ;; Usage: ./remote-connect <host> <password> <commands>
  19
  20 (define debug? #f)
  21
  22 (define (main host pw commands)
  23   (remote-connect host pw commands))
  24
  25 (define (remote-connect host pw commands)
  26
  27   (define (err)
  28     (exit 1))
  29
  30   (let* ((alias (assoc host host-aliases))
  31          (h (if alias (cadr alias) host))
  32          (vbox-vm (assoc h vbox-vms)))
  33
  34     (if vbox-vm
  35         (begin
  36           (set! hostname "localhost")
  37           (set! username (list-ref vbox-vm 1))
  38           (set! password (if (equal? pw "") (list-ref vbox-vm 2) pw))
  39           (set! ssh-port (list-ref vbox-vm 3)))
  40         (begin
  41           (set! hostname h)
  42           (set! username
  43                 (if (and alias (>= (length alias) 3))
  44                     (caddr alias)
  45                     (user-name)))
  46           (set! password
  47                 (if (and (equal? pw "") alias (>= (length alias) 4))
  48                     (cadddr alias)
  49                     pw))
  50           (if (equal? password "?")
  51               (begin
  52                 (print "\nPassword for " username "@" hostname ": ")
  53                 (set! password (read-line))
  54                 (print "\n")))
  55           (set! ssh-port
  56                 (if (and alias (>= (length alias) 5))
  57                     (car (cddddr alias))
  58                     22))))
  59
  60     (if (equal? password "")
  61         (set! password #f))
  62
  63     (end-vbox-vm vbox-vm)
  64     (if (not (start-vbox-vm vbox-vm))
  65         (err)
  66         (begin
  67           (eval (cons 'begin (with-input-from-string commands read-all)))
  68           (if (not (end-vbox-vm vbox-vm))
  69               (err))))))
  70
  71 (define hostname #f)
  72 (define username #f)
  73 (define password #f)
  74 (define ssh-port #f)
  75
  76 (define host-aliases
  77   '(("macosx"    "Snow-Leopard-x86-VM1")
  78     ("windows"   "Windows-7-Ultimate-x86-VM1")
  79     ("farm"      "frontal.iro.umontreal.ca" "gambit" "?" 22)
  80     ("localhost" "localhost")
  81    ))
  82
  83 ;; Name of the VM and username, password and port to connect to the VM
  84 ;; with ssh.  Note that the password need not be hidden because the
  85 ;; VirtualBox VMs are run locally.
  86
  87 (define vbox-vms
  88   '(("Snow-Leopard-x86-VM1"       "administrator" "pass999word" 2211)
  89     ("Snow-Leopard-x86-VM2"       "administrator" "pass999word" 2212)
  90     ("Snow-Leopard-x86-VM3"       "administrator" "pass999word" 2213)
  91     ("Snow-Leopard-x86-VM4"       "administrator" "pass999word" 2214)
  92     ("Windows-7-Ultimate-x86-VM1" "Admin"         "pass999word" 2221)
  93     ("Windows-7-Ultimate-x86-VM2" "Admin"         "pass999word" 2222)
  94     ("Windows-7-Ultimate-x86-VM3" "Admin"         "pass999word" 2223)
  95     ("Windows-7-Ultimate-x86-VM4" "Admin"         "pass999word" 2224)
  96    ))
  97
  98 (define (ssh-options scp?)
  99   (append (if password
 100               (list "-o" "UserKnownHostsFile=/dev/null"
 101                     "-o" "StrictHostKeyChecking=no"
 102                     "-o" "PreferredAuthentications=keyboard-interactive,password")
 103               '())
 104           (list (if scp? "-P" "-p") (number->string ssh-port))))
 105
 106 (define start-marker "575e2a05-9d7b-448b-ab91-1adbb2a93fd7")
 107
 108 (define (expect str port echo?)
 109
 110   (define (same-prefix? prefix lst)
 111     (if (null? prefix)
 112         #t
 113         (if (null? lst)
 114             #f
 115             (if (char=? (car prefix) (car lst))
 116                 (same-prefix? (cdr prefix) (cdr lst))
 117                 #f))))
 118
 119   (if debug? (set! echo? #t))
 120   (let ((rev-str (reverse (string->list str))))
 121     (let loop ((lst '()))
 122       (if (same-prefix? rev-str lst)
 123           (list->string (reverse lst))
 124           (let ((c (read-char port)))
 125             (if (char? c)
 126                 (begin
 127                   (if echo? (display c))
 128                   (loop (cons c lst)))
 129                 #f))))))
 130
 131 (define (send output port)
 132   (if debug? (print output))
 133   (print port: port output)
 134   (force-output port))
 135
 136 (define (end-process port echo?)
 137   (if debug? (set! echo? #t))
 138   (let* ((output (read-line port #f))
 139          (output (if (string? output) output "")))
 140     (if echo? (print output)) ;; echo command output
 141     (close-port port)
 142     (if (= 0 (process-status port))
 143         #t
 144         (begin
 145           (if (not echo?) (print output))
 146           #f))))
 147
 148 (define (send-password port)
 149   (if password
 150       (begin
 151         (expect "assword:" port #f)
 152         (send (list password "\n") port))))
 153
 154 (define (sh cmd)
 155   (= 0 (shell-command cmd)))
 156
 157 (define (ssh timeout command)
 158   (let ((port
 159          (open-process
 160           (list path: "ssh"
 161                 arguments: (append (ssh-options #f)
 162                                    (list (string-append username "@" hostname)
 163                                          (string-append "echo " start-marker
 164                                                         ";" command)))
 165                 output-eol-encoding: 'cr
 166                 pseudo-terminal: #t))))
 167
 168     (input-port-timeout-set! port timeout) ;; must login within this time
 169
 170     (send-password port)
 171
 172     (if (expect (string-append start-marker "\n") port #f)
 173
 174         (begin
 175           (input-port-timeout-set! port +inf.0)
 176           (end-process port #t))
 177
 178         (begin
 179           (close-port port)
 180           #f))))
 181
 182 (define (scp-to timeout src dst)
 183   (let ((port
 184          (open-process
 185           (list path: "scp"
 186                 arguments: (append (ssh-options #t)
 187                                    (list src
 188                                          (string-append username "@" hostname ":" dst)))
 189                 output-eol-encoding: 'cr
 190                 pseudo-terminal: #t))))
 191
 192     (input-port-timeout-set! port timeout) ;; must login and copy within this time
 193
 194     (send-password port)
 195
 196     (end-process port #f)))
 197
 198 (define (scp-from timeout src dst)
 199   (let ((port
 200          (open-process
 201           (list path: "scp"
 202                 arguments: (append (ssh-options #t)
 203                                    (list (string-append username "@" hostname ":" src)
 204                                          dst))
 205                 output-eol-encoding: 'cr
 206                 pseudo-terminal: #t))))
 207
 208     (input-port-timeout-set! port timeout) ;; must login and copy within this time
 209
 210     (send-password port)
 211
 212     (end-process port #f)))
 213
 214 (define (start-vbox-vm vbox-vm)
 215   (if vbox-vm
 216       (let ((vm-name (list-ref vbox-vm 0)))
 217         (and (sh (string-append "VBoxManage modifyvm \""
 218                                 vm-name
 219                                 "\" --natpf1 \"ssh,tcp,localhost,"
 220                                 (number->string ssh-port)
 221                                 ",,22\""))
 222              (if (sh (string-append "VBoxManage startvm --type headless \""
 223                                     vm-name
 224                                     "\""))
 225                  (begin
 226                    (thread-sleep! 70) ;; allow some time for VM to boot up
 227                    #t)
 228                  (begin
 229                    (end-vbox-vm vbox-vm)
 230                    #f))))
 231       #t))
 232
 233 (define (end-vbox-vm vbox-vm)
 234   (if vbox-vm
 235       (let ((vm-name (list-ref vbox-vm 0)))
 236         (sh (string-append "VBoxManage controlvm \""
 237                            vm-name
 238                            "\" poweroff"
 239                            " > /dev/null 2>&1"))
 240         (sh (string-append "VBoxManage modifyvm \""
 241                            vm-name
 242                            "\" --natpf1 delete \"ssh\""
 243                            " > /dev/null 2>&1")))))
 244