make installer: make Windows work with bash-serving sshd

Makes a Windows build client work with Cygwin's opensshd.
This commit is contained in:
Matthew Flatt 2013-10-18 20:41:44 -06:00
parent acadcd2994
commit 7d706cb4e6
3 changed files with 49 additions and 28 deletions

View File

@ -131,7 +131,7 @@
[(#:port) (and (exact-integer? val) (<= 1 val 65535))] [(#:port) (and (exact-integer? val) (<= 1 val 65535))]
[(#:dir) (path-string? val)] [(#:dir) (path-string? val)]
[(#:vbox) (string? val)] [(#:vbox) (string? val)]
[(#:platform) (memq val '(unix windows))] [(#:platform) (memq val '(unix macosx windows windows/bash))]
[(#:configure) (and (list? val) (andmap string? val))] [(#:configure) (and (list? val) (andmap string? val))]
[(#:bits) (or (equal? val 32) (equal? val 64))] [(#:bits) (or (equal? val 32) (equal? val 64))]
[(#:vc) (or (equal? val "x86") (equal? val "x64"))] [(#:vc) (or (equal? val "x86") (equal? val "x64"))]

View File

@ -85,7 +85,9 @@ Each Unix or Mac OS X client needs the following available:
Each Windows client needs the following: Each Windows client needs the following:
* SSH server with public-key authentication * SSH server with public-key authentication, providing either a
Windows command line (like freeSSHd) or bash with access to
cmd.exe (like Cygwin's opensshd)
* git (unless the working directory is ready) * git (unless the working directory is ready)
* Microsoft Visual Studio 9.0 (2008), installed in the * Microsoft Visual Studio 9.0 (2008), installed in the
default folder: default folder:
@ -195,8 +197,9 @@ Site-configuration keywords (where <string*> means no spaces, etc.):
in the Virtual Box GUI); if provided, the virtual machine is in the Virtual Box GUI); if provided, the virtual machine is
started and stopped on the server as needed started and stopped on the server as needed
#:platform <symbol> --- 'windows, 'macosx, or 'unix; defaults to #:platform <symbol> --- 'unix, 'macosx, 'windows, or 'windows/bash
`(system-type)' (which means 'windows though an SSH server providing `bash', such
as Cygwin's); defaults to `(system-type)'
#:configure '(<string> ...) --- arguments to `configure' #:configure '(<string> ...) --- arguments to `configure'

View File

@ -222,10 +222,12 @@
(define (qq l kind) (define (qq l kind)
(case kind (case kind
[(unix) (~a "'" [(unix macosx)
(~a "'"
(apply ~a #:separator " " (map q l)) (apply ~a #:separator " " (map q l))
"'")] "'")]
[(windows) (~a "\"" [(windows windows/bash)
(~a "\""
(apply (apply
~a #:separator " " ~a #:separator " "
(for/list ([i (in-list l)]) (for/list ([i (in-list l)])
@ -240,6 +242,20 @@
"\\\""))) "\\\"")))
"\"")])) "\"")]))
(define (shell-protect s kind)
(case kind
[(windows/bash)
;; protect Windows arguments to go through bash, where
;; backslashes must be escaped, but quotes are effectively
;; preserved by the shell; also, "&&" must be quoted to
;; parsing by bash
(regexp-replace* "&&"
(regexp-replace* #rx"[\\]"
s
"\\\\\\0")
"\"\\&\\&\"")]
[else s]))
(define (client-args c server server-port kind readme) (define (client-args c server server-port kind readme)
(define desc (client-name c)) (define desc (client-name c))
(define pkgs (let ([l (get-opt c '#:pkgs)]) (define pkgs (let ([l (get-opt c '#:pkgs)])
@ -284,7 +300,7 @@
(q "")) (q ""))
" README=" (q (file-name-from-path readme)))) " README=" (q (file-name-from-path readme))))
(define (unix-build c host port user server server-port repo clean? pull? readme) (define (unix-build c platform host port user server server-port repo clean? pull? readme)
(define dir (get-path-opt c '#:dir "build/plt" #:localhost (current-directory))) (define dir (get-path-opt c '#:dir "build/plt" #:localhost (current-directory)))
(define (sh . args) (define (sh . args)
(list "/bin/sh" "-c" (apply ~a args))) (list "/bin/sh" "-c" (apply ~a args)))
@ -307,7 +323,7 @@
" JOB_OPTIONS=\"-j " j "\"" " JOB_OPTIONS=\"-j " j "\""
" CONFIGURE_ARGS_qq=" (qq (get-opt c '#:configure null) 'unix)))) " CONFIGURE_ARGS_qq=" (qq (get-opt c '#:configure null) 'unix))))
(define (windows-build c host port user server server-port repo clean? pull? readme) (define (windows-build c platform host port user server server-port repo clean? pull? readme)
(define dir (get-path-opt c '#:dir "build\\plt" #:localhost (current-directory))) (define dir (get-path-opt c '#:dir "build\\plt" #:localhost (current-directory)))
(define bits (or (get-opt c '#:bits) 64)) (define bits (or (get-opt c '#:bits) 64))
(define vc (or (get-opt c '#:vc) (define vc (or (get-opt c '#:vc)
@ -316,11 +332,11 @@
"x64"))) "x64")))
(define j (or (get-opt c '#:j) 1)) (define j (or (get-opt c '#:j) 1))
(define (cmd . args) (define (cmd . args)
(list "cmd" "/c" (apply ~a args))) (list "cmd" "/c" (shell-protect (apply ~a args) platform)))
(ssh-script (ssh-script
host port user host port user
server-port server-port
'windows platform
(and clean? (and clean?
(cmd "IF EXIST " (q dir) " rmdir /S /Q " (q dir))) (cmd "IF EXIST " (q dir) " rmdir /S /Q " (q dir)))
(cmd "IF NOT EXIST " (q dir) " git clone " (q repo) " " (q dir)) (cmd "IF NOT EXIST " (q dir) " git clone " (q repo) " " (q dir))
@ -332,7 +348,7 @@
" " vc " " vc
" && nmake win32-client" " && nmake win32-client"
" JOB_OPTIONS=\"-j " j "\"" " JOB_OPTIONS=\"-j " j "\""
(client-args c server server-port 'windows readme)))) (client-args c server server-port platform readme))))
(define (client-build c) (define (client-build c)
(define host (or (get-opt c '#:host) (define host (or (get-opt c '#:host)
@ -375,12 +391,14 @@
;; ensure a newline at the end: ;; ensure a newline at the end:
(newline o)))) (newline o))))
(define platform (or (get-opt c '#:platform) (system-type)))
(begin0 (begin0
((case (or (get-opt c '#:platform) (system-type)) ((case platform
[(unix macosx) unix-build] [(unix macosx) unix-build]
[else windows-build]) [else windows-build])
c host port user server server-port repo clean? pull? readme) c platform host port user server server-port repo clean? pull? readme)
(delete-file readme))) (delete-file readme)))