commit 702f0fff3bb681958be1167a6e937dc52994d161
parent 6225df6f5e90559c24aa5db886b35fde427fc55d
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 22 Jun 2013 10:55:56 -0600
add build-farm support to Makefile
The `farm' target run `server', but after the server starts, also
builds clients (via `ssh') as specified in a configuration file.
A client can be a VirtualBox virtual machine, in which case
the client machine can be started and stopped automatically.
Most of the work is in `distro-build/drive-clients' (in the
"distro-build" package), and that's where the configuration-file
format and client-machine requirements are documented.
original commit: 4e23a52f01d81ef7c19c42e0c54f96df54244526
Diffstat:
3 files changed, 562 insertions(+), 20 deletions(-)
diff --git a/pkgs/distro-build/drive-clients.rkt b/pkgs/distro-build/drive-clients.rkt
@@ -0,0 +1,490 @@
+#lang racket/base
+
+;; Each client is built by running commands via `ssh', where the
+;; client's host (and optional port and/or user) indicate the ssh
+;; target. Each client machine must be set up with a public-key
+;; authenticaion, because a direct `ssh' is expected to work without a
+;; password prompt.
+;;
+;; On the client machine, all work is performed with a git clone at a
+;; specified directory that defaults to "build/plt" (Unix, Mac OS X)
+;; or "build\\plt" (Windows).
+;;
+;; If a build fails for a machine, building continues on other
+;; machines. Success for a given machine means that its installer
+;; ends up in "build/installers" (and failure for a machine means no
+;; installer).
+;;
+;; Machine Requirements
+;; --------------------
+;;
+;; Each Unix or Mac OS X client needs the following available:
+;;
+;; * ssh server with public-key authentication
+;; * git
+;; * gcc, make, etc.
+;;
+;; Each Windows client needs the following:
+;;
+;; * git
+;; * Microsoft Visual Studio 9.0 (2008), installed in the
+;; default folder:
+;; C:\Program Files\Microsoft Visual Studio 9.0 (32-bit host)
+;; C:\Program Files (x86)\Microsoft Visual Studio 9.0 (64-bit host)
+;; * Nullsoft Scriptable Install System (NSIS), installed in the
+;; default folder:
+;; C:\Program Files\NSIS\makensis.exe
+;; or C:\Program Files (x86)\NSIS\makensis.exe
+;; or instaled so that `makensis' in in yur PATH.
+;;
+;; Farm Configuration
+;; -------------------
+;;
+;; A farm configuration file is `read' to obtain a configuration. The
+;; file must have a single S-expression that matches the <config>
+;; grammar:
+;;
+;; <config> = (machine <keyword> <val> ... ...)
+;; | (<group-kind> <keyword> <val> ... ... <config> ...)
+;;
+;; <group-kind> = parallel | sequential
+;;
+;; Normally, a configuration file start with "(<group-kind> ...)", since
+;; the configuration otherwise specifies only one client machine.
+;;
+;; A `<keyword> <val> ... ...' sequence specifies options as
+;; keyword--value pairs. The available options are listed below. The
+;; options of a group are propagated to all machines in the group,
+;; except at overridden at a machine or nested group.
+;;
+;; A <group-kind> specifies whether the machines within a group are
+;; run sequentially or in parallel. Note that the default`#:max-vm'
+;; setting is 1, so a parallel configuration of virtual machines will
+;; fail (for some machines) unless `#:max-vm' is increased.
+;;
+;; Machine/group keywords (where <string*> means no spaces, etc.):
+;;
+;; #:pkgs (<string*> ...) --- packages to install; defaults to
+;; the `pkgs' command-line argument
+;; #:server <string*> --- the address of the server from the client;
+;; defaults to `server' command-line argument
+;; #:dist-name <string> --- the distribution name; defaults to the
+;; `dist-name' command-line argument
+;; #:dist-dir <string> --- the distribution's installation directory;
+;; defaults to `dist-dir' command-line argument
+;; #:max-vm <real> --- max number of VMs allowed to run with this
+;; machine, counting the machine; defaults to 1
+;; #:port <integer> --- ssh port for the client; defaults to 22
+;; #:user <string*> --- ssh user for the client; defaults to current user
+;; #:dir <string> --- defaults to "build/plt" or "build\\plt"
+;; #:vbox <string> --- Virtual Box machine name; if provided the
+;; virtual machine is started and stopped as needed
+;; #:platform <symbol> --- 'windows or 'unix, defaults to 'unix
+;; #:bits <integer> --- 32 or 64, affects Visual Studio path
+;; #:vc <string*> --- "x86" or "x64" to select the Visual C build mode;
+;; default depends on bits
+;; #:j <integer> --- parallelism for `make' on Unix and Mac OS X;
+;; defaults to 1
+;; #:timeout <number> --- numbers of seconds to wait before declaring
+;; failure; defaults to 30 minutes
+;; #:repo <string> --- the git repository for Racket; defaults to
+;; "git://github.com/plt/racket.git"
+;;
+;; Machine-only keywords:
+;; #:name <string> --- defaults to host
+;; #:host <string*> --- defaults to "localhost"
+
+;; ----------------------------------------
+
+(require racket/cmdline
+ racket/system
+ racket/port
+ racket/format
+ racket/file
+ racket/string)
+
+;; ----------------------------------------
+
+(define release? #f)
+
+(define-values (config-file default-server default-pkgs default-dist-name default-dist-dir)
+ (command-line
+ #:once-each
+ [("--release") "Create release-mode installers"
+ (set! release? #t)]
+ #:args (config-file server pkgs dist-name dist-dir)
+ (values config-file server pkgs dist-name dist-dir)))
+
+(define config (call-with-input-file* config-file read))
+
+;; ----------------------------------------
+
+(define (simple-string? s)
+ (and (string? s)
+ ;; No spaces, quotes, or other things that could
+ ;; break a command-line, path, or URL construction:
+ (regexp-match #rx"^[-a-zA-A0-9.]*$" s)))
+
+(define (check-group-keyword kw val)
+ (case kw
+ [(#:pkgs) (and (list? val) (andmap simple-string? val))]
+ [(#:dist-name) (string? val)]
+ [(#:dist-dir) (simple-string? val)]
+ [(#:max-vm) (real? val)]
+ [(#:server) (simple-string? val)]
+ [(#:user) (simple-string? val)]
+ [(#:port) (and (exact-integer? val) (<= 1 val 65535))]
+ [(#:dir) (string? val)]
+ [(#:vbox) (string? val)]
+ [(#:platform) (memq val '(unix windows))]
+ [(#:bits) (or (equal? val 32) (equal? val 64))]
+ [(#:vc) (or (equal? val "x86") (equal? val "x64"))]
+ [(#:timeout) (real? val)]
+ [(#:j) (exact-positive-integer? val)]
+ [(#:repo) (string? val)]
+ [else #f]))
+
+(define (check-machine-keyword kw val)
+ (case kw
+ [(#:name) (string? val)]
+ [(#:host) (simple-string? val)]
+ [else (check-group-keyword kw val)]))
+
+(define (check-config config)
+ (define (bad-format msg . rest)
+ (raise-user-error 'drive-clients
+ "~a"
+ (apply ~a "bad configuration"
+ "\n " msg
+ (if config-file
+ (~a "\n config file: "
+ config-file)
+ "")
+ rest)))
+ (unless (list? config)
+ (bad-format (if config-file
+ "does not `read' as a list"
+ "not a list")))
+ (let loop ([config config])
+ (unless (list? config)
+ (bad-format "not a list"
+ (format "\n given: ~e" config)))
+ (cond
+ [(and (pair? config)
+ (or (eq? 'parallel (car config))
+ (eq? 'sequential (car config))))
+ (let gloop ([group (cdr config)])
+ (cond
+ [(keyword? (car group))
+ (unless (pair? (cdr group))
+ (bad-format "missing value after group keyword"
+ (format "\n keyword: ~e" (car group))))
+ (unless (check-group-keyword (car group) (cadr group))
+ (bad-format "bad value for keyword in group"
+ (format "\n keyword: ~e\n value: ~e"
+ (car group)
+ (cadr group))))
+ (gloop (cddr group))]
+ [else (for-each loop group)]))]
+ [(and (pair? config)
+ (eq? 'machine (car config)))
+ (let loop ([client (cdr config)])
+ (cond
+ [(null? client) (void)]
+ [(keyword? (car client))
+ (unless (pair? (cdr client))
+ (bad-format "machine spec missing value after keyword"
+ (format "\n keyword: ~e" (car client))))
+ (unless (check-machine-keyword (car client) (cadr client))
+ (bad-format "bad value for keyword in machine spec"
+ (format "\n keyword: ~e\n value: ~e"
+ (car client)
+ (cadr client))))
+ (loop (cddr client))]
+ [else
+ (bad-format "bad machine spec; expected a keyword"
+ (format "\n found: ~e" (car client)))]))]
+ [else
+ (bad-format "bad format (does not start with 'machine, 'parallel, or 'sequential)"
+ (format "\n found: ~e" config))])))
+
+(check-config config)
+
+;; ----------------------------------------
+
+(define (merge-options opts c)
+ (let loop ([c (cdr c)] [opts opts])
+ (cond
+ [(and (pair? c)
+ (keyword? (car c)))
+ (loop (cddr c)
+ (hash-set opts (car c) (cadr c)))]
+ [else opts])))
+
+(define (get-opt opts kw)
+ (hash-ref opts kw #f))
+
+(define (get-content c)
+ (let loop ([c (cdr c)])
+ (if (and (pair? c)
+ (keyword? (car c)))
+ (loop (cddr c))
+ c)))
+
+(define (client-name opts)
+ (or (get-opt opts '#:name)
+ (get-opt opts '#:host)
+ "localhost"))
+
+;; ----------------------------------------
+;; Managing VirtualBox machines
+
+(define VBoxManage (find-executable-path "VBoxManage"))
+(define use-headless? #t)
+
+(define (system*/show exe . args)
+ (displayln (apply ~a #:separator " "
+ (map (lambda (p) (if (path? p) (path->string p) p))
+ (cons exe args))))
+ (apply system* exe args))
+
+(define (system*/string . args)
+ (define s (open-output-string))
+ (parameterize ([current-output-port s])
+ (apply system* args))
+ (get-output-string s))
+
+(define (vbox-state vbox)
+ (define s (system*/string VBoxManage "showvminfo" vbox))
+ (define m (regexp-match #rx"(?m:^State:[ ]*([a-z]+(?: [a-z]+)*))" s))
+ (define state (and m (string->symbol (cadr m))))
+ (case state
+ [(|powered off| aborted) 'off]
+ [(running saved paused) state]
+ [(restoring) (vbox-state vbox)]
+ [else
+ (eprintf "~a\n" s)
+ (error 'vbox-state "could not get virtual machine status: ~s" vbox)]))
+
+(define (vbox-control vbox what)
+ (system* VBoxManage "controlvm" vbox what))
+
+(define (vbox-start vbox)
+ (apply system* VBoxManage "startvm" vbox
+ (if use-headless?
+ '("--type" "headless")
+ null))
+ ;; wait for the machine to get going:
+ (let loop ([n 0])
+ (unless (eq? 'running (vbox-state vbox))
+ (unless (= n 20)
+ (sleep 0.5)
+ (loop (add1 n))))))
+
+(define call-with-vbox-lock
+ (let ([s (make-semaphore 1)]
+ [lock-cust (current-custodian)])
+ (lambda (thunk)
+ (define t (current-thread))
+ (define ready (make-semaphore))
+ (define done (make-semaphore))
+ (parameterize ([current-custodian lock-cust])
+ (thread (lambda ()
+ (semaphore-wait s)
+ (semaphore-post ready)
+ (sync t done)
+ (semaphore-post s))))
+ (sync ready)
+ (thunk)
+ (semaphore-post done))))
+
+(define (start-client c max-vm)
+ (define vbox (get-opt c '#:vbox))
+ (define (check-count)
+ (define s (system*/string VBoxManage "list" "runningvms"))
+ (unless ((length (string-split s "\n")) . < . max-vm)
+ (error 'start-client "too many virtual machines running (>= ~a) to start: ~s"
+ max-vm
+ (client-name c))))
+ (when vbox
+ (printf "Starting VirtualBox machine ~s\n" vbox)
+ (case (vbox-state vbox)
+ [(running) (void)]
+ [(paused) (vbox-control vbox "resume")]
+ [(off saved) (call-with-vbox-lock
+ (lambda ()
+ (check-count)
+ (vbox-start vbox)))])
+ (unless (eq? (vbox-state vbox) 'running)
+ (error 'start-client "could not get virtual machine started: ~s" (client-name c))))
+ ;; pause a little to let the VM get networkign ready, etc.
+ (sleep 3))
+
+(define (stop-client c)
+ (define vbox (get-opt c '#:vbox))
+ (when vbox
+ (printf "Stopping VirtualBox machine ~s\n" vbox)
+ (vbox-control vbox "savestate")
+ (unless (eq? (vbox-state vbox) 'saved)
+ (error 'start-client "virtual machine isn't in the expected saved state: ~s" c))))
+
+;; ----------------------------------------
+
+(define scp (find-executable-path "scp"))
+(define ssh (find-executable-path "ssh"))
+
+(define (ssh-script host port user . cmds)
+ (for/and ([cmd (in-list cmds)])
+ (apply system*/show ssh
+ "-p" (~a port)
+ (if user
+ (~a user "@" host)
+ host)
+ cmd)))
+
+(define (q s)
+ (~a "\"" s "\""))
+
+(define (client-args server pkgs dist-name dist-dir)
+ (~a " SERVER=" server
+ " PKGS=" (q pkgs)
+ " DIST_NAME=" (q dist-name)
+ " DIST_DIR=" dist-dir
+ " RELEASE_MODE=" (if release? "--release" (q ""))))
+
+(define (unix-build c host port user server repo
+ pkgs dist-name dist-dir)
+ (define dir (or (get-opt c '#:dir)
+ "build/plt"))
+ (define (sh . args)
+ (list "/bin/sh" "-c" (~a "'" (apply ~a args) "'")))
+ (define j (or (get-opt c '#:j) 1))
+ (ssh-script
+ host port user
+ (sh "if [ ! -d " (q dir) " ] ; then"
+ " git clone " (q repo) " " (q dir) " ; "
+ "fi")
+ (sh "cd " (q dir) " ; "
+ "git pull")
+ (sh "cd " (q dir) " ; "
+ "make -j " j " client"
+ (client-args server pkgs dist-name dist-dir))))
+
+(define (windows-build c host port user server repo
+ pkgs dist-name dist-dir)
+ (define dir (or (get-opt c '#:dir)
+ "build\\plt"))
+ (define bits (or (get-opt c '#:bits) 64))
+ (define vc (or (get-opt c '#:vc)
+ (if (= bits 32)
+ "x86"
+ "x64")))
+ (define (cmd . args)
+ (list "cmd" "/c" (apply ~a args)))
+ (ssh-script
+ host port user
+ (cmd "IF NOT EXIST " (q dir) " git clone " (q repo) " " (q dir))
+ (cmd "cd " (q dir)
+ " && git pull")
+ (cmd "cd " (q dir)
+ " && \"c:\\Program Files" (if (= bits 64) " (x86)" "") "\\Microsoft Visual Studio 9.0\\vc\\vcvarsall.bat\""
+ " " (if (= bits 64) "x64" "x86")
+ " && nmake win32-client" (client-args server pkgs dist-name dist-dir))))
+
+(define (client-build c)
+ (define host (or (get-opt c '#:host)
+ "localhost"))
+ (define port (or (get-opt c '#:port)
+ 22))
+ (define user (get-opt c '#:user))
+ (define server (or (get-opt c '#:server)
+ default-server))
+ (define pkgs (or (get-opt c '#:pkgs)
+ default-pkgs))
+ (define dist-name (or (get-opt c '#:dist-name)
+ default-dist-name))
+ (define dist-dir (or (get-opt c '#:dist-dir)
+ default-dist-dir))
+ (define repo (or (get-opt c '#:repo)
+ "git://github.com/plt/racket.git"))
+ ((case (or (get-opt c '#:platform) 'unix)
+ [(unix) unix-build]
+ [else windows-build])
+ c host port user server repo
+ pkgs dist-name dist-dir))
+
+;; ----------------------------------------
+
+(define (limit-and-report-failure c timeout-factor thunk)
+ (define cust (make-custodian))
+ (define timeout (or (get-opt c '#:timeout)
+ (* 30 60)))
+ (define orig-thread (current-thread))
+ (parameterize ([current-custodian cust])
+ (thread (lambda ()
+ (sleep (* timeout-factor timeout))
+ ;; try nice interrupt, first:
+ (break-thread orig-thread)
+ (sleep 1)
+ ;; force quit:
+ (custodian-shutdown-all cust)))
+ (with-handlers ([exn? (lambda (exn)
+ (log-error "~a failed..." (client-name c))
+ (log-error (exn-message exn)))])
+ (thunk)))
+ (custodian-shutdown-all cust))
+
+(define (client-thread c sequential? thunk)
+ (define log-dir (build-path "build" "drive"))
+ (define log-file (build-path log-dir (client-name c)))
+ (make-directory* log-dir)
+ (printf "Logging build: ~a\n" log-file)
+ (define (go)
+ (define p (open-output-file log-file
+ #:exists 'truncate/replace))
+ (file-stream-buffer-mode p 'line)
+ (parameterize ([current-output-port p]
+ [current-error-port p])
+ (thunk)))
+ (cond
+ [sequential? (go) (thread void)]
+ [else (thread go)]))
+
+;; ----------------------------------------
+
+(void
+ (let loop ([config config]
+ [mode 'sequential]
+ [opts (hasheq)])
+ (case (car config)
+ [(parallel sequential)
+ (define new-opts (merge-options opts config))
+ (define ts
+ (map (lambda (c) (loop c
+ (car config)
+ new-opts))
+ (get-content config)))
+ (define (wait)
+ (for ([t (in-list ts)])
+ (sync t)))
+ (cond
+ [(eq? mode 'sequential) (wait) (thread void)]
+ [else (thread wait)])]
+ [else
+ (define c (merge-options opts config))
+ (client-thread
+ c
+ (eq? mode 'sequential)
+ (lambda ()
+ (limit-and-report-failure
+ c 2
+ (lambda ()
+ ;; start client, if a VM:
+ (start-client c (or (get-opt c '#:max-vm) 1))
+ ;; catch failure in build step proper, so we
+ ;; can more likely stop the client:
+ (limit-and-report-failure
+ c 1
+ (lambda () (client-build c)))
+ ;; stop client, if a VM:
+ (stop-client c)))))])))
diff --git a/pkgs/distro-build/installer.rkt b/pkgs/distro-build/installer.rkt
@@ -2,15 +2,21 @@
(require racket/cmdline
"installer-sh.rkt"
"installer-dmg.rkt"
- "installer-exe.rkt")
+ "installer-exe.rkt"
+ net/url
+ racket/file
+ racket/path)
(define release? #f)
+(define upload-to #f)
(define-values (short-human-name human-name dir-name)
(command-line
#:once-each
[("--release") "Create a release installer"
(set! release? #t)]
+ [("--upload") url "Upload installer"
+ (set! upload-to url)]
#:args
(human-name dir-name)
(values human-name
@@ -29,3 +35,14 @@
(build-path "bundle" "installer.txt")
#:exists 'truncate/replace
(lambda (o) (fprintf o "~a\n" installer-file)))
+
+(when upload-to
+ (printf "Upload ~a to ~a\n" installer-file upload-to)
+ (define i
+ (put-pure-port
+ (string->url (format "~aupload/~a"
+ upload-to
+ (path->string (file-name-from-path installer-file))))
+ (file->bytes installer-file)))
+ (unless (equal? (read i) #t)
+ (error "file upload failed")))
diff --git a/pkgs/distro-build/serve-catalog.rkt b/pkgs/distro-build/serve-catalog.rkt
@@ -5,16 +5,20 @@
web-server/http/request-structs
net/url
racket/format
- racket/cmdline)
+ racket/cmdline
+ racket/file
+ racket/path
+ racket/system)
(define from-dir "built")
-(command-line
- #:once-each
- [("--mode") dir "Serve package archives from <dir> subdirectory"
- (set! from-dir dir)]
- #:args ()
- (void))
+(define during-cmd-line
+ (command-line
+ #:once-each
+ [("--mode") dir "Serve package archives from <dir> subdirectory"
+ (set! from-dir dir)]
+ #:args during-cmd
+ during-cmd))
(define build-dir (path->complete-path "build"))
@@ -64,18 +68,49 @@
(define (write-info req pkg-name)
(response/sexpr (pkg-name->info req pkg-name)))
+(define (receive-file req filename)
+ (unless (relative-path? filename)
+ (error "upload path name must be relative"))
+ (define dir (build-path build-dir "installers"))
+ (make-directory* dir)
+ (call-with-output-file (build-path dir filename)
+ #:exists 'truncate/replace
+ (lambda (o)
+ (write-bytes (request-post-data/raw req) o)))
+ (response/sexpr #t))
+
(define-values (dispatch main-url)
(dispatch-rules
- [("pkg" (string-arg)) write-info]))
+ [("pkg" (string-arg)) write-info]
+ [("upload" (string-arg)) #:method "put" receive-file]))
+
+(define (go)
+ (serve/servlet
+ dispatch
+ #:command-line? #t
+ #:listen-ip #f
+ #:extra-files-paths
+ (cons
+ (build-path build-dir "origin")
+ (for/list ([d (in-list dirs)])
+ (path->complete-path (build-path d "pkgs"))))
+ #:servlet-regexp #rx""
+ #:port 9440))
-(serve/servlet
- dispatch
- #:command-line? #t
- #:listen-ip #f
- #:extra-files-paths
- (cons
- (build-path build-dir "origin")
- (for/list ([d (in-list dirs)])
- (path->complete-path (build-path d "pkgs"))))
- #:servlet-regexp #rx""
- #:port 9440)
+(if (null? during-cmd-line)
+ ;; Just run server:
+ (go)
+ ;; Run server in a background thread, finish by
+ ;; running given command:
+ (let ([t (thread go)])
+ (sync (system-idle-evt)) ; try to wait until server is ready
+ (unless (apply system*
+ (let ([exe (car during-cmd-line)])
+ (if (and (relative-path? exe)
+ (not (path-only exe)))
+ (find-executable-path exe)
+ exe))
+ (cdr during-cmd-line))
+ (error 'server-catalog
+ "command failed: ~s"
+ during-cmd-line))))
