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

@@ -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))]

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"

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)))
 

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
+   #:args (config-file config-mode server-hosts server-port . during-cmd)
-   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)