commit 45d71521fd4accec1853c6dcc17adfa6816e73ee parent ba380fda7946af0540967d806d26eebb0e4fa00a Author: Matthew Flatt <mflatt@racket-lang.org> Date: Sun, 9 Mar 2014 11:40:06 -0600 distro-build: split server and client parts original commit: a98582b82337db02cd47b5d1a932285a80146c07 Diffstat:
44 files changed, 1087 insertions(+), 1053 deletions(-)
diff --git a/pkgs/distro-build/LICENSE.txt b/pkgs/distro-build-pkgs/distro-build-client/LICENSE.txt diff --git a/pkgs/distro-build/config.rkt b/pkgs/distro-build-pkgs/distro-build-client/config.rkt diff --git a/pkgs/distro-build/display-time.rkt b/pkgs/distro-build-pkgs/distro-build-client/display-time.rkt diff --git a/pkgs/distro-build/doc.txt b/pkgs/distro-build-pkgs/distro-build-client/doc.txt diff --git a/pkgs/distro-build-pkgs/distro-build-client/info.rkt b/pkgs/distro-build-pkgs/distro-build-client/info.rkt @@ -0,0 +1,11 @@ +#lang info + +(define collection "distro-build") + +(define deps '("base" + "ds-store-lib")) +(define build-deps '("at-exp-lib")) + +(define pkg-desc "client-side part of \"distro-build\"") + +(define pkg-authors '(mflatt)) diff --git a/pkgs/distro-build/install-for-docs.rkt b/pkgs/distro-build-pkgs/distro-build-client/install-for-docs.rkt diff --git a/pkgs/distro-build/install-pkgs.rkt b/pkgs/distro-build-pkgs/distro-build-client/install-pkgs.rkt diff --git a/pkgs/distro-build/installer-dmg.rkt b/pkgs/distro-build-pkgs/distro-build-client/installer-dmg.rkt diff --git a/pkgs/distro-build/installer-exe.rkt b/pkgs/distro-build-pkgs/distro-build-client/installer-exe.rkt diff --git a/pkgs/distro-build/installer-pkg.rkt b/pkgs/distro-build-pkgs/distro-build-client/installer-pkg.rkt diff --git a/pkgs/distro-build/installer-sh.rkt b/pkgs/distro-build-pkgs/distro-build-client/installer-sh.rkt diff --git a/pkgs/distro-build/installer-tgz.rkt b/pkgs/distro-build-pkgs/distro-build-client/installer-tgz.rkt diff --git a/pkgs/distro-build/installer.rkt b/pkgs/distro-build-pkgs/distro-build-client/installer.rkt diff --git a/pkgs/distro-build/macosx-installer/pkg-bg.png b/pkgs/distro-build-pkgs/distro-build-client/macosx-installer/pkg-bg.png Binary files differ. diff --git a/pkgs/distro-build/macosx-installer/racket-rising.png b/pkgs/distro-build-pkgs/distro-build-client/macosx-installer/racket-rising.png Binary files differ. diff --git a/pkgs/distro-build/readme.rkt b/pkgs/distro-build-pkgs/distro-build-client/readme.rkt diff --git a/pkgs/distro-build/set-config.rkt b/pkgs/distro-build-pkgs/distro-build-client/set-config.rkt diff --git a/pkgs/distro-build/unix-installer/installer-header b/pkgs/distro-build-pkgs/distro-build-client/unix-installer/installer-header diff --git a/pkgs/distro-build/unpack-collects.rkt b/pkgs/distro-build-pkgs/distro-build-client/unpack-collects.rkt diff --git a/pkgs/distro-build/url-options.rkt b/pkgs/distro-build-pkgs/distro-build-client/url-options.rkt diff --git a/pkgs/distro-build/windows-installer/header-r.bmp b/pkgs/distro-build-pkgs/distro-build-client/windows-installer/header-r.bmp Binary files differ. diff --git a/pkgs/distro-build/windows-installer/header.bmp b/pkgs/distro-build-pkgs/distro-build-client/windows-installer/header.bmp Binary files differ. diff --git a/pkgs/distro-build/windows-installer/installer.ico b/pkgs/distro-build-pkgs/distro-build-client/windows-installer/installer.ico Binary files differ. diff --git a/pkgs/distro-build/windows-installer/uninstaller.ico b/pkgs/distro-build-pkgs/distro-build-client/windows-installer/uninstaller.ico Binary files differ. diff --git a/pkgs/distro-build/windows-installer/welcome.bmp b/pkgs/distro-build-pkgs/distro-build-client/windows-installer/welcome.bmp Binary files differ. diff --git a/pkgs/distro-build/LICENSE.txt b/pkgs/distro-build-pkgs/distro-build-lib/LICENSE.txt diff --git a/pkgs/distro-build-pkgs/distro-build-lib/info.rkt b/pkgs/distro-build-pkgs/distro-build-lib/info.rkt @@ -0,0 +1,12 @@ +#lang info + +(define collection 'multi) + +(define deps '("distro-build-client" + "distro-build-server")) +(define implies '("distro-build-client" + "distro-build-server")) + +(define pkg-desc "implementation (no documentation) part of \"distro-build\"") + +(define pkg-authors '(mflatt)) diff --git a/pkgs/distro-build/LICENSE.txt b/pkgs/distro-build-pkgs/distro-build-server/LICENSE.txt diff --git a/pkgs/distro-build-pkgs/distro-build-server/assemble-site.rkt b/pkgs/distro-build-pkgs/distro-build-server/assemble-site.rkt @@ -0,0 +1,127 @@ +#lang racket/base +(require racket/cmdline + racket/file + net/url + "download-page.rkt" + (only-in distro-build/config extract-options)) + +(module test racket/base) + +(define build-dir (build-path "build")) + +(define built-dir (build-path build-dir "built")) +(define native-dir (build-path build-dir "native")) +(define docs-dir (build-path build-dir "docs")) + +(define installers-dir (build-path "installers")) +(define pkgs-dir (build-path "pkgs")) +(define catalog-dir (build-path "catalog")) +(define doc-dir (build-path "doc")) +(define pdf-doc-dir (build-path "pdf-doc")) +(define log-dir (build-path "log")) + +(define-values (config-file config-mode) + (command-line + #:args + (config-file config-mode) + (values config-file config-mode))) + +(define config (extract-options config-file config-mode)) + +(define dest-dir (hash-ref config + '#:site-dest + (build-path build-dir "site"))) + +(printf "Assembling site as ~a\n" dest-dir) + +(define (copy dir [build-dir build-dir]) + (make-directory* (let-values ([(base name dir?) (split-path dir)]) + (if (path? base) + (build-path dest-dir base) + dest-dir))) + (printf "Copying ~a\n" (build-path build-dir dir)) + (copy-directory/files (build-path build-dir dir) + (build-path dest-dir dir) + #:keep-modify-seconds? #t)) + +(delete-directory/files dest-dir #:must-exist? #f) + +(define (build-catalog built-dir) + (printf "Building catalog from ~a\n" built-dir) + (let ([c-dir (build-path built-dir pkgs-dir)] + [d-dir (build-path dest-dir pkgs-dir)]) + (make-directory* d-dir) + (for ([f (directory-list c-dir)]) + (define c (build-path c-dir f)) + (define d (build-path d-dir f)) + (copy-file c d) + (file-or-directory-modify-seconds d (file-or-directory-modify-seconds c)))) + (let ([c-dir (build-path built-dir catalog-dir "pkg")] + [d-dir (build-path dest-dir catalog-dir "pkg")]) + (make-directory* d-dir) + (define base-url (string->url (hash-ref config '#:dist-base-url))) + (for ([f (in-list (directory-list c-dir))]) + (define ht (call-with-input-file* (build-path c-dir f) read)) + (define new-ht + (hash-set ht 'source (url->string + (combine-url/relative + base-url + (path->string + (build-path + pkgs-dir + (path-add-suffix f #".zip"))))))) + (call-with-output-file* + (build-path d-dir f) + (lambda (o) + (write new-ht o) + (newline o)))))) + +(build-catalog built-dir) +(build-catalog native-dir) +(let ([l (directory-list (build-path dest-dir catalog-dir "pkg"))]) + ;; Write list of packages: + (define sl (map path-element->string l)) + (call-with-output-file* + (build-path dest-dir catalog-dir "pkgs") + (lambda (o) + (write sl o) + (newline o))) + ;; Write hash table of package details: + (define dht + (for/hash ([f (in-list l)]) + (values (path-element->string f) + (call-with-input-file* + (build-path dest-dir catalog-dir "pkg" f) + read)))) + (call-with-output-file* + (build-path dest-dir catalog-dir "pkgs-all") + (lambda (o) + (write dht o) + (newline o)))) + +(copy log-dir) + +(copy installers-dir) + +(define doc-path (build-path docs-dir doc-dir)) +(when (directory-exists? doc-path) + (copy doc-dir docs-dir)) +(define pdf-doc-path (build-path build-dir pdf-doc-dir)) +(when (directory-exists? pdf-doc-path) + (copy pdf-doc-dir)) +(copy "stamp.txt") +(copy (build-path "origin" "collects.tgz")) + +(make-download-page (build-path build-dir + installers-dir + "table.rktd") + #:installers-url "installers/" + #:log-dir-url "log/" + #:docs-url (and (directory-exists? doc-path) + "doc/index.html") + #:pdf-docs-url (and (directory-exists? pdf-doc-path) + "pdf-doc/") + #:dest (build-path dest-dir + "index.html") + #:help-table (hash-ref config '#:site-help (hash)) + #:git-clone (current-directory)) diff --git a/pkgs/distro-build/download-page.rkt b/pkgs/distro-build-pkgs/distro-build-server/download-page.rkt diff --git a/pkgs/distro-build-pkgs/distro-build-server/drive-clients.rkt b/pkgs/distro-build-pkgs/distro-build-server/drive-clients.rkt @@ -0,0 +1,585 @@ +#lang racket/base +(require racket/cmdline + racket/system + racket/port + racket/format + racket/file + racket/string + racket/path + (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 + "email.rkt") + +;; See "config.rkt" for an overview. + +(module test racket/base) + +;; ---------------------------------------- + +(define default-release? #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)] + [("--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 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)))) + (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 (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) + (flush-output) + (unless dry-run + (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 networking ready, etc. + (sleep 3)))) + +(define (stop-client c) + (define vbox (get-opt c '#:vbox)) + (when vbox + (printf "Stopping VirtualBox machine ~s\n" vbox) + (flush-output) + (unless dry-run + (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 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 (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 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 release? (get-opt c '#:release? default-release?)) + (define source? (get-opt c '#:source? #f)) + (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 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) + " 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) + " INSTALL_NAME=" (q install-name) + " BUILD_STAMP=" (q build-stamp) + " RELEASE_MODE=" (if release? "--release" (q "")) + " SOURCE_MODE=" (if source-runtime? "--source" (q "")) + " PKG_SOURCE_MODE=" (if source-pkgs? + (q "--source --no-setup") + (q "")) + " MAC_PKG_MODE=" (if mac-pkg? "--mac-pkg" (q "")) + " README=" (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 (sh . args) + (list "/bin/sh" "-c" (apply ~a args))) + (define j (or (get-opt c '#:j) 1)) + (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")) + (sh "cd " (q dir) " ; " + "make -j " j " client" + (client-args c server server-port 'unix readme) + " JOB_OPTIONS=\"-j " j "\"" + " CONFIGURE_ARGS_qq=" (qq (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" + "x64"))) + (define j (or (get-opt c '#:j) 1)) + (define (cmd . args) + (list "cmd" "/c" (shell-protect (apply ~a args) platform))) + (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) + " && \"c:\\Program Files" (if (= bits 64) " (x86)" "") "\\Microsoft Visual Studio 9.0\\vc\\vcvarsall.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? + '#: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))))) diff --git a/pkgs/distro-build/email.rkt b/pkgs/distro-build-pkgs/distro-build-server/email.rkt diff --git a/pkgs/distro-build-pkgs/distro-build-server/info.rkt b/pkgs/distro-build-pkgs/distro-build-server/info.rkt @@ -0,0 +1,14 @@ +#lang info + +(define collection "distro-build") + +(define deps '("base" + "distro-build-client" + "web-server-lib" + "ds-store-lib" + "net-lib")) +(define build-deps '("at-exp-lib")) + +(define pkg-desc "server-side part of \"distro-build\"") + +(define pkg-authors '(mflatt)) diff --git a/pkgs/distro-build-pkgs/distro-build-server/manage-snapshots.rkt b/pkgs/distro-build-pkgs/distro-build-server/manage-snapshots.rkt @@ -0,0 +1,131 @@ +#lang racket/base +(require racket/cmdline + racket/file + net/url + "download-page.rkt" + (only-in distro-build/config extract-options)) + +(module test racket/base) + +(define build-dir (build-path "build")) +(define installers-dir (build-path "installers")) + +(define-values (config-file config-mode) + (command-line + #:args + (config-file config-mode) + (values config-file config-mode))) + +(define config (extract-options config-file config-mode)) + +(define site-dir (hash-ref config + '#:site-dest + (build-path build-dir "site"))) + +(define current-snapshot + (let-values ([(base name dir?) (split-path site-dir)]) + (path-element->string name))) + +(define snapshots-dir (build-path site-dir 'up)) + +(define link-file (build-path snapshots-dir "current")) + +(when (link-exists? link-file) + (printf "Removing old \"current\" link\n") + (flush-output) + (delete-file link-file)) + +(define (get-snapshots) + (for/list ([p (in-list (directory-list snapshots-dir))] + #:when (directory-exists? (build-path snapshots-dir p))) + (path-element->string p))) + +(define n (hash-ref config '#:max-snapshots 5)) + +(let ([snapshots (get-snapshots)]) + (when (n . < . (length snapshots)) + (define remove-snapshots (remove + current-snapshot + (list-tail (sort snapshots string>?) n))) + (for ([s (in-list remove-snapshots)]) + (printf "Removing snapshot ~a\n" s) + (flush-output) + (delete-directory/files (build-path snapshots-dir s))))) + +(printf "Loading past successes\n") +(define table-file (build-path site-dir installers-dir "table.rktd")) +(define past-successes + (let ([current-table (get-installers-table table-file)]) + (for/fold ([table (hash)]) ([s (in-list (reverse (remove current-snapshot (get-snapshots))))]) + (define past-table (get-installers-table + (build-path snapshots-dir s installers-dir "table.rktd"))) + (for/fold ([table table]) ([(k v) (in-hash past-table)]) + (if (or (hash-ref current-table k #f) + (hash-ref table k #f) + (not (file-exists? (build-path site-dir "log" k)))) + table + (hash-set table k (past-success s + (string-append s "/index.html") + v))))))) + +(define current-rx (regexp (regexp-quote (version)))) + +(printf "Creating \"current\" links\n") +(flush-output) +(make-file-or-directory-link current-snapshot link-file) +(let ([installer-dir (build-path snapshots-dir current-snapshot "installers")]) + (define (currentize f) + (regexp-replace current-rx + (path->bytes f) + "current")) + (define (make-link f to-file) + (define file-link (build-path + installer-dir + (bytes->path (currentize f)))) + (when (link-exists? file-link) + (delete-file file-link)) + (make-file-or-directory-link to-file file-link)) + ;; Link current successes: + (for ([f (in-list (directory-list installer-dir))]) + (when (regexp-match? current-rx f) + (make-link f f))) + ;; Link past successes: + (for ([v (in-hash-values past-successes)]) + (when (regexp-match? current-rx (past-success-file v)) + (make-link (string->path (past-success-file v)) + (build-path 'up 'up + (past-success-name v) installers-dir + (past-success-file v)))))) + + +(printf "Generating web page\n") +(make-download-page table-file + #:past-successes past-successes + #:installers-url "current/installers/" + #:log-dir (build-path site-dir "log") + #:log-dir-url "current/log/" + #:docs-url (and (directory-exists? (build-path site-dir "doc")) + "current/doc/index.html") + #:pdf-docs-url (and (directory-exists? (build-path site-dir "pdf-doc")) + "current/pdf-doc/") + #:dest (build-path snapshots-dir + "index.html") + #:current-rx current-rx + #:git-clone (current-directory) + #:help-table (hash-ref config '#:site-help (hash)) + #:post-content `((p "Snapshot ID: " + (a ((href ,(string-append current-snapshot + "/index.html"))) + ,current-snapshot)) + ,@(let ([snapshots (get-snapshots)]) + (if ((length snapshots) . < . 2) + null + `((div ([class "detail"]) + "Other available snapshots:" + ,@(for/list ([s (remove "current" + (remove current-snapshot + (sort snapshots string>?)))]) + `(span ([class "detail"]) + nbsp + (a ([href ,(string-append s "/index.html")]) + ,s))))))))) diff --git a/pkgs/distro-build/pack-built.rkt b/pkgs/distro-build-pkgs/distro-build-server/pack-built.rkt diff --git a/pkgs/distro-build/pack-collects.rkt b/pkgs/distro-build-pkgs/distro-build-server/pack-collects.rkt diff --git a/pkgs/distro-build-pkgs/distro-build-server/serve-catalog.rkt b/pkgs/distro-build-pkgs/distro-build-server/serve-catalog.rkt @@ -0,0 +1,197 @@ +#lang racket/base +(require web-server/servlet-env + web-server/dispatch + web-server/http/response-structs + web-server/http/request-structs + net/url + racket/format + racket/cmdline + racket/file + racket/path + racket/string + racket/tcp + racket/port + racket/system + (only-in distro-build/config extract-options) + distro-build/readme) + +(module test racket/base) + +(define from-dir "built") + +(define-values (config-file config-mode + default-server-hosts default-server-port + during-cmd-line) + (command-line + #:once-each + [("--mode") dir "Serve package archives from <dir> subdirectory" + (set! from-dir dir)] + #:args (config-file config-mode server-hosts server-port . during-cmd) + (values config-file config-mode + server-hosts (string->number server-port) + during-cmd))) + +(define server-hosts + (hash-ref (extract-options config-file config-mode) + '#:server-hosts + (string-split default-server-hosts ","))) +(define server-port + (hash-ref (extract-options config-file config-mode) + '#:server-port + default-server-port)) + +(define build-dir (path->complete-path "build")) +(define built-dir (build-path build-dir from-dir)) +(define native-dir (build-path build-dir "native")) + +(define dirs (list built-dir native-dir)) + +(define (pkg-name->info req name) + (define (extract-host-header sel) + (for/or ([h (in-list (request-headers/raw req))]) + (and (equal? (header-field h) #"Host") + (let ([m (regexp-match #rx#"^(.*):([0-9]+)$" + (header-value h))]) + (and m + (sel (list (bytes->string/utf-8 (cadr m)) + (string->number (bytes->string/utf-8 (caddr m)))))))))) + (for/or ([d (in-list dirs)]) + (define f (build-path d "catalog" "pkg" name)) + (and (file-exists? f) + (let ([h (call-with-input-file* + f + read)]) + (define s (hash-ref h 'source)) + (hash-set h + 'source + (url->string + (url "http" + #f + (or (extract-host-header car) + (let ([h (request-host-ip req)]) + (if (equal? h "::1") + "localhost" + h))) + (or (extract-host-header cadr) + (request-host-port req)) + #t + (list (path/param (~a name ".zip") null)) + null + #f))))))) + +(define (response/sexpr v) + (response 200 #"Okay" (current-seconds) + #"text/s-expr" null + (λ (op) (write v op)))) + +(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")) + (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))) + (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) + (dispatch-rules + [("pkg" (string-arg)) write-info] + [("upload" (string-arg)) #:method "put" receive-file])) + +;; Tunnel extra hosts to first one: +(when (and (pair? server-hosts) + (pair? (cdr server-hosts))) + (for ([host (in-list (cdr server-hosts))]) + (thread + (lambda () + (define l (tcp-listen server-port 5 #t host)) + (let loop () + (define-values (i o) (tcp-accept l)) + (define-values (i2 o2) (tcp-connect (car server-hosts) server-port)) + (thread (lambda () + (copy-port i o2) + (close-input-port i) + (close-output-port o2))) + (thread (lambda () + (copy-port i2 o) + (close-input-port i2) + (close-output-port o))) + (loop)))))) + +(define (go) + (serve/servlet + dispatch + #:command-line? #t + #:listen-ip (if (null? server-hosts) + #f + (car server-hosts)) + #:extra-files-paths + (append + (list (build-path build-dir "origin")) + (list readmes-dir) + (for/list ([d (in-list dirs)]) + (path->complete-path (build-path d "pkgs"))) + ;; for ".git": + (list (current-directory))) + #:servlet-regexp #rx"" + #:port server-port)) + +(define readmes-dir (build-path build-dir "readmes")) +(make-directory* readmes-dir) + +(define readme-file (build-path readmes-dir "README.txt")) +(unless (file-exists? readme-file) + (printf "Generating default README\n") + (call-with-output-file* + readme-file + (lambda (o) + (display (make-readme (hash)) o)))) + +(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)))) diff --git a/pkgs/distro-build/LICENSE.txt b/pkgs/distro-build-pkgs/distro-build/LICENSE.txt diff --git a/pkgs/distro-build-pkgs/distro-build/info.rkt b/pkgs/distro-build-pkgs/distro-build/info.rkt @@ -0,0 +1,10 @@ +#lang info + +(define collection 'multi) + +(define deps '("distro-build-lib")) +(define implies '("distro-build-lib")) + +(define pkg-desc "Tools for constructing a distribution of Racket") + +(define pkg-authors '(mflatt)) diff --git a/pkgs/distro-build/assemble-site.rkt b/pkgs/distro-build/assemble-site.rkt @@ -1,127 +0,0 @@ -#lang racket/base -(require racket/cmdline - racket/file - net/url - "download-page.rkt" - (only-in "config.rkt" extract-options)) - -(module test racket/base) - -(define build-dir (build-path "build")) - -(define built-dir (build-path build-dir "built")) -(define native-dir (build-path build-dir "native")) -(define docs-dir (build-path build-dir "docs")) - -(define installers-dir (build-path "installers")) -(define pkgs-dir (build-path "pkgs")) -(define catalog-dir (build-path "catalog")) -(define doc-dir (build-path "doc")) -(define pdf-doc-dir (build-path "pdf-doc")) -(define log-dir (build-path "log")) - -(define-values (config-file config-mode) - (command-line - #:args - (config-file config-mode) - (values config-file config-mode))) - -(define config (extract-options config-file config-mode)) - -(define dest-dir (hash-ref config - '#:site-dest - (build-path build-dir "site"))) - -(printf "Assembling site as ~a\n" dest-dir) - -(define (copy dir [build-dir build-dir]) - (make-directory* (let-values ([(base name dir?) (split-path dir)]) - (if (path? base) - (build-path dest-dir base) - dest-dir))) - (printf "Copying ~a\n" (build-path build-dir dir)) - (copy-directory/files (build-path build-dir dir) - (build-path dest-dir dir) - #:keep-modify-seconds? #t)) - -(delete-directory/files dest-dir #:must-exist? #f) - -(define (build-catalog built-dir) - (printf "Building catalog from ~a\n" built-dir) - (let ([c-dir (build-path built-dir pkgs-dir)] - [d-dir (build-path dest-dir pkgs-dir)]) - (make-directory* d-dir) - (for ([f (directory-list c-dir)]) - (define c (build-path c-dir f)) - (define d (build-path d-dir f)) - (copy-file c d) - (file-or-directory-modify-seconds d (file-or-directory-modify-seconds c)))) - (let ([c-dir (build-path built-dir catalog-dir "pkg")] - [d-dir (build-path dest-dir catalog-dir "pkg")]) - (make-directory* d-dir) - (define base-url (string->url (hash-ref config '#:dist-base-url))) - (for ([f (in-list (directory-list c-dir))]) - (define ht (call-with-input-file* (build-path c-dir f) read)) - (define new-ht - (hash-set ht 'source (url->string - (combine-url/relative - base-url - (path->string - (build-path - pkgs-dir - (path-add-suffix f #".zip"))))))) - (call-with-output-file* - (build-path d-dir f) - (lambda (o) - (write new-ht o) - (newline o)))))) - -(build-catalog built-dir) -(build-catalog native-dir) -(let ([l (directory-list (build-path dest-dir catalog-dir "pkg"))]) - ;; Write list of packages: - (define sl (map path-element->string l)) - (call-with-output-file* - (build-path dest-dir catalog-dir "pkgs") - (lambda (o) - (write sl o) - (newline o))) - ;; Write hash table of package details: - (define dht - (for/hash ([f (in-list l)]) - (values (path-element->string f) - (call-with-input-file* - (build-path dest-dir catalog-dir "pkg" f) - read)))) - (call-with-output-file* - (build-path dest-dir catalog-dir "pkgs-all") - (lambda (o) - (write dht o) - (newline o)))) - -(copy log-dir) - -(copy installers-dir) - -(define doc-path (build-path docs-dir doc-dir)) -(when (directory-exists? doc-path) - (copy doc-dir docs-dir)) -(define pdf-doc-path (build-path build-dir pdf-doc-dir)) -(when (directory-exists? pdf-doc-path) - (copy pdf-doc-dir)) -(copy "stamp.txt") -(copy (build-path "origin" "collects.tgz")) - -(make-download-page (build-path build-dir - installers-dir - "table.rktd") - #:installers-url "installers/" - #:log-dir-url "log/" - #:docs-url (and (directory-exists? doc-path) - "doc/index.html") - #:pdf-docs-url (and (directory-exists? pdf-doc-path) - "pdf-doc/") - #:dest (build-path dest-dir - "index.html") - #:help-table (hash-ref config '#:site-help (hash)) - #:git-clone (current-directory)) diff --git a/pkgs/distro-build/drive-clients.rkt b/pkgs/distro-build/drive-clients.rkt @@ -1,585 +0,0 @@ -#lang racket/base -(require racket/cmdline - racket/system - racket/port - racket/format - racket/file - racket/string - racket/path - (only-in "config.rkt" - current-mode - site-config? - site-config-tag site-config-options site-config-content - current-stamp) - "url-options.rkt" - "display-time.rkt" - "readme.rkt" - "email.rkt") - -;; See "config.rkt" for an overview. - -(module test racket/base) - -;; ---------------------------------------- - -(define default-release? #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)] - [("--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 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)))) - (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 (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) - (flush-output) - (unless dry-run - (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 networking ready, etc. - (sleep 3)))) - -(define (stop-client c) - (define vbox (get-opt c '#:vbox)) - (when vbox - (printf "Stopping VirtualBox machine ~s\n" vbox) - (flush-output) - (unless dry-run - (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 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 (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 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 release? (get-opt c '#:release? default-release?)) - (define source? (get-opt c '#:source? #f)) - (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 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) - " 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) - " INSTALL_NAME=" (q install-name) - " BUILD_STAMP=" (q build-stamp) - " RELEASE_MODE=" (if release? "--release" (q "")) - " SOURCE_MODE=" (if source-runtime? "--source" (q "")) - " PKG_SOURCE_MODE=" (if source-pkgs? - (q "--source --no-setup") - (q "")) - " MAC_PKG_MODE=" (if mac-pkg? "--mac-pkg" (q "")) - " README=" (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 (sh . args) - (list "/bin/sh" "-c" (apply ~a args))) - (define j (or (get-opt c '#:j) 1)) - (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")) - (sh "cd " (q dir) " ; " - "make -j " j " client" - (client-args c server server-port 'unix readme) - " JOB_OPTIONS=\"-j " j "\"" - " CONFIGURE_ARGS_qq=" (qq (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" - "x64"))) - (define j (or (get-opt c '#:j) 1)) - (define (cmd . args) - (list "cmd" "/c" (shell-protect (apply ~a args) platform))) - (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) - " && \"c:\\Program Files" (if (= bits 64) " (x86)" "") "\\Microsoft Visual Studio 9.0\\vc\\vcvarsall.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? - '#: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))))) diff --git a/pkgs/distro-build/info.rkt b/pkgs/distro-build/info.rkt @@ -1,13 +0,0 @@ -#lang info - -(define collection "distro-build") - -(define deps '("base" - "web-server-lib" - "ds-store-lib" - "net-lib")) -(define build-deps '("at-exp-lib")) - -(define pkg-desc "Tools for constructing a distribution of Racket") - -(define pkg-authors '(mflatt)) diff --git a/pkgs/distro-build/manage-snapshots.rkt b/pkgs/distro-build/manage-snapshots.rkt @@ -1,131 +0,0 @@ -#lang racket/base -(require racket/cmdline - racket/file - net/url - "download-page.rkt" - (only-in "config.rkt" extract-options)) - -(module test racket/base) - -(define build-dir (build-path "build")) -(define installers-dir (build-path "installers")) - -(define-values (config-file config-mode) - (command-line - #:args - (config-file config-mode) - (values config-file config-mode))) - -(define config (extract-options config-file config-mode)) - -(define site-dir (hash-ref config - '#:site-dest - (build-path build-dir "site"))) - -(define current-snapshot - (let-values ([(base name dir?) (split-path site-dir)]) - (path-element->string name))) - -(define snapshots-dir (build-path site-dir 'up)) - -(define link-file (build-path snapshots-dir "current")) - -(when (link-exists? link-file) - (printf "Removing old \"current\" link\n") - (flush-output) - (delete-file link-file)) - -(define (get-snapshots) - (for/list ([p (in-list (directory-list snapshots-dir))] - #:when (directory-exists? (build-path snapshots-dir p))) - (path-element->string p))) - -(define n (hash-ref config '#:max-snapshots 5)) - -(let ([snapshots (get-snapshots)]) - (when (n . < . (length snapshots)) - (define remove-snapshots (remove - current-snapshot - (list-tail (sort snapshots string>?) n))) - (for ([s (in-list remove-snapshots)]) - (printf "Removing snapshot ~a\n" s) - (flush-output) - (delete-directory/files (build-path snapshots-dir s))))) - -(printf "Loading past successes\n") -(define table-file (build-path site-dir installers-dir "table.rktd")) -(define past-successes - (let ([current-table (get-installers-table table-file)]) - (for/fold ([table (hash)]) ([s (in-list (reverse (remove current-snapshot (get-snapshots))))]) - (define past-table (get-installers-table - (build-path snapshots-dir s installers-dir "table.rktd"))) - (for/fold ([table table]) ([(k v) (in-hash past-table)]) - (if (or (hash-ref current-table k #f) - (hash-ref table k #f) - (not (file-exists? (build-path site-dir "log" k)))) - table - (hash-set table k (past-success s - (string-append s "/index.html") - v))))))) - -(define current-rx (regexp (regexp-quote (version)))) - -(printf "Creating \"current\" links\n") -(flush-output) -(make-file-or-directory-link current-snapshot link-file) -(let ([installer-dir (build-path snapshots-dir current-snapshot "installers")]) - (define (currentize f) - (regexp-replace current-rx - (path->bytes f) - "current")) - (define (make-link f to-file) - (define file-link (build-path - installer-dir - (bytes->path (currentize f)))) - (when (link-exists? file-link) - (delete-file file-link)) - (make-file-or-directory-link to-file file-link)) - ;; Link current successes: - (for ([f (in-list (directory-list installer-dir))]) - (when (regexp-match? current-rx f) - (make-link f f))) - ;; Link past successes: - (for ([v (in-hash-values past-successes)]) - (when (regexp-match? current-rx (past-success-file v)) - (make-link (string->path (past-success-file v)) - (build-path 'up 'up - (past-success-name v) installers-dir - (past-success-file v)))))) - - -(printf "Generating web page\n") -(make-download-page table-file - #:past-successes past-successes - #:installers-url "current/installers/" - #:log-dir (build-path site-dir "log") - #:log-dir-url "current/log/" - #:docs-url (and (directory-exists? (build-path site-dir "doc")) - "current/doc/index.html") - #:pdf-docs-url (and (directory-exists? (build-path site-dir "pdf-doc")) - "current/pdf-doc/") - #:dest (build-path snapshots-dir - "index.html") - #:current-rx current-rx - #:git-clone (current-directory) - #:help-table (hash-ref config '#:site-help (hash)) - #:post-content `((p "Snapshot ID: " - (a ((href ,(string-append current-snapshot - "/index.html"))) - ,current-snapshot)) - ,@(let ([snapshots (get-snapshots)]) - (if ((length snapshots) . < . 2) - null - `((div ([class "detail"]) - "Other available snapshots:" - ,@(for/list ([s (remove "current" - (remove current-snapshot - (sort snapshots string>?)))]) - `(span ([class "detail"]) - nbsp - (a ([href ,(string-append s "/index.html")]) - ,s))))))))) diff --git a/pkgs/distro-build/serve-catalog.rkt b/pkgs/distro-build/serve-catalog.rkt @@ -1,197 +0,0 @@ -#lang racket/base -(require web-server/servlet-env - web-server/dispatch - web-server/http/response-structs - web-server/http/request-structs - net/url - racket/format - racket/cmdline - racket/file - racket/path - racket/string - racket/tcp - racket/port - racket/system - (only-in "config.rkt" extract-options) - "readme.rkt") - -(module test racket/base) - -(define from-dir "built") - -(define-values (config-file config-mode - default-server-hosts default-server-port - during-cmd-line) - (command-line - #:once-each - [("--mode") dir "Serve package archives from <dir> subdirectory" - (set! from-dir dir)] - #:args (config-file config-mode server-hosts server-port . during-cmd) - (values config-file config-mode - server-hosts (string->number server-port) - during-cmd))) - -(define server-hosts - (hash-ref (extract-options config-file config-mode) - '#:server-hosts - (string-split default-server-hosts ","))) -(define server-port - (hash-ref (extract-options config-file config-mode) - '#:server-port - default-server-port)) - -(define build-dir (path->complete-path "build")) -(define built-dir (build-path build-dir from-dir)) -(define native-dir (build-path build-dir "native")) - -(define dirs (list built-dir native-dir)) - -(define (pkg-name->info req name) - (define (extract-host-header sel) - (for/or ([h (in-list (request-headers/raw req))]) - (and (equal? (header-field h) #"Host") - (let ([m (regexp-match #rx#"^(.*):([0-9]+)$" - (header-value h))]) - (and m - (sel (list (bytes->string/utf-8 (cadr m)) - (string->number (bytes->string/utf-8 (caddr m)))))))))) - (for/or ([d (in-list dirs)]) - (define f (build-path d "catalog" "pkg" name)) - (and (file-exists? f) - (let ([h (call-with-input-file* - f - read)]) - (define s (hash-ref h 'source)) - (hash-set h - 'source - (url->string - (url "http" - #f - (or (extract-host-header car) - (let ([h (request-host-ip req)]) - (if (equal? h "::1") - "localhost" - h))) - (or (extract-host-header cadr) - (request-host-port req)) - #t - (list (path/param (~a name ".zip") null)) - null - #f))))))) - -(define (response/sexpr v) - (response 200 #"Okay" (current-seconds) - #"text/s-expr" null - (λ (op) (write v op)))) - -(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")) - (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))) - (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) - (dispatch-rules - [("pkg" (string-arg)) write-info] - [("upload" (string-arg)) #:method "put" receive-file])) - -;; Tunnel extra hosts to first one: -(when (and (pair? server-hosts) - (pair? (cdr server-hosts))) - (for ([host (in-list (cdr server-hosts))]) - (thread - (lambda () - (define l (tcp-listen server-port 5 #t host)) - (let loop () - (define-values (i o) (tcp-accept l)) - (define-values (i2 o2) (tcp-connect (car server-hosts) server-port)) - (thread (lambda () - (copy-port i o2) - (close-input-port i) - (close-output-port o2))) - (thread (lambda () - (copy-port i2 o) - (close-input-port i2) - (close-output-port o))) - (loop)))))) - -(define (go) - (serve/servlet - dispatch - #:command-line? #t - #:listen-ip (if (null? server-hosts) - #f - (car server-hosts)) - #:extra-files-paths - (append - (list (build-path build-dir "origin")) - (list readmes-dir) - (for/list ([d (in-list dirs)]) - (path->complete-path (build-path d "pkgs"))) - ;; for ".git": - (list (current-directory))) - #:servlet-regexp #rx"" - #:port server-port)) - -(define readmes-dir (build-path build-dir "readmes")) -(make-directory* readmes-dir) - -(define readme-file (build-path readmes-dir "README.txt")) -(unless (file-exists? readme-file) - (printf "Generating default README\n") - (call-with-output-file* - readme-file - (lambda (o) - (display (make-readme (hash)) o)))) - -(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))))
