commit c3b3c1357fbc4acd194e8b5a5c87b1863cc9045f
parent 012236700ad76a98152d5aea7535d1d54f4225e4
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 18 Oct 2013 20:41:44 -0600
make installer: make Windows work with bash-serving sshd
Makes a Windows build client work with Cygwin's opensshd.
original commit: 7d706cb4e648eaba458dc384b46b33d3acc3726a
Diffstat:
3 files changed, 49 insertions(+), 28 deletions(-)
diff --git a/pkgs/distro-build/config.rkt b/pkgs/distro-build/config.rkt
@@ -131,7 +131,7 @@
[(#:port) (and (exact-integer? val) (<= 1 val 65535))]
[(#:dir) (path-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))]
[(#:bits) (or (equal? val 32) (equal? val 64))]
[(#:vc) (or (equal? val "x86") (equal? val "x64"))]
diff --git a/pkgs/distro-build/doc.txt b/pkgs/distro-build/doc.txt
@@ -85,7 +85,9 @@ Each Unix or Mac OS X client needs the following available:
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)
* Microsoft Visual Studio 9.0 (2008), installed in the
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
started and stopped on the server as needed
- #:platform <symbol> --- 'windows, 'macosx, or 'unix; defaults to
- `(system-type)'
+ #:platform <symbol> --- 'unix, 'macosx, 'windows, or 'windows/bash
+ (which means 'windows though an SSH server providing `bash', such
+ as Cygwin's); defaults to `(system-type)'
#:configure '(<string> ...) --- arguments to `configure'
diff --git a/pkgs/distro-build/drive-clients.rkt b/pkgs/distro-build/drive-clients.rkt
@@ -222,23 +222,39 @@
(define (qq l kind)
(case kind
- [(unix) (~a "'"
- (apply ~a #:separator " " (map q l))
- "'")]
- [(windows) (~a "\""
- (apply
- ~a #:separator " "
- (for/list ([i (in-list l)])
- (~a "\\\""
- i
- ;; A backslash is literal unless followed by a
- ;; quote. If `i' ends in backslashes, they
- ;; must be doubled, because the \" added to
- ;; the end will make them treated as escapes.
- (let ([m (regexp-match #rx"\\\\*$" i)])
- (car m))
- "\\\"")))
- "\"")]))
+ [(unix macosx)
+ (~a "'"
+ (apply ~a #:separator " " (map q l))
+ "'")]
+ [(windows windows/bash)
+ (~a "\""
+ (apply
+ ~a #:separator " "
+ (for/list ([i (in-list l)])
+ (~a "\\\""
+ i
+ ;; A backslash is literal unless followed by a
+ ;; quote. If `i' ends in backslashes, they
+ ;; must be doubled, because the \" added to
+ ;; the end will make them treated as escapes.
+ (let ([m (regexp-match #rx"\\\\*$" i)])
+ (car m))
+ "\\\"")))
+ "\"")]))
+
+(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 desc (client-name c))
@@ -284,7 +300,7 @@
(q ""))
" 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 (sh . args)
(list "/bin/sh" "-c" (apply ~a args)))
@@ -307,7 +323,7 @@
" JOB_OPTIONS=\"-j " j "\""
" 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 bits (or (get-opt c '#:bits) 64))
(define vc (or (get-opt c '#:vc)
@@ -316,11 +332,11 @@
"x64")))
(define j (or (get-opt c '#:j) 1))
(define (cmd . args)
- (list "cmd" "/c" (apply ~a args)))
+ (list "cmd" "/c" (shell-protect (apply ~a args) platform)))
(ssh-script
host port user
server-port
- 'windows
+ platform
(and clean?
(cmd "IF EXIST " (q dir) " rmdir /S /Q " (q dir)))
(cmd "IF NOT EXIST " (q dir) " git clone " (q repo) " " (q dir))
@@ -332,7 +348,7 @@
" " vc
" && nmake win32-client"
" 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 host (or (get-opt c '#:host)
@@ -375,12 +391,14 @@
;; ensure a newline at the end:
(newline o))))
+ (define platform (or (get-opt c '#:platform) (system-type)))
+
(begin0
- ((case (or (get-opt c '#:platform) (system-type))
+ ((case platform
[(unix macosx) unix-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)))
