commit cb01a4af0f1062a21890970410d33f8525491f25
parent eb48ea6e1f5354d6b94fef6a53cf7201c72a85cd
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 1 Jul 2013 06:57:13 -0600
change farm-configuration file to a module
Also, improve connection between installers and farm-configuration
entries, and improve configuration of installer name versus
target-install directory.
original commit: 29b9a22d87a7567a851f28d0381267611ee8a48f
Diffstat:
7 files changed, 400 insertions(+), 233 deletions(-)
diff --git a/pkgs/distro-build/drive-clients.rkt b/pkgs/distro-build/drive-clients.rkt
@@ -1,245 +1,57 @@
#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
-;; #:dist-suffix <string*> --- a suffix for the installer's name, usually
-;; used for an OS variant; defaults to ""
-;; #: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
-;; #:configure (<string> ...) --- arguments to `configure'
-;; #: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
-;; "http://<server>:9440/.git"
-;; #:clean? <boolean> --- override default cleaning mode
-;;
-;; 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)
+ racket/string
+ (only-in "farm.rkt"
+ current-mode
+ farm-config?
+ farm-config-tag farm-config-options farm-config-content))
+
+;; See "farm.rkt" for an overview.
;; ----------------------------------------
(define release? #f)
(define default-clean? #f)
-(define-values (config-file default-server default-pkgs default-dist-name default-dist-dir)
+(define-values (config-file config-mode
+ default-server default-pkgs
+ default-dist-name default-dist-base default-dist-dir)
(command-line
#:once-each
[("--release") "Create release-mode installers"
(set! release? #t)]
[("--clean") "Erase client directories before building"
(set! default-clean? #t)]
- #:args (config-file server pkgs dist-name dist-dir)
- (values config-file server pkgs dist-name dist-dir)))
+ #:args (config-file config-mode
+ server pkgs
+ dist-name dist-base dist-dir)
+ (values config-file config-mode
+ server pkgs
+ dist-name dist-base 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)]
- [(#:dist-suffix) (simple-string? val)]
- [(#:max-vm) (real? val)]
- [(#:server) (simple-string? val)]
- [(#:host) (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))]
- [(#:configure) (and (list? val) (andmap string? val))]
- [(#: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)]
- [(#:clean?) (boolean? val)]
- [else #f]))
-
-(define (check-machine-keyword kw val)
- (case kw
- [(#:name) (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))])))
+(define config (parameterize ([current-mode config-mode])
+ (dynamic-require (path->complete-path config-file) 'farm-config)))
-(check-config config)
+(unless (farm-config? config)
+ (error 'drive-clients
+ "configuration module did not provide a farm-configuration value: ~e"
+ 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])))
+ (for/fold ([opts opts]) ([(k v) (in-hash (farm-config-options c))])
+ (hash-set opts k v)))
(define (get-opt opts kw [default #f])
(hash-ref opts kw default))
(define (get-content c)
- (let loop ([c (cdr c)])
- (if (and (pair? c)
- (keyword? (car c)))
- (loop (cddr c))
- c)))
+ (farm-config-content c))
(define (client-name opts)
(or (get-opt opts '#:name)
@@ -356,16 +168,18 @@
(define (q s)
(~a "\"" s "\""))
-(define (client-args server pkgs dist-name dist-dir dist-suffix)
+(define (client-args desc server pkgs dist-name dist-base dist-dir dist-suffix)
(~a " SERVER=" server
" PKGS=" (q pkgs)
+ " DIST_DESC=" (q desc)
" DIST_NAME=" (q dist-name)
+ " DIST_BASE=" dist-base
" DIST_DIR=" dist-dir
" DIST_SUFFIX=" (q dist-suffix)
" RELEASE_MODE=" (if release? "--release" (q ""))))
(define (unix-build c host port user server repo clean?
- pkgs dist-name dist-dir dist-suffix)
+ pkgs dist-name dist-base dist-dir dist-suffix)
(define dir (or (get-opt c '#:dir)
"build/plt"))
(define (sh . args)
@@ -382,12 +196,14 @@
"git pull")
(sh "cd " (q dir) " ; "
"make -j " j " client"
- (client-args server pkgs dist-name dist-dir dist-suffix)
+ (client-args (client-name c)
+ server pkgs
+ dist-name dist-base dist-dir dist-suffix)
" CORE_CONFIGURE_ARGS=" (q (apply ~a #:separator " "
(get-opt c '#:configure null))))))
(define (windows-build c host port user server repo clean?
- pkgs dist-name dist-dir dist-suffix)
+ pkgs dist-name dist-base dist-dir dist-suffix)
(define dir (or (get-opt c '#:dir)
"build\\plt"))
(define bits (or (get-opt c '#:bits) 64))
@@ -407,7 +223,10 @@
(cmd "cd " (q dir)
" && \"c:\\Program Files" (if (= bits 64) " (x86)" "") "\\Microsoft Visual Studio 9.0\\vc\\vcvarsall.bat\""
" " vc
- " && nmake win32-client" (client-args server pkgs dist-name dist-dir dist-suffix))))
+ " && nmake win32-client"
+ (client-args (client-name c)
+ server pkgs
+ dist-name dist-base dist-dir dist-suffix))))
(define (client-build c)
(define host (or (get-opt c '#:host)
@@ -421,6 +240,8 @@
default-pkgs))
(define dist-name (or (get-opt c '#:dist-name)
default-dist-name))
+ (define dist-base (or (get-opt c '#:dist-base)
+ default-dist-base))
(define dist-dir (or (get-opt c '#:dist-dir)
default-dist-dir))
(define dist-suffix (get-opt c '#:dist-suffix ""))
@@ -434,7 +255,7 @@
[(unix) unix-build]
[else windows-build])
c host port user server repo clean?
- pkgs dist-name dist-dir dist-suffix))
+ pkgs dist-name dist-base dist-dir dist-suffix))
;; ----------------------------------------
@@ -479,7 +300,7 @@
(let loop ([config config]
[mode 'sequential]
[opts (hasheq)])
- (case (car config)
+ (case (farm-config-tag config)
[(parallel sequential)
(define new-opts (merge-options opts config))
(define ts
diff --git a/pkgs/distro-build/farm.rkt b/pkgs/distro-build/farm.rkt
@@ -0,0 +1,313 @@
+#lang racket/base
+
+;; A build farm is normally run via the `farm' target of the Racket
+;; repository's top-level makefile. That target, in turn, uses the
+;; `distro-build/drive-clients' module.
+;;
+;; 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. The directory defaults to "build/plt" (Unix,
+;; Mac OS X) or "build\\plt" (Windows). If the directory exists
+;; already on a client machine (and the machine is not configured for
+;; "clean" mode), then the directory is assumed to be a suitable git
+;; clone, and it is updated with `git pull'. Otherwise, a git
+;; repository is cloned; by default, the server is used as the source
+;; git repository (so that the server and client are in sync).
+;;
+;; 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) as recorded in the "table.rktd" file.
+;;
+;; 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 module is normally wriiten in the
+;; `distro-build/farm' language. The configuration describes
+;; individual machines, and groups them with `parallel' or
+;; `sequential' to indicate whether the machine's builds should run
+;; sequentially or in parallel. Options specified at `parallel' or
+;; `sequential' are propagated to eachmachine in the group.
+;;
+;; For example, a configuration module might look like this:
+;;
+;; #lang distro-build/farm
+;;
+;; (sequential
+;; #:server "192.168.56.1"
+;; (machine
+;; #:desc "Linux (32-bit, Precise Pangolin)"
+;; #:name "Ubuntu 32"
+;; #:vbox "Ubuntu 12.04"
+;; #:host "192.168.56.102")
+;; (machine
+;; #:desc "Windows (64-bit)"
+;; #:name "Windows 64"
+;; #:vbox "Windows 7"
+;; #:host "192.168.56.103"
+;; #:port 2022
+;; #:dir "c:\\Users\\mflatt\\build\\plt"
+;; #:platform 'windows
+;; #:bits 64))
+;;
+;;
+;; Farm-configuration keywords (where <string*> means no spaces, etc.):
+;;
+;; #:host <string*> --- defaults to "localhost"
+;; #: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"
+;; #:server <string*> --- the address of the server as accessed by the
+;; client; defaults to the `server' command-line
+;; argument
+;; #:repo <string> --- the git repository for Racket; defaults to
+;; "http://<server>:9440/.git"
+;; #:pkgs '(<string*> ...) --- packages to install; defaults to
+;; `PKGS' in the makfile (or, more genereally,
+;; the `pkgs' command-line argument to
+;; `distro-build/drive-clients')
+;; #:dist-name <string> --- the distribution name; defaults to the
+;; `DIST_NAME' makefile variable or `dist-name'
+;; command-line argument
+;; #:dist-base <string*> --- the distribution's installater name prefix;
+;; defaults to the `DIST_BASE' makefile variable
+;; or the `dist-base' command-line argument
+;; #:dist-dir <string*> --- the distribution's installation directory;
+;; defaults to the `DIST_DIR' makefile variable
+;; or the `dist-dir' command-line argument
+;; #:dist-suffix <string*> --- a suffix for the installer's name, usually
+;; used for an OS variant; defaults to the
+;; `DIST_SUFFIX' makefile variable or the
+;; `dist-suffix' command-line argument
+;; #:max-vm <real> --- max number of VMs allowed to run with this
+;; machine, counting the machine; defaults to 1
+;; #: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
+;; #:configure '(<string> ...) --- arguments to `configure'
+;; #: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
+;; #:clean? <boolean> --- if true, then the build process on the client
+;; machine starts by removing <dir>; the default
+;; is #f, but the `--clean' command-line flag
+;; changes the default to #t
+;;
+;; Machine-only keywords:
+;; #:name <string> --- defaults to host; this string is recorded as
+;; a description of the installer (for use in a
+;; generated table of installer links, for example)
+;;
+;;
+;; More precisely, the `distro-build/farm' language is like
+;; `racket/base' except that the module body must have exactly one
+;; expression (plus any number of definitions, etc.) that produces a
+;; farm-configuration value. The value is exported as `farm-config'
+;; from the module. Any module can act as a farm-configuration module
+;; a long as it exports `farm-config' as a farm-configuration value.
+;;
+;; The `distro-build/farm' language also adds the following functions
+;; to `racket/base':
+;;
+;; (machine <opt-kw> <opt-val> ... ...) -> farm-config?
+;; Produces a farm configuration based on the given keyword-based
+;; options. The support keyword arguments are described above.
+;;
+;; (sequential <opt-kw> <opt-val> ... ... config ...)
+;; -> farm-config?
+;; config : farm-config?
+;; Produces a farm configuration that runs each `config'
+;; sequentially. The support keyword arguments are described above.
+;;
+;; (parallel <opt-kw> <opt-val> ... ... config ...)
+;; -> farm-config?
+;; config : farm-config?
+;; Produces a farm configuration that runs each `config' in
+;; parallel. The support keyword arguments are described above.
+;;
+;; (farm-config? v) -> boolean?
+;; (farm-config-tag config) -> (or/c 'machine 'sequential 'parallel)
+;; config : farm-config?
+;; (farm-config-options config) -> (hash/c keyword? any/c)
+;; config : farm-config?
+;; (farm-config-content config) -> (listof farm-config?)
+;; config : farm-config?
+;; Farm configuation inspection
+;;
+;; (current-mode) -> string?
+;; (current-mode s) -> void?
+;; s : string?
+;; A parameter whose value is the user's requested mode for this
+;; configuration. The default mode is "default". The interpretation
+;; of modes is completely up to the farm-configuration file.
+
+;; ----------------------------------------
+
+(require racket/format
+ (for-syntax syntax/kerncase
+ racket/base))
+
+(provide (except-out (all-from-out racket/base)
+ #%module-begin)
+ (rename-out [module-begin #%module-begin])
+ sequential
+ parallel
+ machine
+ farm-config?
+ farm-config-tag
+ farm-config-options
+ farm-config-content
+ current-mode)
+
+(module reader syntax/module-reader
+ distro-build/farm)
+
+(struct farm-config (tag options content))
+
+(define-syntax-rule (module-begin form ...)
+ (#%plain-module-begin (farm-begin #f form ...)))
+
+(define-syntax (farm-begin stx)
+ (syntax-case stx ()
+ [(_ #t) #'(begin)]
+ [(_ #f)
+ (raise-syntax-error 'farm
+ "did not find an expression for the farm configuration")]
+ [(_ found? next . rest)
+ (let ([expanded (local-expand #'next 'module (kernel-form-identifier-list))])
+ (syntax-case expanded (begin)
+ [(begin next1 ...)
+ #`(farm-begin found? next1 ... . rest)]
+ [(id . _)
+ (and (identifier? #'id)
+ (ormap (lambda (kw) (free-identifier=? #'id kw))
+ (syntax->list #'(require
+ provide
+ define-values
+ define-syntaxes
+ begin-for-syntax
+ module
+ module*
+ #%require
+ #%provide))))
+ #`(begin #,expanded (farm-begin found? . rest))]
+ [_else
+ (if (syntax-e #'found?)
+ (raise-syntax-error 'farm
+ "found second top-level expression"
+ #'next)
+ #`(begin
+ (provide farm-config)
+ (define farm-config (let ([v #,expanded])
+ (unless (farm-config? v)
+ (error 'farm
+ (~a "expression did not produce a farm configuration\n"
+ " result: ~e\n"
+ " expression: ~.s")
+ v
+ 'next))
+ v))
+ (farm-begin
+ #t
+ . rest)))]))]))
+
+(define sequential
+ (make-keyword-procedure
+ (lambda (kws kw-vals . subs)
+ (constructor kws kw-vals subs
+ check-group-keyword 'sequential))))
+(define parallel
+ (make-keyword-procedure
+ (lambda (kws kw-vals . subs)
+ (constructor kws kw-vals subs
+ check-group-keyword 'sequential))))
+(define machine
+ (make-keyword-procedure
+ (lambda (kws kw-vals)
+ (constructor kws kw-vals null
+ check-machine-keyword 'machine))))
+
+(define (constructor kws kw-vals subs check tag)
+ (farm-config
+ tag
+ (for/hash ([kw (in-list kws)]
+ [val (in-list kw-vals)])
+ (unless (check kw val)
+ (error tag
+ (~a "bad value for keyword\n"
+ " keyword: ~s"
+ " value: ~e")
+ kw
+ val))
+ (values kw val))
+ (for/list ([sub subs])
+ (unless (farm-config? sub)
+ (raise-argument-error tag "farm-config?" sub))
+ sub)))
+
+(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)]
+ [(#:dist-suffix) (simple-string? val)]
+ [(#:max-vm) (real? val)]
+ [(#:server) (simple-string? val)]
+ [(#:host) (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))]
+ [(#:configure) (and (list? val) (andmap string? val))]
+ [(#: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)]
+ [(#:clean?) (boolean? val)]
+ [else #f]))
+
+(define (check-machine-keyword kw val)
+ (case kw
+ [(#:name) (string? val)]
+ [else (check-group-keyword kw val)]))
+
+(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 current-mode (make-parameter "default"))
diff --git a/pkgs/distro-build/installer-dmg.rkt b/pkgs/distro-build/installer-dmg.rkt
@@ -108,9 +108,9 @@
(system*/show hdiutil "detach" mnt)
(delete-directory mnt))
-(define (installer-dmg human-name dir-name dist-suffix)
+(define (installer-dmg human-name base-name dist-suffix)
(define dmg-name (format "bundle/~a-~a~a.dmg"
- dir-name
+ base-name
(system-library-subpath #f)
dist-suffix))
(make-dmg human-name "bundle/racket" dmg-name bg-image)
diff --git a/pkgs/distro-build/installer-exe.rkt b/pkgs/distro-build/installer-exe.rkt
@@ -397,14 +397,14 @@ SectionEnd
(parameterize ([current-directory "bundle"])
(system* makensis "/V3" "installer.nsi")))
-(define (installer-exe human-name dir-name release? dist-suffix)
+(define (installer-exe human-name base-name release? dist-suffix)
(define makensis (or (find-executable-path "makensis.exe")
(try-exe "c:\\Program Files\\NSIS\\makensis.exe")
(try-exe "c:\\Program Files (x86)\\NSIS\\makensis.exe")
(error 'installer-exe "cannot find \"makensis.exe\"")))
(define platform (let-values ([(base name dir?) (split-path (system-library-subpath #f))])
(path->string name)))
- (define exe-path (format "bundle/~a-~a-win32~a.exe" dir-name platform dist-suffix))
+ (define exe-path (format "bundle/~a-~a-win32~a.exe" base-name platform dist-suffix))
(nsis-generate exe-path
human-name
(version)
diff --git a/pkgs/distro-build/installer-sh.rkt b/pkgs/distro-build/installer-sh.rkt
@@ -69,9 +69,9 @@
(system/show "chmod" "+x" dest)
(delete-file tmp-tgz))
-(define (installer-sh human-name dir-name release? dist-suffix)
+(define (installer-sh human-name base-name dir-name release? dist-suffix)
(define sh-path (format "bundle/~a-~a~a.sh"
- dir-name
+ base-name
(system-library-subpath #f)
dist-suffix))
(generate-installer-sh "bundle/racket" sh-path
diff --git a/pkgs/distro-build/installer.rkt b/pkgs/distro-build/installer.rkt
@@ -9,18 +9,22 @@
(define release? #f)
(define upload-to #f)
+(define upload-desc "")
-(define-values (short-human-name human-name dir-name dist-suffix)
+(define-values (short-human-name human-name base-name dir-name dist-suffix)
(command-line
#:once-each
[("--release") "Create a release installer"
(set! release? #t)]
[("--upload") url "Upload installer"
(set! upload-to url)]
+ [("--desc") desc "Description to accompany upload"
+ (set! upload-desc desc)]
#:args
- (human-name dir-name dist-suffix)
+ (human-name base-name dir-name dist-suffix)
(values human-name
(format "~a v~a" human-name (version))
+ (format "~a-~a" base-name (version))
(if release?
dir-name
(format "~a-~a" dir-name (version)))
@@ -30,14 +34,16 @@
(define installer-file
(case (system-type)
- [(unix) (installer-sh human-name dir-name release? dist-suffix)]
- [(macosx) (installer-dmg human-name dir-name dist-suffix)]
- [(windows) (installer-exe short-human-name dir-name release? dist-suffix)]))
+ [(unix) (installer-sh human-name base-name dir-name release? dist-suffix)]
+ [(macosx) (installer-dmg human-name base-name dist-suffix)]
+ [(windows) (installer-exe short-human-name base-name release? dist-suffix)]))
(call-with-output-file*
(build-path "bundle" "installer.txt")
#:exists 'truncate/replace
- (lambda (o) (fprintf o "~a\n" installer-file)))
+ (lambda (o)
+ (fprintf o "~a\n" installer-file)
+ (fprintf o "~a\n" upload-desc)))
(when upload-to
(printf "Upload ~a to ~a\n" installer-file upload-to)
@@ -46,6 +52,7 @@
(string->url (format "~aupload/~a"
upload-to
(path->string (file-name-from-path installer-file))))
- (file->bytes installer-file)))
+ (file->bytes installer-file)
+ (list (string-append "Description: " upload-desc))))
(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
@@ -68,6 +68,27 @@
(define (write-info req pkg-name)
(response/sexpr (pkg-name->info req pkg-name)))
+(define (record-installer dir filename desc)
+ (when desc
+ (define table-file (build-path dir "table.rktd"))
+ (call-with-file-lock/timeout
+ #:max-delay 2
+ table-file
+ 'exclusive
+ (lambda ()
+ (define t (hash-set
+ (if (file-exists? table-file)
+ (call-with-input-file* table-file read)
+ (hash))
+ desc
+ filename))
+ (call-with-output-file table-file
+ #:exists 'truncate/replace
+ (lambda (o)
+ (write t o)
+ (newline o))))
+ void)))
+
(define (receive-file req filename)
(unless (relative-path? filename)
(error "upload path name must be relative"))
@@ -77,6 +98,11 @@
#:exists 'truncate/replace
(lambda (o)
(write-bytes (request-post-data/raw req) o)))
+ (define desc
+ (for/or ([h (in-list (request-headers/raw req))])
+ (and (equal? (header-field h) #"Description")
+ (bytes->string/utf-8 (header-value h)))))
+ (record-installer dir filename desc)
(response/sexpr #t))
(define-values (dispatch main-url)
