From 7d706cb4e648eaba458dc384b46b33d3acc3726a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 18 Oct 2013 20:41:44 -0600 Subject: [PATCH] make installer: make Windows work with bash-serving sshd Makes a Windows build client work with Cygwin's opensshd. --- pkgs/distro-build/config.rkt | 2 +- pkgs/distro-build/doc.txt | 9 ++-- pkgs/distro-build/drive-clients.rkt | 66 ++++++++++++++++++----------- 3 files changed, 49 insertions(+), 28 deletions(-) diff --git a/pkgs/distro-build/config.rkt b/pkgs/distro-build/config.rkt index dd94619288..63dd6c827d 100644 --- 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 index 91ba95b490..6c222b2d19 100644 --- 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 means no spaces, etc.): in the Virtual Box GUI); if provided, the virtual machine is started and stopped on the server as needed - #:platform --- 'windows, 'macosx, or 'unix; defaults to - `(system-type)' + #:platform --- 'unix, 'macosx, 'windows, or 'windows/bash + (which means 'windows though an SSH server providing `bash', such + as Cygwin's); defaults to `(system-type)' #:configure '( ...) --- arguments to `configure' diff --git a/pkgs/distro-build/drive-clients.rkt b/pkgs/distro-build/drive-clients.rkt index c52db33bd3..c3f6a83f78 100644 --- 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)))