575 lines
21 KiB
Racket
575 lines
21 KiB
Racket
#lang racket/base
|
|
(require racket/cmdline
|
|
racket/system
|
|
racket/port
|
|
racket/format
|
|
racket/file
|
|
racket/string
|
|
racket/path
|
|
net/base64
|
|
(only-in distro-build/config
|
|
current-mode
|
|
site-config?
|
|
site-config-tag site-config-options site-config-content
|
|
current-stamp)
|
|
distro-build/url-options
|
|
distro-build/display-time
|
|
distro-build/readme
|
|
remote-shell/vbox
|
|
"email.rkt")
|
|
|
|
;; See "config.rkt" for an overview.
|
|
|
|
(module test racket/base)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define default-release? #f)
|
|
(define default-source? #f)
|
|
(define default-versionless? #f)
|
|
(define default-clean? #f)
|
|
(define dry-run #f)
|
|
|
|
(define snapshot-install-name "snapshot")
|
|
|
|
(define-values (config-file config-mode
|
|
default-server default-server-port default-server-hosts
|
|
default-pkgs default-doc-search
|
|
default-dist-name default-dist-base default-dist-dir)
|
|
(command-line
|
|
#:once-each
|
|
[("--release") "Create release-mode installers"
|
|
(set! default-release? #t)]
|
|
[("--source") "Create source installers"
|
|
(set! default-source? #t)]
|
|
[("--versionless") "Avoid version number in names and paths"
|
|
(set! default-versionless? #t)]
|
|
[("--clean") "Erase client directories before building"
|
|
(set! default-clean? #t)]
|
|
[("--dry-run") mode
|
|
("Don't actually use the clients;"
|
|
" <mode> can be `ok', `fail', `error', `stuck', or `frozen'")
|
|
(unless (member mode '("ok" "fail" "error" "stuck" "frozen"))
|
|
(raise-user-error 'drive-clients "bad dry-run mode: ~a" mode))
|
|
(set! dry-run (string->symbol mode))]
|
|
#:args (config-file config-mode
|
|
server server-port server-hosts pkgs doc-search
|
|
dist-name dist-base dist-dir)
|
|
(values config-file config-mode
|
|
server server-port server-hosts pkgs doc-search
|
|
dist-name dist-base dist-dir)))
|
|
|
|
(define config (parameterize ([current-mode config-mode])
|
|
(dynamic-require (path->complete-path config-file) 'site-config)))
|
|
|
|
(unless (site-config? config)
|
|
(error 'drive-clients
|
|
"configuration module did not provide a site-configuration value: ~e"
|
|
config))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (merge-options opts c)
|
|
(for/fold ([opts opts]) ([(k v) (in-hash (site-config-options c))])
|
|
(if (eq? k '#:custom)
|
|
(hash-set opts
|
|
'#:custom
|
|
(let ([prev (hash-ref opts '#:custom (hash))])
|
|
(for/fold ([prev prev]) ([(k2 v2) (in-hash v)])
|
|
(hash-set prev k2 v2))))
|
|
(hash-set opts k v))))
|
|
|
|
(define (get-opt opts kw [default #f] #:localhost [localhost-default default])
|
|
(hash-ref opts kw (lambda ()
|
|
(cond
|
|
[(equal? default localhost-default) default]
|
|
[(and (equal? "localhost" (get-opt opts '#:host "localhost"))
|
|
(equal? #f (get-opt opts '#:user #f))
|
|
(equal? #f (get-opt opts '#:dir #f)))
|
|
localhost-default]
|
|
[else default]))))
|
|
|
|
(define (get-content c)
|
|
(site-config-content c))
|
|
|
|
(define (client-name opts)
|
|
(or (get-opt opts '#:name)
|
|
(get-opt opts '#:host)
|
|
"localhost"))
|
|
|
|
(define (get-path-opt opt key default #:localhost [localhost-default default])
|
|
(define d (get-opt opt key default #:localhost localhost-default))
|
|
(if (path? d)
|
|
(path->string d)
|
|
d))
|
|
|
|
(define (add-defaults c . l)
|
|
(let loop ([c c] [l l])
|
|
(cond
|
|
[(null? l) c]
|
|
[else (loop (hash-set c (car l)
|
|
(hash-ref c (car l) (lambda () (cadr l))))
|
|
(cddr l))])))
|
|
|
|
;; ----------------------------------------
|
|
;; Managing VirtualBox machines
|
|
|
|
(define (start-client c max-vm)
|
|
(define vbox (get-opt c '#:vbox))
|
|
(when vbox
|
|
(start-vbox-vm vbox
|
|
#:max-vms max-vm
|
|
#:dry-run? dry-run)))
|
|
|
|
(define (stop-client c)
|
|
(define vbox (get-opt c '#:vbox))
|
|
(when vbox
|
|
(stop-vbox-vm vbox)))
|
|
|
|
(define (try-until-ready c host port user server-port kind cmd)
|
|
(when (get-opt c '#:vbox)
|
|
;; A VM may take a little while to get networking set up and
|
|
;; respond, so give a dummy `cmd` a few tries
|
|
(let loop ([tries 3])
|
|
(unless (ssh-script host port user server-port kind cmd)
|
|
(sleep 1)
|
|
(loop (sub1 tries))))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define scp (find-executable-path "scp"))
|
|
(define ssh (find-executable-path "ssh"))
|
|
|
|
(define (system*/show exe . args)
|
|
(displayln (apply ~a #:separator " "
|
|
(map (lambda (p) (if (path? p) (path->string p) p))
|
|
(cons exe args))))
|
|
(flush-output)
|
|
(case dry-run
|
|
[(ok) #t]
|
|
[(fail) #f]
|
|
[(error) (error "error")]
|
|
[(stuck) (semaphore-wait (make-semaphore))]
|
|
[(frozen) (break-enabled #f) (semaphore-wait (make-semaphore))]
|
|
[else
|
|
(apply system* exe args)]))
|
|
|
|
(define (ssh-script host port user server-port kind . cmds)
|
|
(for/and ([cmd (in-list cmds)])
|
|
(when cmd (display-time))
|
|
(or (not cmd)
|
|
(if (and (equal? host "localhost")
|
|
(not user))
|
|
(apply system*/show cmd)
|
|
(apply system*/show ssh
|
|
"-p" (~a port)
|
|
;; create tunnel to connect back to server:
|
|
"-R" (~a server-port ":localhost:" server-port)
|
|
(if user
|
|
(~a user "@" host)
|
|
host)
|
|
(if (eq? kind 'unix)
|
|
;; ssh needs an extra level of quoting
|
|
;; relative to sh:
|
|
(for/list ([arg (in-list cmd)])
|
|
(~a "'"
|
|
(regexp-replace* #rx"'" arg "'\"'\"'")
|
|
"'"))
|
|
;; windows quoting built into `cmd' aready
|
|
cmd))))))
|
|
|
|
(define (q s)
|
|
(~a "\"" s "\""))
|
|
|
|
(define (qq l kind)
|
|
(case kind
|
|
[(unix macosx)
|
|
(~a "'"
|
|
(apply ~a #:separator " " (map q l))
|
|
"'")]
|
|
[(windows windows/bash)
|
|
(~a "\""
|
|
(apply
|
|
~a #:separator " "
|
|
(for/list ([i (in-list l)])
|
|
(~a "\\\""
|
|
i
|
|
;; A backslash is literal unless followed by a
|
|
;; quote. If `i' ends in backslashes, they
|
|
;; must be doubled, because the \" added to
|
|
;; the end will make them treated as escapes.
|
|
(let ([m (regexp-match #rx"\\\\*$" i)])
|
|
(car m))
|
|
"\\\"")))
|
|
"\"")]))
|
|
|
|
(define (shell-protect s kind)
|
|
(case kind
|
|
[(windows/bash)
|
|
;; Protect Windows arguments to go through bash, where
|
|
;; unquoted backslashes must be escaped, but quotes are effectively
|
|
;; preserved by the shell, and quoted backslashes should be left
|
|
;; alone; also, "&&" must be quoted to avoid parsing by bash
|
|
(regexp-replace* "&&"
|
|
(list->string
|
|
;; In practice, the following loop is likely to
|
|
;; do nothing, because constructed command lines
|
|
;; tend to have only quoted backslashes.
|
|
(let loop ([l (string->list s)] [in-quote? #f])
|
|
(cond
|
|
[(null? l) null]
|
|
[(and (equal? #\\ (car l))
|
|
(not in-quote?))
|
|
(list* #\\ #\\ (loop (cdr l) #f))]
|
|
[(and in-quote?
|
|
(equal? #\\ (car l))
|
|
(pair? (cdr l))
|
|
(or (equal? #\" (cadr l))
|
|
(equal? #\\ (cadr l))))
|
|
(list* #\\ (cadr l) (loop (cddr l) #t))]
|
|
[(equal? #\" (car l))
|
|
(cons #\" (loop (cdr l) (not in-quote?)))]
|
|
[else
|
|
(cons (car l) (loop (cdr l) in-quote?))])))
|
|
"\"\\&\\&\"")]
|
|
[else s]))
|
|
|
|
(define (pack-base64-arguments args)
|
|
(bytes->string/utf-8 (base64-encode (string->bytes/utf-8 (format "~s" args))
|
|
#"")))
|
|
|
|
(define (client-args c server server-port kind readme)
|
|
(define desc (client-name c))
|
|
(define pkgs (let ([l (get-opt c '#:pkgs)])
|
|
(if l
|
|
(apply ~a #:separator " " l)
|
|
default-pkgs)))
|
|
(define racket (get-opt c '#:racket))
|
|
(define doc-search (choose-doc-search c default-doc-search))
|
|
(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 ""))
|
|
(define dist-catalogs (choose-catalogs c '("")))
|
|
(define sign-identity (get-opt c '#:sign-identity ""))
|
|
(define osslsigncode-args (get-opt c '#:osslsigncode-args))
|
|
(define release? (get-opt c '#:release? default-release?))
|
|
(define source? (get-opt c '#:source? default-source?))
|
|
(define versionless? (get-opt c '#:versionless? default-versionless?))
|
|
(define source-pkgs? (get-opt c '#:source-pkgs? source?))
|
|
(define source-runtime? (get-opt c '#:source-runtime? source?))
|
|
(define mac-pkg? (get-opt c '#:mac-pkg? #f))
|
|
(define tgz? (get-opt c '#:tgz? #f))
|
|
(define install-name (get-opt c '#:install-name (if release?
|
|
""
|
|
snapshot-install-name)))
|
|
(define build-stamp (get-opt c '#:build-stamp (if release?
|
|
""
|
|
(current-stamp))))
|
|
(~a " SERVER=" server
|
|
" SERVER_PORT=" server-port
|
|
" PKGS=" (q pkgs)
|
|
(if racket
|
|
(~a " PLAIN_RACKET=" (q racket))
|
|
"")
|
|
" DOC_SEARCH=" (q doc-search)
|
|
" DIST_DESC=" (q desc)
|
|
" DIST_NAME=" (q dist-name)
|
|
" DIST_BASE=" dist-base
|
|
" DIST_DIR=" dist-dir
|
|
" DIST_SUFFIX=" (q dist-suffix)
|
|
" DIST_CATALOGS_q=" (qq dist-catalogs kind)
|
|
" SIGN_IDENTITY=" (q sign-identity)
|
|
" OSSLSIGNCODE_ARGS_BASE64=" (q (if osslsigncode-args
|
|
(pack-base64-arguments osslsigncode-args)
|
|
""))
|
|
" INSTALL_NAME=" (q install-name)
|
|
" BUILD_STAMP=" (q build-stamp)
|
|
" RELEASE_MODE=" (if release? "--release" (q ""))
|
|
" SOURCE_MODE=" (if source-runtime? "--source" (q ""))
|
|
" VERSIONLESS_MODE=" (if versionless? "--versionless" (q ""))
|
|
" PKG_SOURCE_MODE=" (if source-pkgs?
|
|
(q "--source --no-setup")
|
|
(q ""))
|
|
" MAC_PKG_MODE=" (if mac-pkg? "--mac-pkg" (q ""))
|
|
" TGZ_MODE=" (if tgz? "--tgz" (q ""))
|
|
" UPLOAD=http://" server ":" server-port "/upload/"
|
|
" README=http://" server ":" server-port "/" (q (file-name-from-path readme))))
|
|
|
|
(define (unix-build c platform host port user server server-port repo clean? pull? readme)
|
|
(define dir (get-path-opt c '#:dir "build/plt" #:localhost (current-directory)))
|
|
(define env (get-opt c '#:env null))
|
|
(define (sh . args)
|
|
(append
|
|
(if (null? env)
|
|
null
|
|
(list* "/usr/bin/env"
|
|
(for/list ([e (in-list env)])
|
|
(format "~a=~a" (car e) (cadr e)))))
|
|
(list "/bin/sh" "-c" (apply ~a args))))
|
|
(define j (or (get-opt c '#:j) 1))
|
|
(define cross-target (get-opt c '#:cross-target))
|
|
(define given-racket (and cross-target
|
|
(get-opt c '#:racket)))
|
|
(define need-native-racket? (and cross-target
|
|
(not given-racket)))
|
|
(define built-native-racket "cross/racket/racket3m") ; relative to build directory
|
|
(try-until-ready c host port user server-port 'unix (sh "echo hello"))
|
|
(ssh-script
|
|
host port user
|
|
server-port
|
|
'unix
|
|
(and clean?
|
|
(sh "rm -rf " (q dir)))
|
|
(sh "if [ ! -d " (q dir) " ] ; then"
|
|
" git clone " (q repo) " " (q dir) " ; "
|
|
"fi")
|
|
(and pull?
|
|
(sh "cd " (q dir) " ; "
|
|
"git pull"))
|
|
(and need-native-racket?
|
|
(sh "cd " (q dir) " ; "
|
|
"make -j " j " native-for-cross"))
|
|
(sh "cd " (q dir) " ; "
|
|
"make -j " j " client"
|
|
(client-args c server server-port 'unix readme)
|
|
" JOB_OPTIONS=\"-j " j "\""
|
|
(if need-native-racket?
|
|
(~a " PLAIN_RACKET=`pwd`/racket/src/build/" built-native-racket)
|
|
"")
|
|
" CONFIGURE_ARGS_qq=" (qq (append
|
|
(if cross-target
|
|
(list (~a "--enable-racket="
|
|
(or given-racket
|
|
(~a "`pwd`/" built-native-racket)))
|
|
(~a "--host=" cross-target))
|
|
null)
|
|
(get-opt c '#:configure null))
|
|
'unix))))
|
|
|
|
(define (windows-build c platform host port user server server-port repo clean? pull? readme)
|
|
(define dir (get-path-opt c '#:dir "build\\plt" #:localhost (current-directory)))
|
|
(define bits (or (get-opt c '#:bits) 64))
|
|
(define vc (or (get-opt c '#:vc)
|
|
(if (= bits 32)
|
|
"x86"
|
|
"x86_amd64")))
|
|
(define j (or (get-opt c '#:j) 1))
|
|
(define (cmd . args)
|
|
(list "cmd" "/c" (shell-protect (apply ~a args) platform)))
|
|
(try-until-ready c host port user server-port 'windows (cmd "echo hello"))
|
|
(ssh-script
|
|
host port user
|
|
server-port
|
|
platform
|
|
(and clean?
|
|
(cmd "IF EXIST " (q dir) " rmdir /S /Q " (q dir)))
|
|
(cmd "IF NOT EXIST " (q dir) " git clone " (q repo) " " (q dir))
|
|
(and pull?
|
|
(cmd "cd " (q dir)
|
|
" && git pull"))
|
|
(cmd "cd " (q dir)
|
|
" && racket\\src\\worksp\\msvcprep.bat " vc
|
|
" && nmake win32-client"
|
|
" JOB_OPTIONS=\"-j " j "\""
|
|
(client-args c server server-port platform readme))))
|
|
|
|
(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 server-port (or (get-opt c '#:server-port)
|
|
default-server-port))
|
|
(define repo (or (get-opt c '#:repo)
|
|
(~a "http://" server ":" server-port "/.git")))
|
|
(define clean? (get-opt c '#:clean? default-clean? #:localhost #f))
|
|
(define pull? (get-opt c '#:pull? #t #:localhost #f))
|
|
|
|
(define readme-txt (let ([rdme (get-opt c '#:readme make-readme)])
|
|
(if (string? rdme)
|
|
rdme
|
|
(rdme (add-defaults c
|
|
'#:release? default-release?
|
|
'#:source? default-source?
|
|
'#:versionless? default-versionless?
|
|
'#:pkgs (string-split default-pkgs)
|
|
'#:install-name (if (get-opt c '#:release? default-release?)
|
|
""
|
|
snapshot-install-name)
|
|
'#:build-stamp (if (get-opt c '#:release? default-release?)
|
|
""
|
|
(current-stamp)))))))
|
|
(make-directory* (build-path "build" "readmes"))
|
|
(define readme (make-temporary-file
|
|
"README-~a"
|
|
#f
|
|
(build-path "build" "readmes")))
|
|
(call-with-output-file*
|
|
readme
|
|
#:exists 'truncate
|
|
(lambda (o)
|
|
(display readme-txt o)
|
|
(unless (regexp-match #rx"\n$" readme-txt)
|
|
;; ensure a newline at the end:
|
|
(newline o))))
|
|
|
|
(define platform (or (get-opt c '#:platform) (system-type)))
|
|
|
|
(begin0
|
|
|
|
((case platform
|
|
[(unix macosx) unix-build]
|
|
[else windows-build])
|
|
c platform host port user server server-port repo clean? pull? readme)
|
|
|
|
(delete-file readme)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define stop? #f)
|
|
|
|
(define failures (make-hasheq))
|
|
(define (record-failure name)
|
|
;; relies on atomicity of `eq?'-based hash table:
|
|
(hash-set! failures (string->symbol name) #t))
|
|
|
|
(define (limit-and-report-failure c timeout-factor
|
|
shutdown report-fail
|
|
thunk)
|
|
(define cust (make-custodian))
|
|
(define timeout (or (get-opt c '#:timeout)
|
|
(* 30 60)))
|
|
(define orig-thread (current-thread))
|
|
(define timeout? #f)
|
|
(begin0
|
|
(parameterize ([current-custodian cust])
|
|
(thread (lambda ()
|
|
(sleep (* timeout-factor timeout))
|
|
(eprintf "timeout for ~s\n" (client-name c))
|
|
;; try nice interrupt, first:
|
|
(set! timeout? #t)
|
|
(break-thread orig-thread)
|
|
(sleep 1)
|
|
;; force quit:
|
|
(report-fail)
|
|
(shutdown)))
|
|
(with-handlers ([exn? (lambda (exn)
|
|
(when (exn:break? exn)
|
|
;; This is useful only when everything is
|
|
;; sequential, which is the only time that
|
|
;; we'll get break events that aren't timeouts:
|
|
(unless timeout?
|
|
(set! stop? #t)))
|
|
(log-error "~a failed..." (client-name c))
|
|
(log-error (exn-message exn))
|
|
(report-fail)
|
|
#f)])
|
|
(thunk)))
|
|
(custodian-shutdown-all cust)))
|
|
|
|
(define (client-thread c all-seq? proc)
|
|
(unless stop?
|
|
(define log-dir (build-path "build" "log"))
|
|
(define log-file (build-path log-dir (client-name c)))
|
|
(make-directory* log-dir)
|
|
(printf "Logging build: ~a\n" log-file)
|
|
(flush-output)
|
|
(define cust (make-custodian))
|
|
(define (go shutdown)
|
|
(define p (open-output-file log-file
|
|
#:exists 'truncate/replace))
|
|
(file-stream-buffer-mode p 'line)
|
|
(define (report-fail)
|
|
(record-failure (client-name c))
|
|
(printf "Build FAILED for ~s\n" (client-name c)))
|
|
(unless (parameterize ([current-output-port p]
|
|
[current-error-port p])
|
|
(proc shutdown report-fail))
|
|
(report-fail))
|
|
(display-time))
|
|
(cond
|
|
[all-seq?
|
|
(go (lambda () (exit 1)))
|
|
(thread void)]
|
|
[else
|
|
(parameterize ([current-custodian cust])
|
|
(thread
|
|
(lambda ()
|
|
(go (lambda ()
|
|
(custodian-shutdown-all cust))))))])))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define start-seconds (current-seconds))
|
|
(display-time)
|
|
|
|
(void
|
|
(sync
|
|
(let loop ([config config]
|
|
[all-seq? #t] ; Ctl-C handling is better if nothing is in parallel
|
|
[opts (hasheq)])
|
|
(cond
|
|
[stop? (thread void)]
|
|
[else
|
|
(case (site-config-tag config)
|
|
[(parallel)
|
|
(define new-opts (merge-options opts config))
|
|
(define ts
|
|
(map (lambda (c) (loop c #f new-opts))
|
|
(get-content config)))
|
|
(thread
|
|
(lambda ()
|
|
(for ([t (in-list ts)])
|
|
(sync t))))]
|
|
[(sequential)
|
|
(define new-opts (merge-options opts config))
|
|
(define (go)
|
|
(for-each (lambda (c) (sync (loop c all-seq? new-opts)))
|
|
(get-content config)))
|
|
(if all-seq?
|
|
(begin (go) (thread void))
|
|
(thread go))]
|
|
[else
|
|
(define c (merge-options opts config))
|
|
(client-thread
|
|
c
|
|
all-seq?
|
|
(lambda (shutdown report-fail)
|
|
(limit-and-report-failure
|
|
c 2 shutdown report-fail
|
|
(lambda ()
|
|
(sleep (get-opt c '#:pause-before 0))
|
|
;; 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:
|
|
(begin0
|
|
(limit-and-report-failure
|
|
c 1 shutdown report-fail
|
|
(lambda () (client-build c)))
|
|
;; stop client, if a VM:
|
|
(stop-client c)
|
|
(sleep (get-opt c '#:pause-after 0)))))))])]))))
|
|
|
|
(display-time)
|
|
(define end-seconds (current-seconds))
|
|
|
|
(unless stop?
|
|
(let ([opts (merge-options (hasheq) config)])
|
|
(let ([to-email (get-opt opts '#:email-to null)])
|
|
(unless (null? to-email)
|
|
(printf "Sending report to ~a\n" (apply ~a to-email #:separator ", "))
|
|
(send-email to-email (lambda (key def)
|
|
(get-opt opts key def))
|
|
(get-opt opts '#:build-stamp (current-stamp))
|
|
start-seconds end-seconds
|
|
(hash-map failures (lambda (k v) (symbol->string k))))
|
|
(display-time)))))
|