suzanne.soy/distro-build
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

make installer: option to set address & port where server listened

Browse Source 
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
This commit is contained in:
Matthew Flatt 2013-10-18 12:01:56 -06:00
parent 8c959d8df9
commit 012236700a
4 changed files with 84 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/distro-build/config.rkt
View File

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

27
pkgs/distro-build/doc.txt
View File

@ -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"

30
pkgs/distro-build/drive-clients.rkt
View File

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

48
pkgs/distro-build/serve-catalog.rkt
View File

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