From 4e23a52f01d81ef7c19c42e0c54f96df54244526 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 22 Jun 2013 10:55:56 -0600 Subject: [PATCH] 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. --- INSTALL.txt | 136 +++++--- Makefile | 58 +++- pkgs/distro-build/drive-clients.rkt | 490 ++++++++++++++++++++++++++++ pkgs/distro-build/installer.rkt | 19 +- pkgs/distro-build/serve-catalog.rkt | 73 +++-- 5 files changed, 700 insertions(+), 76 deletions(-) create mode 100644 pkgs/distro-build/drive-clients.rkt diff --git a/INSTALL.txt b/INSTALL.txt index c7479ce11e..106b8462b4 100644 --- a/INSTALL.txt +++ b/INSTALL.txt @@ -1,3 +1,13 @@ +Quick Instrctions +================= + +On Unix of Mac OS X, `make' (or `make in-place') creates a build in +the "racket" directory. + +The build includes (via links) all packages that are in the "pkgs" +directory. + + Building Racket =============== @@ -9,16 +19,23 @@ Racket distribution. On Unix and Mac OS X, you can build Racket plus the included packages with `make in-place' (or just `make'). The resulting build is in the -"racket" subdirectory. For now, you need to have `git' installed for +"racket" subdirectory. For now, you need to have `git' installed for downloading native-library packages. If you want more control over the process, see below. On Windows, you must first clone "git://github.com/plt/libs.git" -as "build/native-pkgs". Then, you can use `nmake win32-in-place'. +as "build/native-pkgs". Then, you can use `nmake win32-in-place', +as long as you're using Microsoft Visual Studio 9.0 (2008). +Building Racket Pieces +====================== + +Instead of just using `make in-place', you can take more control over +the build. + Building Core Racket -==================== +-------------------- Instead of using the top-level makefile, you can go into "racket/src" and follow the "README" there, which gives you more configuration @@ -28,9 +45,13 @@ If you don't want any special configuration and you just want the core build, you can use `make core' (or `nmake win32-core') with the top-level makefile. +(The Racket core does not require additional native libraries to run, +but under Windows, encoding-conversion, extflonum, and SSL +functionality is hobbled until native libraries from the +`racket-win32-i386' or `racket-win32-x86_64' package are installed.) Installing Packages -=================== +------------------- In the near future, after you've built the core, you can install packages via a package-catalog server (ignoring the content of @@ -38,7 +59,7 @@ packages via a package-catalog server (ignoring the content of Linking Packages for Development Mode -===================================== +------------------------------------- Aside from the issue of native-library packages, using all of the packages in "pkgs" corresponds to a build that is like the main Racket @@ -49,10 +70,11 @@ reinstalling packages). The `pkg-links' target of the makefile links (or re-links) packages from "pkgs" into the "racket" build. (The `in-place' target of the -makefile uses `pkg-links'.) Packages are linked using installation -scope, so that the links affect only the build in the "racket" -directory. Use the `pkg-links' target whenever the set of native -packages or packages in "pkgs" changes. Packages are linked with the +makefile uses `pkg-links'.) Make the `pkg-links' target whenever the +set of native packages or packages in "pkgs" changes. + +Packages are linked using installation scope, so that the links affect +only the build in the "racket" directory. Packages are linked with the `--no-setup' flag (effectively), which means that a `raco setup' is needed after installing links. @@ -71,25 +93,8 @@ as When you have a "build/native-pkgs" directory, then the `pkg-links' makefile target also links relavant native packages. -You need a "racket" build before linking packages. So, to get set up: - - git clone git://github.com/mflatt/racket.git plt - cd plt - git checkout pkg - - make core - - # Mac OS X: - make native-from-git - # Windows: - git clone git://github.com/plt/libs.git build/native-pkgs - - make pkg-links - racket/bin/raco setup - - Trying Packages Locally -======================= +----------------------- Suppose that you've built core "racket" and you want to see what it looks like to install individual packages. @@ -116,11 +121,6 @@ To remove the package, try The `--auto' flag undoes automatic installs from `--deps search-auto'. -If you try out packages in this way, clean out all package -installations before trying to create installers (as described in the -next section), because the distribution-bundle process expects a core -build in "racket" that has no installed packages. - Building Installers =================== @@ -134,6 +134,47 @@ machines, each of which contacts the server machine to obtain pre-built packages. The server can act as a client, naturally, to create an installer for the server's platform. +Running Build Farms +------------------- + +The `farm' target of the makefile will do everything to generate +installers: build a server on the current machine, run clients on +hosts specified via FARM_CONFIG, and start/stop VirtualBox virtual +machines that implement clients. + +See + + pkgs/distro-build/drive-clients.rkt + +for a description of the farm-configuration file and requirements on +client hosts. + +If "my-farm-config.rktd" is a configuration file, then + + make farm FARM_CONFIG=my-farm-config.rktd PKGS="..." + +drives the build farm, and the resulting installers are in +"build/installers". + +The default FARM_CONFIG path is "build/farm-config.rktd", so you could +put your configuration file there and omit the `FARM_CONFIG' argument +to `make'. Similarly, you can omit `PKGS' to use the default specified +in the Makefile. + +A configuration file can specify the packages to include, host address +of the server, distribution name, and installer directory, but default +can be provided as `make' arguments via `PKGS', `SERVER', `DIST_NAME' +and `DIST_DIR', respectively. Note that a sets of packages specified +in a configure file affects the clients, but it does not affect the +packages prepared by the server; only `PKGS' affects the server (and +the client's packages must be a subset of the server's packages). + +Separate Server and Clients +--------------------------- + +Instead of using the `farm' makefile target and a farm configuration +file, you can run server and client processes manually. + Roughly, the steps are 1. On the server machine: @@ -147,6 +188,13 @@ Roughly, the steps are Add `RELEASE_MODE=--release' to the `client' line to build a "release" installer, as opposed to a snapshot installer. + Add `DIST_NAME="..."' to the `client' line to give an installer a + different human-readable distribution name, instead of "Racket". + + Add `DIST_DIR="..."' to the `client' line to make the installer + use a different directory name on installation, instead of + "racket". + In more detail: 1a. Build "racket" on a server. @@ -191,13 +239,25 @@ In more detail: Alternatively, use the `client' target, which combines `core' and `client-from-core' (i.e., steps 2a and 2b). - To create a release installer, provide `RELEASE_MODE' as - "--release". A release installer has slightly different defaults - that are suitable for infrequently updated release installations, - as opposed to ferquently updated snapshot installations. - On Windows, you need NSIS installed, either in the usual location or with `makensis' in your command-line path. + To create a release installer, provide `RELEASE_MODE' as + "--release" to `make'. A release installer has slightly different + defaults that are suitable for infrequently updated release + installations, as opposed to ferquently updated snapshot + installations. + + To change the human-readable name of the distribution as embedded + in the installer, provide `DIST_NAME' to `make'. The default + distribution name is "Racket". Whatever name you pick, the Racket + version number is automatically added for various contexts. + + To change the directory name for Unix installation, as well as + the base name of the installer file for all platforms, provide + `DIST_DIR' to `make'. The default is "racket". + On each client, step 2b produces a "bundle/installer.txt" file that -contains the path to the generated installer. +contains the path to the generated installer, but the installer is +also uploaded to the server, which leaves the installer in a +"build/installers" directory. diff --git a/Makefile b/Makefile index 07f8995d6d..050c1e3945 100644 --- a/Makefile +++ b/Makefile @@ -16,14 +16,6 @@ # # client = build core, create an installer with $(PKGS) with the help # of $(SERVER); result is recorded in "bundle/installer.txt" -# -# Some smaller steps: -# -# server-from-core = the part of `server' after the core is built, -# which is useful if you want to run `configure', -# etc., manually -# -# client-from-core = the part of `client' after the core is built # ------------------------------------------------------------ # In-place build @@ -84,6 +76,13 @@ RELEASE_MODE = DIST_NAME = Racket DIST_DIR = racket +# Configuration of clients to run for a build farm: +FARM_CONFIG = build/farm-config.rktd + +# A command to run after the server has started; normally set by +# the `farm' target: +SERVE_DURING_CMD = + # ------------------------------------------------------------ # Helpers @@ -136,7 +135,6 @@ server-from-core: build-from-local: $(MAKE) local-catalog $(MAKE) local-build - $(MAKE) packages-from-local # Set up a local catalog (useful on its own): local-catalog: @@ -195,7 +193,7 @@ built-catalog: # Run a catalog server to provide pre-built packages, as well # as the copy of the server's "collects" tree: built-catalog-server: - $(RACKET) -l distro-build/serve-catalog + $(RACKET) -l distro-build/serve-catalog $(SERVE_DURING_CMD) # Demonstrate how a catalog server for binary packages works, # which involves creating package archives in "binary" mode @@ -207,12 +205,18 @@ binary-catalog-server: # ------------------------------------------------------------ # On each supported platform: +# +# The `client' and `win32-client' targets are also used by +# `distro-buid/drive-clients', which is in turn run by the +# `farm' target. +# +# For a non-Windows machine, if "build/drive" exists, then +# keep the "build/user" directory on the grounds that the +# client is the same as the server. client: + if [ ! -d build/drive ] ; then rm -rf build/user ; fi $(MAKE) core - $(MAKE) client-from-core - -client-from-core: $(MAKE) distro-build-from-server $(MAKE) bundle-from-server $(MAKE) installer-from-bundle @@ -220,10 +224,8 @@ client-from-core: COPY_ARGS = SERVER=$(SERVER) PKGS="$(PKGS)" RELEASE_MODE=$(RELEASE_MODE) DIST_NAME="$(DIST_NAME)" DIST_DIR=$(DIST_DIR) win32-client: + IF EXIST build\user cmd /c rmdir /S /Q build\user $(MAKE) win32-core $(COPY_ARGS) - $(MAKE) win32-client-from-core $(COPY_ARGS) - -win32-client-from-core: $(MAKE) win32-distro-build-from-server $(COPY_ARGS) $(MAKE) win32-bundle-from-server $(COPY_ARGS) $(MAKE) win32-installer-from-bundle $(COPY_ARGS) @@ -244,10 +246,12 @@ bundle-from-server: $(RACKET) -l distro-build/unpack-collects http://$(SERVER):9440/ bundle/racket/bin/raco pkg install $(REMOTE_INST_AUTO) $(PKGS) $(REQUIRED_PKGS) +UPLOAD = --upload http://$(SERVER):9440/ + # Create an installer from the build (with installed packages) that's # in "bundle/racket": installer-from-bundle: - $(RACKET) -l distro-build/installer $(RELEASE_MODE) "$(DIST_NAME)" $(DIST_DIR) + $(RACKET) -l- distro-build/installer $(UPLOAD) $(RELEASE_MODE) "$(DIST_NAME)" $(DIST_DIR) win32-distro-build-from-server: $(WIN32_RACO) pkg install $(REMOTE_USER_AUTO) distro-build @@ -266,4 +270,22 @@ win32-bundle-from-server: bundle\racket\raco pkg install $(REMOTE_INST_AUTO) $(PKGS) win32-installer-from-bundle: - $(WIN32_RACKET) -l distro-build/installer $(RELEASE_MODE) "$(DIST_NAME)" $(DIST_DIR) + $(WIN32_RACKET) -l- distro-build/installer $(UPLOAD) $(RELEASE_MODE) "$(DIST_NAME)" $(DIST_DIR) + +# ------------------------------------------------------------ +# On each supported platform: + +DRIVE_ARGS = $(RELEASE_MODE) "$(FARM_CONFIG)" $(SERVER) "$(PKGS)" "$(DIST_NAME)" $(DIST_DIR) +DRIVE_CMD = $(RACKET) -l- distro-build/drive-clients $(DRIVE_ARGS) + +# Full server build and clients drive, based on `FARM_CONFIG': +farm: + $(MAKE) server SERVE_DURING_CMD="$(DRIVE_CMD)" + +# Server is already built; start it and drive clients: +built-farm: + $(MAKE) built-catalog-server SERVE_DURING_CMD="$(DRIVE_CMD)" + +# Just the clients, assuming server is already running: +drive-clients: + $(DRIVE_CMD) diff --git a/pkgs/distro-build/drive-clients.rkt b/pkgs/distro-build/drive-clients.rkt new file mode 100644 index 0000000000..2a3aba048f --- /dev/null +++ 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 +;; grammar: +;; +;; = (machine ... ...) +;; | ( ... ... ...) +;; +;; = parallel | sequential +;; +;; Normally, a configuration file start with "( ...)", since +;; the configuration otherwise specifies only one client machine. +;; +;; A ` ... ...' 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 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 means no spaces, etc.): +;; +;; #:pkgs ( ...) --- packages to install; defaults to +;; the `pkgs' command-line argument +;; #:server --- the address of the server from the client; +;; defaults to `server' command-line argument +;; #:dist-name --- the distribution name; defaults to the +;; `dist-name' command-line argument +;; #:dist-dir --- the distribution's installation directory; +;; defaults to `dist-dir' command-line argument +;; #:max-vm --- max number of VMs allowed to run with this +;; machine, counting the machine; defaults to 1 +;; #:port --- ssh port for the client; defaults to 22 +;; #:user --- ssh user for the client; defaults to current user +;; #:dir --- defaults to "build/plt" or "build\\plt" +;; #:vbox --- Virtual Box machine name; if provided the +;; virtual machine is started and stopped as needed +;; #:platform --- 'windows or 'unix, defaults to 'unix +;; #:bits --- 32 or 64, affects Visual Studio path +;; #:vc --- "x86" or "x64" to select the Visual C build mode; +;; default depends on bits +;; #:j --- parallelism for `make' on Unix and Mac OS X; +;; defaults to 1 +;; #:timeout --- numbers of seconds to wait before declaring +;; failure; defaults to 30 minutes +;; #:repo --- the git repository for Racket; defaults to +;; "git://github.com/plt/racket.git" +;; +;; Machine-only keywords: +;; #:name --- defaults to host +;; #:host --- 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 index 1c45e4de95..e6066b9951 100644 --- 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 index c3a6b03973..5135b7e362 100644 --- 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 subdirectory" - (set! from-dir dir)] - #:args () - (void)) +(define during-cmd-line + (command-line + #:once-each + [("--mode") dir "Serve package archives from 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])) -(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) +(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)) + +(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))))