From 012236700ad76a98152d5aea7535d1d54f4225e4 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 18 Oct 2013 12:01:56 -0600
Subject: [PATCH] make installer: option to set address & port where server
listened
Client SSH connections now create remote port forwarding port back
to the server, so that making the server listen only on "localhost"
provides an easy improvement for security (except that remote port
forwarding seems not to work with freeSSHd on Windows).
original commit: acadcd2994504d246790505c85b114fc66d2aad5
---
pkgs/distro-build/config.rkt | 2 ++
pkgs/distro-build/doc.txt | 27 +++++++++++-----
pkgs/distro-build/drive-clients.rkt | 30 +++++++++++-------
pkgs/distro-build/serve-catalog.rkt | 48 ++++++++++++++++++++++++++---
4 files changed, 84 insertions(+), 23 deletions(-)
diff --git a/pkgs/distro-build/config.rkt b/pkgs/distro-build/config.rkt
index f374c76..dd94619 100644
--- a/pkgs/distro-build/config.rkt
+++ b/pkgs/distro-build/config.rkt
@@ -124,6 +124,8 @@
[(#:build-stamp) (string? val)]
[(#:max-vm) (real? val)]
[(#:server) (simple-string? val)]
+ [(#:server-port) (and (exact-integer? val) (<= 1 val 65535))]
+ [(#:server-hosts) (and (list? val) (andmap simple-string? val))]
[(#:host) (simple-string? val)]
[(#:user) (or (not val) (simple-string? val))]
[(#:port) (and (exact-integer? val) (<= 1 val 65535))]
diff --git a/pkgs/distro-build/doc.txt b/pkgs/distro-build/doc.txt
index a44585e..91ba95b 100644
--- a/pkgs/distro-build/doc.txt
+++ b/pkgs/distro-build/doc.txt
@@ -26,7 +26,7 @@ locally.
Each client is normally built by running commands via `ssh', where
the client's host, `#:host' (with and optional `#:port' and/or
-`#:user') indicate the ssh target. Each client machine must be set
+`#:user') indicate the SSH target. Each client machine must be set
up with a public-key authentication, because a direct `ssh' is
expected to work without a password prompt. An exception is when
the host is "localhost" and user is #f, in which case a shell is
@@ -54,7 +54,7 @@ Normally, the client directory is a git clone:
that the server and client are in sync), which means that the
server's directory must be a git clone.
-Note that neither ssh nor git turn out to be needed when the host
+Note that neither SSH nor git turn out to be needed when the host
is "localhost", the user is #f, and the directory is not specified
(which corresponds to the defaults in all cases).
@@ -79,13 +79,13 @@ Machine Requirements
Each Unix or Mac OS X client needs the following available:
- * ssh server with public-key authentication (except "localhost")
+ * SSH server with public-key authentication (except "localhost")
* git (unless the working directory is ready)
* gcc, make, etc.
Each Windows client needs the following:
- * ssh server with public-key authentication
+ * SSH server with public-key authentication
* git (unless the working directory is ready)
* Microsoft Visual Studio 9.0 (2008), installed in the
default folder:
@@ -111,9 +111,9 @@ Site-configuration keywords (where <string*> means no spaces, etc.):
#:host <string*> --- defaults to "localhost"
- #:port <integer> --- ssh port for the client; defaults to 22
+ #:port <integer> --- SSH port for the client; defaults to 22
- #:user <string*/false> --- ssh user for the client; defaults to #f,
+ #:user <string*/false> --- SSH user for the client; defaults to #f,
which means the current user
#:dir <path-string> --- defaults to "build/plt" or "build\\plt", or
@@ -121,7 +121,20 @@ Site-configuration keywords (where <string*> means no spaces, etc.):
is #f
#:server <string*> --- the address of the server as accessed by the
- client; defaults to the `SERVER' makefile variable
+ client; when ssh remote tunneling works, then "localhost" should
+ always work to reach the server; defaults to the `SERVER' makefile
+ variable, which in turn defaults to "localhost"
+
+ #:server-port <integer> --- the port of the server as accessed by
+ the client, and a port used on clients to tunnel back to the
+ server; defaults to the `SERVER_PORT' makefile variable, which in
+ turn defaults to 9440
+
+ #:server-hosts <list-of-string*> --- addresses that determine the
+ interfaces on which the server listens; an empty list means all of
+ the server's interface, while '("localhost") would listen only on
+ the loopback device; defaults to the `SERVER_HOSTS` makefile
+ variable split on comma, which in turn defaults to the empty list
#:repo <string> --- the git repository for Racket; defaults to
"http://<server>:9440/.git"
diff --git a/pkgs/distro-build/drive-clients.rkt b/pkgs/distro-build/drive-clients.rkt
index 490ec5e..c52db33 100644
--- a/pkgs/distro-build/drive-clients.rkt
+++ b/pkgs/distro-build/drive-clients.rkt
@@ -25,7 +25,8 @@
(define snapshot-install-name "snapshot")
(define-values (config-file config-mode
- default-server default-pkgs default-doc-search
+ default-server default-server-port default-server-hosts
+ default-pkgs default-doc-search
default-dist-name default-dist-base default-dist-dir)
(command-line
#:once-each
@@ -34,10 +35,10 @@
[("--clean") "Erase client directories before building"
(set! default-clean? #t)]
#:args (config-file config-mode
- server pkgs doc-search
+ server server-port server-hosts pkgs doc-search
dist-name dist-base dist-dir)
(values config-file config-mode
- server pkgs doc-search
+ server server-port server-hosts pkgs doc-search
dist-name dist-base dist-dir)))
(define config (parameterize ([current-mode config-mode])
@@ -192,7 +193,7 @@
(define scp (find-executable-path "scp"))
(define ssh (find-executable-path "ssh"))
-(define (ssh-script host port user kind . cmds)
+(define (ssh-script host port user server-port kind . cmds)
(for/and ([cmd (in-list cmds)])
(when cmd (display-time))
(or (not cmd)
@@ -201,6 +202,8 @@
(apply system*/show cmd)
(apply system*/show ssh
"-p" (~a port)
+ ;; create tunnel to connect back to server:
+ "-R" (~a server-port ":localhost:" server-port)
(if user
(~a user "@" host)
host)
@@ -237,7 +240,7 @@
"\\\"")))
"\"")]))
-(define (client-args c server kind readme)
+(define (client-args c server server-port kind readme)
(define desc (client-name c))
(define pkgs (let ([l (get-opt c '#:pkgs)])
(if l
@@ -263,6 +266,7 @@
""
(current-stamp))))
(~a " SERVER=" server
+ " SERVER_PORT=" server-port
" PKGS=" (q pkgs)
" DOC_SEARCH=" (q doc-search)
" DIST_DESC=" (q desc)
@@ -280,13 +284,14 @@
(q ""))
" README=" (q (file-name-from-path readme))))
-(define (unix-build c host port user server repo clean? pull? readme)
+(define (unix-build c 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)))
(define j (or (get-opt c '#:j) 1))
(ssh-script
host port user
+ server-port
'unix
(and clean?
(sh "rm -rf " (q dir)))
@@ -298,11 +303,11 @@
"git pull"))
(sh "cd " (q dir) " ; "
"make -j " j " client"
- (client-args c server 'unix readme)
+ (client-args c server server-port 'unix readme)
" JOB_OPTIONS=\"-j " j "\""
" CONFIGURE_ARGS_qq=" (qq (get-opt c '#:configure null) 'unix))))
-(define (windows-build c host port user server repo clean? pull? readme)
+(define (windows-build c 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)
@@ -314,6 +319,7 @@
(list "cmd" "/c" (apply ~a args)))
(ssh-script
host port user
+ server-port
'windows
(and clean?
(cmd "IF EXIST " (q dir) " rmdir /S /Q " (q dir)))
@@ -326,7 +332,7 @@
" " vc
" && nmake win32-client"
" JOB_OPTIONS=\"-j " j "\""
- (client-args c server 'windows readme))))
+ (client-args c server server-port 'windows readme))))
(define (client-build c)
(define host (or (get-opt c '#:host)
@@ -336,8 +342,10 @@
(define user (get-opt c '#:user))
(define server (or (get-opt c '#:server)
default-server))
+ (define server-port (or (get-opt c '#:server-port)
+ default-server-port))
(define repo (or (get-opt c '#:repo)
- (~a "http://" server ":9440/.git")))
+ (~a "http://" server ":" server-port "/.git")))
(define clean? (get-opt c '#:clean? default-clean? #:localhost #f))
(define pull? (get-opt c '#:pull? #t #:localhost #f))
@@ -372,7 +380,7 @@
((case (or (get-opt c '#:platform) (system-type))
[(unix macosx) unix-build]
[else windows-build])
- c host port user server repo clean? pull? readme)
+ c host port user server server-port repo clean? pull? readme)
(delete-file readme)))
diff --git a/pkgs/distro-build/serve-catalog.rkt b/pkgs/distro-build/serve-catalog.rkt
index b608a67..71844c9 100644
--- a/pkgs/distro-build/serve-catalog.rkt
+++ b/pkgs/distro-build/serve-catalog.rkt
@@ -8,19 +8,35 @@
racket/cmdline
racket/file
racket/path
+ racket/string
+ racket/tcp
+ racket/port
racket/system
+ (only-in "config.rkt" extract-options)
"readme.rkt")
(define from-dir "built")
-(define during-cmd-line
+(define-values (config-file config-mode
+ default-server-hosts default-server-port
+ during-cmd-line)
(command-line
#:once-each
[("--mode") dir "Serve package archives from <dir> subdirectory"
(set! from-dir dir)]
- #:args during-cmd
- during-cmd))
+ #:args (config-file config-mode server-hosts server-port . during-cmd)
+ (values config-file config-mode
+ server-hosts (string->number server-port)
+ during-cmd)))
+(define server-hosts
+ (hash-ref (extract-options config-file config-mode)
+ '#:server-hosts
+ (string-split default-server-hosts ",")))
+(define server-port
+ (hash-ref (extract-options config-file config-mode)
+ '#:server-port
+ default-server-port))
(define build-dir (path->complete-path "build"))
(define built-dir (build-path build-dir from-dir))
@@ -111,11 +127,33 @@
[("pkg" (string-arg)) write-info]
[("upload" (string-arg)) #:method "put" receive-file]))
+;; Tunnel extra hosts to first one:
+(when (and (pair? server-hosts)
+ (pair? (cdr server-hosts)))
+ (for ([host (in-list (cdr server-hosts))])
+ (thread
+ (lambda ()
+ (define l (tcp-listen server-port 5 #t host))
+ (let loop ()
+ (define-values (i o) (tcp-accept l))
+ (define-values (i2 o2) (tcp-connect (car server-hosts) server-port))
+ (thread (lambda ()
+ (copy-port i o2)
+ (close-input-port i)
+ (close-output-port o2)))
+ (thread (lambda ()
+ (copy-port i2 o)
+ (close-input-port i2)
+ (close-output-port o)))
+ (loop))))))
+
(define (go)
(serve/servlet
dispatch
#:command-line? #t
- #:listen-ip #f
+ #:listen-ip (if (null? server-hosts)
+ #f
+ (car server-hosts))
#:extra-files-paths
(append
(list (build-path build-dir "origin"))
@@ -125,7 +163,7 @@
;; for ".git":
(list (current-directory)))
#:servlet-regexp #rx""
- #:port 9440))
+ #:port server-port))
(define readmes-dir (build-path build-dir "readmes"))
(make-directory* readmes-dir)