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.
This commit is contained in:
Matthew Flatt
parent
314eee0804
commit
4e23a52f01
136
INSTALL.txt
136
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.
|
||||
|
|
|
|||
58
Makefile
58
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)
|
||||
|
|
|
|||
490
pkgs/distro-build/drive-clients.rkt
Normal file
490
pkgs/distro-build/drive-clients.rkt
Normal file
|
|
@ -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)))))])))
|
||||
|
|
@ -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")))
|
||||
|
|
|
|||
|
|
@ -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]))
|
||||
|
||||
(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))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user