From 8fa26e6f4fecc08baf40c2bd0a2feb4704ce3191 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 28 Nov 2014 15:26:10 -0500 Subject: [PATCH] Split `pkg-build` from the main repository. The `drdr2` pkg is now at https://github.com/racket/pkg-build --- pkgs/plt-services/meta/pkg-build/about.rkt | 191 --- pkgs/plt-services/meta/pkg-build/download.rkt | 51 - .../meta/pkg-build/extract-doc.rkt | 40 - pkgs/plt-services/meta/pkg-build/main.rkt | 1392 ----------------- pkgs/plt-services/meta/pkg-build/pkg-adds.rkt | 33 - pkgs/plt-services/meta/pkg-build/pkg-list.rkt | 12 - pkgs/plt-services/meta/pkg-build/status.rkt | 35 - pkgs/plt-services/meta/pkg-build/summary.rkt | 182 --- pkgs/plt-services/meta/pkg-build/thread.rkt | 139 -- .../meta/pkg-build/union-find.rkt | 64 - 10 files changed, 2139 deletions(-) delete mode 100644 pkgs/plt-services/meta/pkg-build/about.rkt delete mode 100644 pkgs/plt-services/meta/pkg-build/download.rkt delete mode 100644 pkgs/plt-services/meta/pkg-build/extract-doc.rkt delete mode 100644 pkgs/plt-services/meta/pkg-build/main.rkt delete mode 100644 pkgs/plt-services/meta/pkg-build/pkg-adds.rkt delete mode 100644 pkgs/plt-services/meta/pkg-build/pkg-list.rkt delete mode 100644 pkgs/plt-services/meta/pkg-build/status.rkt delete mode 100644 pkgs/plt-services/meta/pkg-build/summary.rkt delete mode 100644 pkgs/plt-services/meta/pkg-build/thread.rkt delete mode 100644 pkgs/plt-services/meta/pkg-build/union-find.rkt diff --git a/pkgs/plt-services/meta/pkg-build/about.rkt b/pkgs/plt-services/meta/pkg-build/about.rkt deleted file mode 100644 index 8818947b2f..0000000000 --- a/pkgs/plt-services/meta/pkg-build/about.rkt +++ /dev/null @@ -1,191 +0,0 @@ -#lang at-exp racket/base -(require scribble/html - plt-web - (only-in plt-web/style columns)) - -(provide make-about) - -(define (here . c) - (columns 10 #:row? #t (body c))) - -(define (hx . c) - @h5{@b[c]}) - -(define (make-about page-site) - (define page-title "About Package Builds") - (define (literal-url s) - @a[href: s s]) - (page #:site page-site - #:file "about.html" - #:title page-title - (html (head (title page-title)) - - @here{@h3[page-title] - - @p{For every package that is registered at -@literal-url{http://pkgs.racket-lang.org/}, the package-build service -starts with the current release, periodically checks for package -updates, and attempts to build each package that has changed or has a -dependency that has changed.} - - @p{When a package installation succeeds, -tests in the package are run with} - - @pre{ raco test --drdr} - - @p{} - - @p{Packages are built on a 64-bit Linux virtual -machine (VM) that is isolated from the network. Each package build -starts with a fresh instance of the virtual machine, and -packages are re-packaged in built form for use by other -packages. Testing of a package starts with a fresh instance of the -virtual machine and a fresh installation of the package from its built -form.} - - @; ---------------------------------------- - @h3{Limitations} - - @hx{Only Packages from the Main Catalog are Supported} - - @p{The package-build service does not support -references to @a[href: "http://planet.racket-lang.org"]{PLaneT -packages} or to compatibility packages at -@literal-url{http://planet-compats.racket-lang.org/}. When a package -depends on one of those, then the package installation fails, because -package builds are performed on a VM without network -connectivity.} - - @hx{Few System Libraries are Installed} - - @p{Each package is installed on a minimal VM that -omits as many system libraries and tools as is practical. If building -on the minimal VM fails, the package build is retried on a VM with -more tools and libraries, including a C compiler and an X server -running at @tt{:1}. Look for @|ldquo|extra system dependencies@|rdquo| in -the result column for packages that don@|rsquo|t work in the minimal -environment but do work in the extended one.} - - @p{The idea behind the minimal VM is that a -package generally shouldn@|rsquo|t rely on tools that a Racket user -may not have installed@|mdash|and so it@|rsquo|s worth reporting -those problems from the package-build service. At the same time, a -package might be intended to work only in a typical Unix setup, and -witholding a C compiler, for example, would be especially uncooperative of -the package-build service.} - - @hx{Test Capabilities May Be Limited} - - @p{Limited system libraries, missing network -connectivity, or other constraints may prevent the package-build -service from straighforwardly running a package@|rsquo|s tests. See -@a[href: "#test"]{Dealing with Test Failures}.} - - @hx{Native Libraries Need Special Handling} - - @p{Even on the extended VM, the available system -libraries are limited. See @a[href: "#foreign"]{Working with Native -Libraries} below for information on implementing packages that rely on -additional native libraries.} - - @; ---------------------------------------- - @h3[name: "test"]{Dealing Test Failures} - - @p{In the absence of any @tt{"info.rkt"}-based -specifications or @tt{test} submodules, @tt{raco test} runs each -module in a package. Running a particular module might fail if -it@|rsquo|s a program-starting module that expects command-line -arguments, or a module might start a program that expects input and -causes the test to time out.} - - @p{In the simplest case, you can add a `test` submodule as} - - @pre{ (module test racket/base)} - - @p{} - - @p{to make @tt{raco test} ignore the enclosing -module. You can control @tt{raco test} in various other ways through -submodules and @tt{"info.rkt"} files@";" see -@a[href: "http://docs.racket-lang.org/raco/test.html"]{the -documentation}.} - - @p{The default timeout on an individual test is 90 seconds, and the -overall timeout for testing a package is 10 minutes. You can adjust the -former, but the latter is a hard limit for now.} - - @p{Tests are always run on the extended VM, but even so, -sometimes the package-build service cannot run a package@|rsquo|s tests. For -example, if a package needs network access for testing, the -package-build service can@|rsquo|t help, because it runs on an isolated -VM. There@|rsquo|s no way for a package to opt out of -testing, but a package author can implement a test suite that skip tests -under adverse conditions. In case there@|rsquo|s no other way for a test -suite to determine that it can@|rsquo|t run, the package-build service sets -the @tt{PLT_PKG_BUILD_SERVICE} environment variable when running -tests@";" a test suite can explicitly check for the environment -variable and skip tests that can@|rsquo|t work.} - - - @; ---------------------------------------- - @h3[name: "foreign"]{Working with Native Libraries} - - @p{The @|ldquo|minimal@|rdquo| versus -@|ldquo|extended@|rdquo| VM distinction begs the question of how the -package-build service can support a package that relies on a native -library@|mdash|one that is not installed even on the extended VM.} - - @p{It would be nice to have a bridge between the -Racket package system and the OS package manager so that dependencies -on OS packages could be declared and installed. One catch is that the -bridge would have to work with a package-build VM that is isolated -from the network. The networking, permission, and maintenance issues -seem complex enough that we haven@|rsquo|t embarked on that direction.} - - @p{For now, the package-build installation -identifies itself as running on the @tt{"x86_64-linux-natipkg"} -platform, as opposed to plain @tt{"x86_64-linux"}. On the plain -@tt{"x86_64-linux"} platform, native libraries as needed by Racket -packages are expected to be installed by a user through the -OS@|rsquo|s package manager. On the @tt{"x86_64-linux-natipkg"} -platform, however, native libraries are handled as on Windows and Mac -OS X: they are expected to be provided by platform-specific packages.} - - @p{For example, on the @tt{"x86_64-linux-natipkg"} -platform, the @tt{"math-lib"} package depends on the -@tt{"math-x86_64-linux-natipkg"} package, which provides 64-bit Linux -builds of GMP and MPFR. You can see that dependency declaration in the -@tt{"info.rkt"} file for the @tt{"math-lib"} package:} - - @pre{ @literal-url{https://github.com/plt/racket/blob/master/pkgs/math-pkgs/math-lib/info.rkt}} - - @p{} - - @p{If your package depends on a native -library, then you currently have two main options:} - - @hx{Accomodate Unavailable Libraries} - - @p{One option is to make the package behave when the native library is unavailable.} - - @p{Typically, a native library that is accessed via @tt{ffi/unsafe} - isn@|rsquo|t needed to merely build a package - (including its documentation). If possible, delay any use of the - native library to run time so that the package can build without it.} - - @p{For tests, you can either just let them fail, or you can adjust the - test suite to avoid failure reports when the native library is - unavailable or (if you must) when @tt{PLT_PKG_BUILD_SERVICE} is defined.} - - @hx{Distribute Native Libraries} - - @p{Another option is to build a 64-bit Linux -version of the library, distribute it as a package, and make -the package a platform-specific dependency of your package for the -@tt{"x86_64-linux-natipkg"} platform.} - - @p{This option is in many ways the best one for -users and for testing@|mdash|especially if Windows and Mac OS X -native-library packages are also provided@|mdash|but it@|rsquo|s more work.} - - }))) diff --git a/pkgs/plt-services/meta/pkg-build/download.rkt b/pkgs/plt-services/meta/pkg-build/download.rkt deleted file mode 100644 index da2f230a97..0000000000 --- a/pkgs/plt-services/meta/pkg-build/download.rkt +++ /dev/null @@ -1,51 +0,0 @@ -#lang racket/base -(require net/url - net/head - racket/format - racket/file - racket/port) - -(provide download-installer) - -(define (download-installer snapshot-url installer-dir installer-name substatus) - (define status-file (build-path installer-dir "status.rktd")) - (define name+etag (and (file-exists? status-file) - (call-with-input-file* - status-file - read))) - (define installer-url (combine-url/relative (string->url snapshot-url) - (~a "installers/" installer-name))) - (define etag - (cond - [(equal? (url-scheme installer-url) "file") - #f] - [else - (define p (head-impure-port installer-url)) - (define h (purify-port p)) - (close-input-port p) - (extract-field "ETag" h)])) - (cond - [(and (file-exists? (build-path installer-dir installer-name)) - name+etag - (equal? (car name+etag) installer-name) - (cadr name+etag) - (equal? (cadr name+etag) etag)) - (substatus "Using cached installer, Etag ~a\n" etag)] - [else - (delete-directory/files installer-dir #:must-exist? #f) - (make-directory* installer-dir) - (call/input-url - installer-url - get-pure-port - (lambda (i) - (call-with-output-file* - (build-path installer-dir installer-name) - #:exists 'replace - (lambda (o) - (copy-port i o))))) - (when etag - (call-with-output-file* - status-file - (lambda (o) - (write (list installer-name etag) o) - (newline o))))])) diff --git a/pkgs/plt-services/meta/pkg-build/extract-doc.rkt b/pkgs/plt-services/meta/pkg-build/extract-doc.rkt deleted file mode 100644 index 1b8103de7c..0000000000 --- a/pkgs/plt-services/meta/pkg-build/extract-doc.rkt +++ /dev/null @@ -1,40 +0,0 @@ -#lang racket/base -(require racket/file - racket/format - setup/getinfo - setup/collection-name - file/unzip - pkg/strip) - -(provide extract-documentation) - -(define (extract-documentation zip pkg dest-dir) - (define temp-dir (make-temporary-file "docs~a" 'directory)) - (parameterize ([current-directory temp-dir]) - (unzip zip)) - (for ([d (in-directory temp-dir)]) - (cond - [(directory-exists? d) - (define i (get-info/full d - #:namespace (make-base-namespace) - #:bootstrap? #t)) - (when i - (define l (i 'scribblings (lambda () null))) - (when (list? l) - (for ([s (in-list l)]) - (when (and (list? s) - (pair? s) - (path-string? (car s)) - (or ((length s) . < . 4) - (collection-name-element? (list-ref s 3)))) - (define n (if ((length s) . < . 4) - (let-values ([(base name dir?) (split-path (car s))]) - (path->string (path-replace-suffix name #""))) - (list-ref s 3))) - (when (directory-exists? (build-path d "doc" n)) - (define doc-dest (build-path dest-dir (~a n "@" pkg))) - (copy-directory/files (build-path d "doc" n) - doc-dest) - (for ([p (in-directory doc-dest)]) - (when (regexp-match? #rx#"[.]html$" (path->bytes p)) - (fixup-local-redirect-reference p "../local-redirect"))))))))]))) diff --git a/pkgs/plt-services/meta/pkg-build/main.rkt b/pkgs/plt-services/meta/pkg-build/main.rkt deleted file mode 100644 index b1437badc9..0000000000 --- a/pkgs/plt-services/meta/pkg-build/main.rkt +++ /dev/null @@ -1,1392 +0,0 @@ -#lang racket/base -(require racket/cmdline - racket/file - racket/port - racket/format - racket/date - racket/list - racket/set - racket/string - racket/runtime-path - net/url - pkg/lib - file/untgz - file/tar - file/gzip - remote-shell/vbox - remote-shell/ssh - web-server/servlet-env - (only-in scribble/html a td tr #%top) - "download.rkt" - "union-find.rkt" - "thread.rkt" - "status.rkt" - "extract-doc.rkt" - "summary.rkt") - -(provide vbox-vm - build-pkgs - steps-in) - -(define-runtime-path pkg-list-rkt "pkg-list.rkt") -(define-runtime-path pkg-adds-rkt "pkg-adds.rkt") - -;; ---------------------------------------- - -;; Builds all packages from a given catalog and using a given snapshot. -;; The build of each package is isolated through a virtual machine, -;; and the result is both a set of built packages and a complete set -;; of documentation. -;; -;; To successfully build, a package must -;; - install without error -;; - correctly declare its dependencies (but may work, anyway, -;; if build order happens to accomodate) -;; - depend on packages that build successfully on their own -;; - refer only to other packages in the snapshot and catalog -;; (and, in particular, must not use PLaneT packages) -;; - build without special system libraries -;; -;; A successful build does not require that its declared dependencies -;; are complete if the needed packages end up installed, anyway, but -;; the declaraed dependencies are checked. -;; -;; Even when a build is unsuccessful, any documentation that is built -;; along the way is extracted, if possible. -;; -;; To do: -;; - tier-based selection of packages on conflict -;; - support for running tests - -(struct vm (name host user dir env init-snapshot installed-snapshot minimal-variant ssh-key)) - -;; Each VM must provide at least an ssh server and `tar`, and the -;; intent is that it is otherwise isolated (e.g., no network -;; connection except to the host) -(define (vbox-vm - ;; VirtualBox VM name: - #:name name - ;; IP address of VM (from host): - #:host host - ;; User for ssh login to VM: - #:user [user "racket"] - ;; Working directory on VM: - #:dir [dir "/home/racket/build-pkgs"] - ;; Enviornment variables as (list (cons ) ...) - #:env [env null] - ;; Name of a clean starting snapshot in the VM: - #:init-shapshot [init-snapshot "init"] - ;; An "installed" snapshot is created after installing Racket - ;; and before building any package: - #:installed-shapshot [installed-snapshot "installed"] - ;; If not #f, a `vm` that is more constrained and will be - ;; tried as an installation target before this one: - #:minimal-variant [minimal-variant #f] - ;; Path to ssh key to use to connect to this VM: - ;; #f indicates that ssh's defaults are used - #:ssh-key [ssh-key #f]) - (unless (complete-path? dir) - (error 'vbox-vm "need a complete path for #:dir")) - (vm name host user dir env init-snapshot installed-snapshot minimal-variant ssh-key)) - -;; The build steps: -(define all-steps-in-order - (list - ;; Download installer from snapshot site: - 'download - ;; Archive catalogs, downlowning the catalog and all - ;; packages to the working directory: - 'archive - ;; Install into each VM: - 'install - ;; Build packages that have changed: - 'build - ;; Extract and assemble documentation: - 'docs - ;; Build a result-summary file and web page: - 'summary - ;; Assemble web-friendly pieces to an archive: - 'site)) - -;; Return the subset of steps with `start` through `end` inclusive: -(define (steps-in start end) - (define l (member start all-steps-in-order)) - (if l - (let ([l (member end (reverse l))]) - (if l - (reverse l) - (if (member end all-steps-in-order) - (error 'steps-in "steps out of order: ~e and: ~e" start end) - (error 'steps-in "bad ending step: ~e" end)))) - (error 'steps-in "bad starting step: ~e" start))) - -(define (build-pkgs - ;; Besides a running Racket, the host machine must provide - ;; `ssh`, `scp`, and `VBoxManage`. - - ;; All local state is here, where state from a previous - ;; run is used to work incrementally: - #:work-dir [given-work-dir (current-directory)] - ;; Directory content: - ;; - ;; "installer/" --- holds installer downloaded - ;; from the snapshot site - ;; - ;; "install-list.rktd" --- list of packages found in - ;; the installation - ;; "install-adds.rktd" --- table of docs, libs, etc. - ;; in the installation (to detect conflicts) - ;; "install-doc.tgz" --- copy of installation's docs - ;; - ;; "server/archive" plus "state.sqlite" --- archived - ;; packages, taken from the snapshot site plus additional - ;; specified catalogs - ;; - ;; "server/built" --- built packages - ;; For a package P: - ;; * "pkgs/P.orig-CHECKSUM" matching archived catalog - ;; + "pkgs/P.zip" - ;; + "P.zip.CHECKSUM" - ;; => up-to-date and successful, - ;; "docs/P-adds.rktd" listing of docs, exes, etc., and - ;; "success/P.txt" records success; - ;; "install/P.txt" records installation; - ;; "deps/P.txt" records dependency-checking failure; - ;; "test-{success,fail}/P.txt" records `raco test` result; - ;; "min-fail/P.txt" records failure on minimal-host attempt; - ;; * pkgs/P.orig-CHECKSUM matching archived catalog - ;; + fail/P.txt - ;; => up-to-date and failed; - ;; "install/P.txt" may record installation success - ;; - ;; "dumpster/" --- saved builds of failed packages if the - ;; package at least installs; maybe the attempt built - ;; some documentation - ;; - ;; "doc/" --- unpacked docs with non-conflicting - ;; packages installed - ;; "all-doc.tgz" --- "doc", still packed - ;; - ;; "summary.rktd" --- summary of build results, a hash - ;; table mapping each package name to another hash table - ;; with the following keys: - ;; 'success-log --- #f or relative path - ;; 'failure-log --- #f or relative path - ;; 'dep-failure-log --- #f or relative path - ;; 'test-success-log --- #f or relative path - ;; 'test-failure-log --- #f or relative path - ;; 'min-failure-log --- #f or relative path - ;; 'docs --- list of one of - ;; * (docs/none name) - ;; * (docs/main name path) - ;; 'conflict-log --- #f, relative path, or - ;; (conflicts/indirect path) - ;; "index.html" (and "robots.txt", etc.) --- summary in - ;; web-page form - ;; - ;; A package is rebuilt if its checksum changes or if one of - ;; its declared dependencies changes. - - ;; URL to provide the installer and pre-built packages: - #:snapshot-url snapshot-url - ;; Name of platform for installer to get from snapshot: - #:installer-platform-name installer-platform-name - - ;; VirtualBox VMs (created by `vbox-vm`), at least one: - #:vms vms - - ;; Catalogs of packages to build (via an archive): - #:pkg-catalogs [pkg-catalogs (list "http://pkgs.racket-lang.org/")] - - ;; The Racket version to use in queries to archived catalogs; - ;; this version should be consistent with `snapshot-url`. - #:pkgs-for-version [pkgs-for-version (version)] - - ;; Extra packages to install within an installation so that - ;; they're treated like packages included in the installer; - ;; these should be built packages (normally from the snapshot - ;; site), or else the generated build packages will not work - ;; right (especially when using multiple VMs): - #:extra-packages [extra-packages null] - - ;; Steps that you want to include; you can skip steps - ;; at the beginning if you know they're already done, and - ;; you can skip tests at the end if you don't want them: - #:steps [steps (steps-in 'download 'summary)] - - ;; Run tests? - #:run-tests? [run-tests? #t] - - ;; Omit specified packages from the summary: - #:summary-omit-pkgs [summary-omit-pkgs null] - - ;; Timeout in seconds for any one package or step: - #:timeout [timeout 600] - - ;; Building more than one package at a time case be faster, - ;; but it risks success when a build should have failed due - ;; to missing dependencies, and it risks corruption due to - ;; especially broken or nefarious packages: - #:max-build-together [max-build-together 1] - - ;; Port to use on host machine for catalog server: - #:server-port [server-port 18333]) - - (unless (and (list? vms) - ((length vms) . >= . 1) - (andmap vm? vms)) - (error 'build-pkgs "expected a non-empty list of `vm`s")) - - (for ([step (in-list steps)]) - (unless (member step all-steps-in-order) - (error 'build-pkgs "bad step: ~e" step))) - - (define skip-download? (not (member 'download steps))) - (define skip-install? (not (member 'install steps))) - (define skip-archive? (not (member 'archive steps))) - (define skip-build? (not (member 'build steps))) - (define skip-docs? (not (member 'docs steps))) - (define skip-summary? (not (member 'summary steps))) - (define skip-site? (not (member 'site steps))) - - (define work-dir (path->complete-path given-work-dir)) - (define installer-dir (build-path work-dir "installer")) - (define server-dir (build-path work-dir "server")) - (define archive-dir (build-path server-dir "archive")) - (define state-file (build-path work-dir "state.sqlite")) - - (define built-dir (build-path server-dir "built")) - (define built-pkgs-dir (build-path built-dir "pkgs/")) - (define built-catalog-dir (build-path built-dir "catalog")) - (define fail-dir (build-path built-dir "fail")) - (define min-fail-dir (build-path built-dir "min-fail")) - (define success-dir (build-path built-dir "success")) - (define install-success-dir (build-path built-dir "install")) - (define deps-fail-dir (build-path built-dir "deps")) - (define test-success-dir (build-path built-dir "test-success")) - (define test-fail-dir (build-path built-dir "test-fail")) - - (define dumpster-dir (build-path work-dir "dumpster")) - (define dumpster-pkgs-dir (build-path dumpster-dir "pkgs/")) - (define dumpster-adds-dir (build-path dumpster-dir "adds")) - - (define doc-dir (build-path work-dir "doc")) - - (define (txt s) (~a s ".txt")) - - (define snapshot-catalog - (url->string - (combine-url/relative (string->url snapshot-url) - "catalog/"))) - - (make-directory* work-dir) - - ;; ---------------------------------------- - - (define (q s) - (~a "\"" s "\"")) - - (define (at-vm vm dest) - (at-remote (vm-remote vm) dest)) - - (define (cd-racket vm) (~a "cd " (q (vm-dir vm)) "/racket")) - - (define (vm-remote vm) - (remote #:host (vm-host vm) - #:user (vm-user vm) - #:env (append - (vm-env vm) - (list (cons "PLTUSERHOME" - (~a (vm-dir vm) "/user")))) - #:key (vm-ssh-key vm) - #:timeout timeout - #:remote-tunnels (list (cons server-port server-port)))) - - (define (make-sure-vm-is-ready vm rt) - (make-sure-remote-is-ready rt) - (status "Fixing time at ~a\n" (vm-name vm)) - (ssh rt "sudo date --set=" (q (parameterize ([date-display-format 'rfc2822]) - (date->string (seconds->date (current-seconds)) #t))))) - - ;; ---------------------------------------- - (define installer-table-path (build-path work-dir "table.rktd")) - (unless skip-download? - (status "Getting installer table\n") - (define table (call/input-url - (combine-url/relative (string->url snapshot-url) - "installers/table.rktd") - get-pure-port - (lambda (i) (read i)))) - (call-with-output-file* - installer-table-path - #:exists 'truncate/replace - (lambda (o) (write table o) (newline o)))) - - (define installer-name (hash-ref - (call-with-input-file* - installer-table-path - read) - installer-platform-name)) - (substatus "Installer is ~a\n" installer-name) - - ;; ---------------------------------------- - (unless skip-download? - (status "Downloading installer ~a\n" installer-name) - (download-installer snapshot-url installer-dir installer-name substatus)) - - ;; ---------------------------------------- - (unless skip-archive? - (status "Archiving packages from\n") - (show-list (cons snapshot-catalog pkg-catalogs)) - (make-directory* archive-dir) - (parameterize ([current-pkg-lookup-version pkgs-for-version]) - (pkg-catalog-archive archive-dir - (cons snapshot-catalog pkg-catalogs) - #:state-catalog state-file - #:relative-sources? #t - #:package-exn-handler (lambda (name exn) - (log-error "~a\nSKIPPING ~a" - (exn-message exn) - name))))) - - (define snapshot-pkg-names - (parameterize ([current-pkg-catalogs (list (string->url snapshot-catalog))]) - (get-all-pkg-names-from-catalogs))) - - (define all-pkg-names - (parameterize ([current-pkg-catalogs (list (path->url (build-path archive-dir "catalog")))]) - (get-all-pkg-names-from-catalogs))) - - (define pkg-details - (parameterize ([current-pkg-catalogs (list (path->url (build-path archive-dir "catalog")))]) - (get-all-pkg-details-from-catalogs))) - - ;; ---------------------------------------- - (status "Starting server at locahost:~a for ~a\n" server-port archive-dir) - - (define server - (thread - (lambda () - (serve/servlet - (lambda args #f) - #:command-line? #t - #:listen-ip "localhost" - #:extra-files-paths (list server-dir) - #:servlet-regexp #rx"$." ; never match - #:port server-port)))) - (sync (system-idle-evt)) - - ;; ---------------------------------------- - (define (install vm #:one-time? [one-time? #f]) - (status "Starting VM ~a\n" (vm-name vm)) - (stop-vbox-vm (vm-name vm)) - (restore-vbox-snapshot (vm-name vm) (vm-init-snapshot vm)) - - (dynamic-wind - (lambda () (start-vbox-vm (vm-name vm))) - (lambda () - (define rt (vm-remote vm)) - (make-sure-vm-is-ready vm rt) - - ;; ---------------------------------------- - (define there-dir (vm-dir vm)) - (status "Preparing directory ~a\n" there-dir) - (ssh rt "rm -rf " (~a (q there-dir) "/*")) - (ssh rt "mkdir -p " (q there-dir)) - (ssh rt "mkdir -p " (q (~a there-dir "/user"))) - (ssh rt "mkdir -p " (q (~a there-dir "/built"))) - - (scp rt (build-path installer-dir installer-name) (at-vm vm there-dir)) - - (ssh rt "cd " (q there-dir) " && " " sh " (q installer-name) " --in-place --dest ./racket") - - ;; VM-side helper modules: - (scp rt pkg-adds-rkt (at-vm vm (~a there-dir "/pkg-adds.rkt"))) - (scp rt pkg-list-rkt (at-vm vm (~a there-dir "/pkg-list.rkt"))) - - ;; ---------------------------------------- - (status "Setting catalogs at ~a\n" (vm-name vm)) - (ssh rt (cd-racket vm) - " && bin/raco pkg config -i --set catalogs " - " http://localhost:" (~a server-port) "/built/catalog/" - " http://localhost:" (~a server-port) "/archive/catalog/") - - ;; ---------------------------------------- - (unless (null? extra-packages) - (status "Extra package installs at ~a\n" (vm-name vm)) - (ssh rt (cd-racket vm) - " && bin/raco pkg install -i --auto" - " " (apply ~a #:separator " " extra-packages))) - - (when one-time? - ;; ---------------------------------------- - (status "Getting installed packages\n") - (ssh rt (cd-racket vm) - " && bin/racket ../pkg-list.rkt > ../pkg-list.rktd") - (scp rt (at-vm vm (~a there-dir "/pkg-list.rktd")) - (build-path work-dir "install-list.rktd")) - - ;; ---------------------------------------- - (status "Stashing installation docs\n") - (ssh rt (cd-racket vm) - " && bin/racket ../pkg-adds.rkt --all > ../pkg-adds.rktd") - (ssh rt (cd-racket vm) - " && tar zcf ../install-doc.tgz doc") - (scp rt (at-vm vm (~a there-dir "/pkg-adds.rktd")) - (build-path work-dir "install-adds.rktd")) - (scp rt (at-vm vm (~a there-dir "/install-doc.tgz")) - (build-path work-dir "install-doc.tgz"))) - - (void)) - (lambda () - (stop-vbox-vm (vm-name vm)))) - - ;; ---------------------------------------- - (status "Taking installation snapshopt\n") - (when (exists-vbox-snapshot? (vm-name vm) (vm-installed-snapshot vm)) - (delete-vbox-snapshot (vm-name vm) (vm-installed-snapshot vm))) - (take-vbox-snapshot (vm-name vm) (vm-installed-snapshot vm))) - - (unless skip-install? - (for ([vm (in-list vms)] - [i (in-naturals)]) - (install vm #:one-time? (zero? i)) - (when (vm-minimal-variant vm) - (install (vm-minimal-variant vm))))) - - ;; ---------------------------------------- - (status "Resetting ready content of ~a\n" built-pkgs-dir) - - (make-directory* built-pkgs-dir) - - (define installed-pkg-names - (call-with-input-file* (build-path work-dir "install-list.rktd") read)) - - (substatus "Total number of packages: ~a\n" (length all-pkg-names)) - (substatus "Packages installed already: ~a\n" (length installed-pkg-names)) - - (define snapshot-pkgs (list->set snapshot-pkg-names)) - (define installed-pkgs (list->set installed-pkg-names)) - - (define try-pkgs (set-subtract (list->set all-pkg-names) - installed-pkgs)) - - (define (pkg-checksum pkg) (hash-ref (hash-ref pkg-details pkg) 'checksum "")) - (define (pkg-author pkg) (hash-ref (hash-ref pkg-details pkg) 'author "")) - (define (pkg-checksum-file pkg) (build-path built-pkgs-dir (~a pkg ".orig-CHECKSUM"))) - (define (pkg-zip-file pkg) (build-path built-pkgs-dir (~a pkg ".zip"))) - (define (pkg-zip-checksum-file pkg) (build-path built-pkgs-dir (~a pkg ".zip.CHECKSUM"))) - (define (pkg-failure-dest pkg #:minimal? [min? #f]) - (build-path (if min? min-fail-dir fail-dir) (txt pkg))) - (define (pkg-test-success-dest pkg) (build-path test-success-dir (txt pkg))) - (define (pkg-test-failure-dest pkg) (build-path test-fail-dir (txt pkg))) - - (define failed-pkgs - (for/set ([pkg (in-list all-pkg-names)] - #:when - (let () - (define checksum (pkg-checksum pkg)) - (define checksum-file (pkg-checksum-file pkg)) - (and (file-exists? checksum-file) - (equal? checksum (file->string checksum-file)) - (not (set-member? installed-pkgs pkg)) - (file-exists? (pkg-failure-dest pkg))))) - pkg)) - - (define changed-pkgs - (for/set ([pkg (in-list all-pkg-names)] - #:unless - (let () - (define checksum (pkg-checksum pkg)) - (define checksum-file (pkg-checksum-file pkg)) - (and (file-exists? checksum-file) - (equal? checksum (file->string checksum-file)) - (or (set-member? installed-pkgs pkg) - (file-exists? (pkg-failure-dest pkg)) - (and - (file-exists? (pkg-zip-file pkg)) - (file-exists? (pkg-zip-checksum-file pkg))))))) - pkg)) - - (define (pkg-deps pkg) - (map (lambda (dep) - (define d (if (string? dep) dep (car dep))) - (if (equal? d "racket") "base" d)) - (hash-ref (hash-ref pkg-details pkg) 'dependencies null))) - - (define update-pkgs - (let loop ([update-pkgs changed-pkgs]) - (define more-pkgs - (for/set ([pkg (in-set try-pkgs)] - #:when (and (not (set-member? update-pkgs pkg)) - (for/or ([dep (in-list (pkg-deps pkg))]) - (set-member? update-pkgs dep)))) - pkg)) - (if (set-empty? more-pkgs) - update-pkgs - (loop (set-union more-pkgs update-pkgs))))) - - ;; Remove any ".zip[.CHECKSUM]" for packages that need to be built - (for ([pkg (in-set update-pkgs)]) - (define checksum-file (pkg-checksum-file pkg)) - (when (file-exists? checksum-file) (delete-file checksum-file)) - (define zip-file (pkg-zip-file pkg)) - (when (file-exists? zip-file) (delete-file zip-file)) - (define zip-checksum-file (pkg-zip-checksum-file pkg)) - (when (file-exists? zip-checksum-file) (delete-file zip-checksum-file))) - - ;; For packages in the installation, remove any ".zip[.CHECKSUM]" and set ".orig-CHECKSUM" - (for ([pkg (in-set installed-pkgs)]) - (define checksum-file (pkg-checksum-file pkg)) - (define zip-file (pkg-zip-file pkg)) - (define zip-checksum-file (pkg-zip-checksum-file pkg)) - (define failure-dest (pkg-failure-dest pkg)) - (define min-failure-dest (pkg-failure-dest pkg #:minimal? #t)) - (when (file-exists? zip-file) (delete-file zip-file)) - (when (file-exists? zip-checksum-file) (delete-file zip-checksum-file)) - (when (file-exists? failure-dest) (delete-file failure-dest)) - (when (file-exists? min-failure-dest) (delete-file min-failure-dest)) - (call-with-output-file* - checksum-file - #:exists 'truncate/replace - (lambda (o) - (write-string (pkg-checksum pkg) o)))) - - (define need-pkgs (set-subtract (set-subtract update-pkgs installed-pkgs) - failed-pkgs)) - - (define cycles (make-hash)) ; for union-find - - ;; Sort needed packages based on dependencies, and accumulate cycles: - (define need-rep-pkgs-list - (let loop ([l (sort (set->list need-pkgs) stringset pre))) - (define remainder (loop (cdr l) pre-seen cycle-stack)) - (elect! cycles pkg) ; in case of mutual dependency, follow all pre-reqs - (append pre (cons pkg remainder))]))))) - - ;; A list that contains strings and lists of strings, where a list - ;; of strings represents mutually dependent packages: - (define need-pkgs-list - (let ([reps (make-hash)]) - (for ([pkg (in-set need-pkgs)]) - (hash-update! reps (find! cycles pkg) (lambda (l) (cons pkg l)) null)) - (for/list ([pkg (in-list need-rep-pkgs-list)] - #:when (equal? pkg (find! cycles pkg))) - (define pkgs (hash-ref reps pkg)) - (if (= 1 (length pkgs)) - pkg - pkgs)))) - - (substatus "Packages that we need:\n") - (show-list need-pkgs-list) - - ;; ---------------------------------------- - (status "Preparing built catalog at ~a\n" built-catalog-dir) - - (define (update-built-catalog given-pkgs) - ;; Don't shadow anything from the catalog, even if we "built" it to - ;; get documentation: - (define pkgs (filter (lambda (pkg) (not (set-member? snapshot-pkgs pkg))) - given-pkgs)) - ;; Generate info for each now-built package: - (define hts (for/list ([pkg (in-list pkgs)]) - (let* ([ht (hash-ref pkg-details pkg)] - [ht (hash-set ht 'source (~a "../pkgs/" pkg ".zip"))] - [ht (hash-set ht 'checksum - (file->string (build-path built-pkgs-dir - (~a pkg ".zip.CHECKSUM"))))]) - ht))) - (for ([pkg (in-list pkgs)] - [ht (in-list hts)]) - (call-with-output-file* - (build-path built-catalog-dir "pkg" pkg) - (lambda (o) (write ht o) (newline o)))) - (define old-all (call-with-input-file* (build-path built-catalog-dir "pkgs-all") read)) - (define all - (for/fold ([all old-all]) ([pkg (in-list pkgs)] - [ht (in-list hts)]) - (hash-set all pkg ht))) - (call-with-output-file* - (build-path built-catalog-dir "pkgs-all") - #:exists 'truncate/replace - (lambda (o) - (write all o) - (newline o))) - (call-with-output-file* - (build-path built-catalog-dir "pkgs") - #:exists 'truncate/replace - (lambda (o) - (write (hash-keys all) o) - (newline o)))) - - (delete-directory/files built-catalog-dir #:must-exist? #f) - (make-directory* built-catalog-dir) - (make-directory* (build-path built-catalog-dir "pkg")) - (call-with-output-file* - (build-path built-catalog-dir "pkgs-all") - (lambda (o) (displayln "#hash()" o))) - (call-with-output-file* - (build-path built-catalog-dir "pkgs") - (lambda (o) (displayln "()" o))) - (update-built-catalog (set->list (set-subtract - (set-subtract try-pkgs need-pkgs) - failed-pkgs))) - - ;; ---------------------------------------- - (make-directory* (build-path built-dir "adds")) - (make-directory* fail-dir) - (make-directory* min-fail-dir) - (make-directory* success-dir) - (make-directory* install-success-dir) - (make-directory* deps-fail-dir) - (make-directory* test-success-dir) - (make-directory* test-fail-dir) - - (make-directory* dumpster-pkgs-dir) - (make-directory* dumpster-adds-dir) - - (define (pkg-adds-file pkg) - (build-path built-dir "adds" (format "~a-adds.rktd" pkg))) - - (define (complain failure-dest fmt . args) - (when failure-dest - (call-with-output-file* - failure-dest - #:exists 'truncate/replace - (lambda (o) (apply fprintf o fmt args)))) - (apply eprintf fmt args) - #f) - - ;; Print status and munge a list-of-list-of-packages: - (define (status-pkgs pkgs action) - (define flat-pkgs (flatten pkgs)) - ;; one-pkg can be a list in the case of mutual dependencies: - (define one-pkg (and (= 1 (length pkgs)) (car pkgs))) - (define pkgs-str (apply ~a #:separator " " flat-pkgs)) - - (status (~a (make-string 40 #\=) "\n")) - (if one-pkg - (if (pair? one-pkg) - (begin - (status "~a mutually dependent packages:\n" action) - (show-list one-pkg)) - (status "~a ~a\n" action one-pkg)) - (begin - (status "~a packages together:\n" action) - (show-list pkgs))) - - (values flat-pkgs one-pkg pkgs-str)) - - ;; Build one package or a group of packages: - (define (build-pkgs vm pkgs #:minimal? [minimal? #f]) - (define-values (flat-pkgs one-pkg pkgs-str) - (status-pkgs pkgs "Building")) - - (define failure-dest (and one-pkg - (pkg-failure-dest (car flat-pkgs) #:minimal? minimal?))) - (define install-success-dest (build-path install-success-dir - (txt (car flat-pkgs)))) - - (define (pkg-deps-failure-dest pkg) - (build-path deps-fail-dir (txt pkg))) - (define deps-failure-dest (and one-pkg - (pkg-deps-failure-dest (car flat-pkgs)))) - - (define (save-checksum pkg) - (call-with-output-file* - (build-path built-pkgs-dir (~a pkg ".orig-CHECKSUM")) - #:exists 'truncate/replace - (lambda (o) (write-string (pkg-checksum pkg) o)))) - - (define there-dir (vm-dir vm)) - - (for ([pkg (in-list flat-pkgs)]) - (define f (build-path install-success-dir (txt pkg))) - (when (file-exists? f) (delete-file f))) - - (restore-vbox-snapshot (vm-name vm) (vm-installed-snapshot vm)) - (dynamic-wind - (lambda () (start-vbox-vm (vm-name vm) #:max-vms (length vms))) - (lambda () - (define rt (vm-remote vm)) - (make-sure-vm-is-ready vm rt) - (define ok? - (and - ;; Try to install: - (ssh #:show-time? #t - rt (cd-racket vm) - " && bin/raco pkg install -u --auto" - (if one-pkg "" " --fail-fast") - " " pkgs-str - #:mode 'result - #:failure-log failure-dest - #:success-log install-success-dest) - ;; Copy success log for other packages in the group: - (for ([pkg (in-list (cdr flat-pkgs))]) - (copy-file install-success-dest - (build-path install-success-dir (txt pkg)) - #t)) - (let () - ;; Make sure that any extra installed packages used were previously - ;; built, since we want built packages to be consistent with a binary - ;; installation. - (ssh #:show-time? #t - rt (cd-racket vm) - " && bin/racket ../pkg-list.rkt --user > ../user-list.rktd") - (scp rt (at-vm vm (~a there-dir "/user-list.rktd")) - (build-path work-dir "user-list.rktd")) - (define new-pkgs (call-with-input-file* - (build-path work-dir "user-list.rktd") - read)) - (for/and ([pkg (in-list new-pkgs)]) - (or (member pkg flat-pkgs) - (set-member? installed-pkgs pkg) - (file-exists? (build-path built-catalog-dir "pkg" pkg)) - (complain failure-dest - (~a "use of package not previously built: ~s;\n" - " maybe a dependency is missing, or maybe the package\n" - " failed to build on its own\n") - pkg)))))) - (define deps-ok? - (and ok? - (ssh #:show-time? #t - rt (cd-racket vm) - " && bin/raco setup -nxiID --check-pkg-deps --pkgs " - " " pkgs-str - #:mode 'result - #:failure-log deps-failure-dest))) - (when (and ok? one-pkg (not deps-ok?)) - ;; Copy dependency-failure log for other packages in the group: - (for ([pkg (in-list (cdr flat-pkgs))]) - (copy-file deps-failure-dest - (pkg-deps-failure-dest pkg) - #t))) - (define doc-ok? - (and - (or ok? (not minimal?)) - ;; If we're building a single package (or set of mutually - ;; dependent packages), then try to save generated documentation - ;; even on failure. We'll put it in the "dumpster". - (or ok? one-pkg) - (ssh rt (cd-racket vm) - " && bin/racket ../pkg-adds.rkt " pkgs-str - " > ../pkg-adds.rktd" - #:mode 'result - #:failure-log (and ok? failure-dest)) - (for/and ([pkg (in-list flat-pkgs)]) - (ssh rt (cd-racket vm) - " && bin/raco pkg create --from-install --built" - " --dest " there-dir "/built" - " " pkg - #:mode 'result - #:failure-log (and ok? failure-dest))))) - (cond - [(and ok? doc-ok? (or deps-ok? one-pkg)) - (for ([pkg (in-list flat-pkgs)]) - (when (file-exists? (pkg-failure-dest pkg)) - (delete-file (pkg-failure-dest pkg))) - (when (and minimal? - (file-exists? (pkg-failure-dest pkg #:minimal? #t))) - (delete-file (pkg-failure-dest pkg #:minimal? #t))) - (when (and deps-ok? (file-exists? (pkg-deps-failure-dest pkg))) - (delete-file (pkg-deps-failure-dest pkg))) - (when (file-exists? (pkg-test-failure-dest pkg)) - (delete-file (pkg-test-failure-dest pkg))) - (when (file-exists? (pkg-test-success-dest pkg)) - (delete-file (pkg-test-success-dest pkg))) - (scp rt (at-vm vm (~a there-dir "/built/" pkg ".zip")) - built-pkgs-dir) - (scp rt (at-vm vm (~a there-dir "/built/" pkg ".zip.CHECKSUM")) - built-pkgs-dir) - (scp rt (at-vm vm (~a there-dir "/pkg-adds.rktd")) - (build-path built-dir "adds" (format "~a-adds.rktd" pkg))) - (define deps-msg (if deps-ok? "" ", but problems with dependency declarations")) - (call-with-output-file* - (build-path success-dir (txt pkg)) - #:exists 'truncate/replace - (lambda (o) - (if one-pkg - (fprintf o "success~a\n" deps-msg) - (fprintf o "success with ~s~a\n" pkgs deps-msg)))) - (save-checksum pkg)) - (update-built-catalog flat-pkgs)] - [else - (when one-pkg - ;; Record failure (for all docs in a mutually dependent set): - (for ([pkg (in-list flat-pkgs)]) - (when (list? one-pkg) - (unless (equal? pkg (car one-pkg)) - (copy-file failure-dest - (pkg-failure-dest (car one-pkg) #:minimal? minimal?) - #t))) - (save-checksum pkg)) - ;; Keep any docs that might have been built: - (for ([pkg (in-list flat-pkgs)]) - (scp rt (at-vm vm (~a there-dir "/built/" pkg ".zip")) - dumpster-pkgs-dir - #:mode 'result) - (scp rt (at-vm vm (~a there-dir "/built/" pkg ".zip.CHECKSUM")) - dumpster-pkgs-dir - #:mode 'result) - (scp rt (at-vm vm (~a there-dir "/pkg-adds.rktd")) - (build-path dumpster-adds-dir (format "~a-adds.rktd" pkg)) - #:mode 'result))) - (substatus "*** failed ***\n")]) - ok?) - (lambda () - (stop-vbox-vm (vm-name vm) #:save-state? #f)))) - - ;; Test one package or a group of packages: - (define (test-pkgs vm pkgs) - ;; If we get interrupted or something goes wrong here, we may - ;; leave a package in a built-but-not-tested state. - (define-values (flat-pkgs one-pkg pkgs-str) - (status-pkgs pkgs "Testing")) - - (define test-success-dest (pkg-test-success-dest (car flat-pkgs))) - (define test-failure-dest (pkg-test-failure-dest (car flat-pkgs))) - - (restore-vbox-snapshot (vm-name vm) (vm-installed-snapshot vm)) - (dynamic-wind - (lambda () (start-vbox-vm (vm-name vm) #:max-vms (length vms))) - (lambda () - (define rt (vm-remote vm)) - (make-sure-vm-is-ready vm rt) - (define test-ok? - (ssh #:show-time? #t - rt (cd-racket vm) - " && bin/raco pkg install -u --auto " pkgs-str - " && bin/raco test --drdr --package " pkgs-str - #:mode 'result - #:success-log test-success-dest - #:failure-log test-failure-dest)) - - (define remove-dest (if test-ok? - pkg-test-failure-dest - pkg-test-success-dest)) - (define copy-dest (if test-ok? - pkg-test-success-dest - pkg-test-failure-dest)) - (for ([pkg (in-list flat-pkgs)]) - (when (file-exists? (remove-dest pkg)) - (delete-file (remove-dest pkg)))) - (when one-pkg - ;; Copy test-failure log for other packages in the group: - (for ([pkg (in-list (cdr flat-pkgs))]) - (copy-file (if test-ok? - test-success-dest - test-failure-dest) - (copy-dest pkg) - #t))) - - (cond - [test-ok? (void)] - [else (substatus "*** test failed ***\n")]) - test-ok?) - (lambda () - (stop-vbox-vm (vm-name vm) #:save-state? #f)))) - - ;; Build and test a group of packages, recurring on smaller groups - ;; if the big group fails: - (define (build-pkg-set vm pkgs) - (define len (length pkgs)) - (define has-minimal? (and (vm-minimal-variant vm) #t)) - (define ok? (and (len . <= . max-build-together) - (or - ;; Here's the main build attempt: - (build-pkgs (if has-minimal? - (vm-minimal-variant vm) - vm) - pkgs - #:minimal? has-minimal?) - ;; ... but if that was minimal, try again - ;; with the non-minimal variant: - (and has-minimal? - (build-pkgs vm pkgs #:minimal? #f))))) - (when (and ok? run-tests?) - ;; Testing always uses the non-minimal variant: - (test-pkgs vm pkgs)) - (flush-chunk-output) - (unless (or ok? (= 1 len)) - (define part (min (quotient len 2) - max-build-together)) - (build-pkg-set vm (take pkgs part)) - (build-pkg-set vm (drop pkgs part)))) - - ;; Look for n packages whose dependencies are ready: - (define (select-n n pkgs pending-pkgs) - (cond - [(zero? n) null] - [(null? pkgs) null] - [else - (define pkg (car pkgs)) ; `pkg` can be a list of strings - ;; Check for dependencies in `pending-pkgs`, but - ;; we don't have to check dependencies transtively, - ;; because the ordering of `pkgs` takes care of that. - (cond - [(ormap (lambda (dep) (set-member? pending-pkgs dep)) - (if (string? pkg) - (pkg-deps pkg) - (apply append (map pkg-deps pkg)))) - (select-n n (cdr pkgs) pending-pkgs)] - [else - (cons pkg - (select-n (sub1 n) (cdr pkgs) pending-pkgs))])])) - - ;; try-pkgs has the same order as `pkgs`: - (define (remove-ordered try-pkgs pkgs) - (cond - [(null? try-pkgs) pkgs] - [(equal? (car try-pkgs) (car pkgs)) - (remove-ordered (cdr try-pkgs) (cdr pkgs))] - [else - (cons (car pkgs) (remove-ordered try-pkgs (cdr pkgs)))])) - - (struct running (vm pkgs th done?-box) - #:property prop:evt (lambda (r) - (wrap-evt (running-th r) - (lambda (v) r)))) - (define (start-running vm pkgs) - (define done?-box (box #f)) - (define t (thread/chunk-output - (lambda () - (break-enabled #t) - (status "Sending to ~a~a:\n" - (vm-name vm) - (if (vm-minimal-variant vm) - (~a " / " (vm-name (vm-minimal-variant vm))) - "")) - (show-list pkgs) - (flush-chunk-output) - (build-pkg-set vm pkgs) - (set-box! done?-box #t)))) - (running vm pkgs t done?-box)) - - (define (break-running r) - (break-thread (running-th r)) - (sync (running-th r))) - - ;; Build a group of packages, trying smaller - ;; groups if the whole group fails or is too - ;; big: - (define (build-all-pkgs pkgs) - ;; pkgs is a list of string and lists (for mutual dependency) - (let loop ([pkgs pkgs] - [pending-pkgs (list->set pkgs)] - [vms vms] - [runnings null] - [error? #f]) - (define (wait) - (define r - (with-handlers ([exn:break? (lambda (exn) - (log-error "breaking...") - (for-each break-running runnings) - (wait-chunk-output) - (raise exn))]) - (parameterize-break - #t - (apply sync runnings)))) - (loop pkgs - (set-subtract pending-pkgs (list->set (running-pkgs r))) - (cons (running-vm r) vms) - (remq r runnings) - (or error? (not (unbox (running-done?-box r)))))) - (cond - [error? - (if (null? runnings) - (error "a build task ended prematurely") - (wait))] - [(and (null? pkgs) - (null? runnings)) - ;; Done - (void)] - [(null? vms) - ;; All VMs busy; wait for one to finish - (wait)] - [else - (define try-pkgs (select-n max-build-together pkgs pending-pkgs)) - (cond - [(null? try-pkgs) - ;; Nothing to do until a dependency finished; wait - (wait)] - [else - (loop (remove-ordered try-pkgs pkgs) - pending-pkgs - (cdr vms) - (cons (start-running (car vms) try-pkgs) - runnings) - error?)])]))) - - ;; Build all of the out-of-date packages: - (unless skip-build? - (if (= 1 (length vms)) - ;; Sequential builds: - (build-pkg-set (car vms) need-pkgs-list) - ;; Parallel builds: - (parameterize-break - #f - (build-all-pkgs need-pkgs-list)))) - - ;; ---------------------------------------- - (status "Assembling documentation\n") - - (define available-pkgs - (for/set ([pkg (in-list all-pkg-names)] - #:when - (let () - (define checksum (pkg-checksum pkg)) - (define checksum-file (pkg-checksum-file pkg)) - (and (file-exists? checksum-file) - (file-exists? (pkg-zip-file pkg)) - (file-exists? (pkg-zip-checksum-file pkg))))) - pkg)) - - (define adds-pkgs - (for/hash ([pkg (in-set available-pkgs)]) - (define adds-file (pkg-adds-file pkg)) - (define ht (call-with-input-file* adds-file read)) - (values pkg (hash-ref ht pkg null)))) - - (define doc-pkgs - (for/set ([(k l) (in-hash adds-pkgs)] - #:when (for/or ([v (in-list l)]) - (eq? (car v) 'doc))) - k)) - - (define doc-pkg-list - (sort (set->list doc-pkgs) string . 1)) - (cons k v))) - (cond - [(null? conflicts) - (values (set) available-pkgs)] - [else - (define (show-conflicts) - (substatus "Install conflicts:\n") - (for ([v (in-list conflicts)]) - (substatus " ~a ~s:\n" (caar v) (cdar v)) - (show-list #:indent " " (sort (set->list (cdr v)) stringlist disallowed-pkgs) stringset doc-pkg-list) no-conflict-pkgs)) - (define no-conflict-doc-pkg-list (sort (set->list no-conflict-doc-pkgs) stringrelative p) - (define work (explode-path work-dir)) - (define dest (explode-path p)) - (unless (equal? work (take dest (length work))) - (error "not relative")) - (string-join (map path->string (drop dest (length work))) "/")) - - (define summary-ht - (for/hash ([pkg (in-set (set-subtract try-pkgs - (list->set summary-omit-pkgs)))]) - (define failed? (file-exists? (pkg-failure-dest pkg))) - (define succeeded? (file-exists? (build-path install-success-dir (txt pkg)))) - (define status - (cond - [(and failed? (not succeeded?)) 'failure] - [(and succeeded? (not failed?)) 'success] - [(and succeeded? failed?) 'confusion] - [else 'unknown])) - (define (more-status dir [success-dir #f]) - (if (eq? status 'success) - (if (file-exists? (build-path dir (txt pkg))) - 'failure - (if (or (not success-dir) - (file-exists? (build-path success-dir (txt pkg)))) - 'success - 'unknown)) - 'unknown)) - (define dep-status (more-status deps-fail-dir)) - (define test-status (more-status test-fail-dir test-success-dir)) - (define min-status (more-status min-fail-dir)) - (define adds (let ([adds-file (if (eq? status 'success) - (pkg-adds-file pkg) - (build-path dumpster-adds-dir (format "~a-adds.rktd" pkg)))]) - (if (file-exists? adds-file) - (hash-ref (call-with-input-file* adds-file read) - pkg - null) - null))) - (define conflicts? (and (eq? status 'success) - (not (set-member? no-conflict-pkgs pkg)))) - (define docs (for/list ([add (in-list adds)] - #:when (eq? (car add) 'doc)) - (cdr add))) - (values - pkg - (hash 'success-log (and (or (eq? status 'success) - (eq? status 'confusion)) - (path->relative (build-path install-success-dir (txt pkg)))) - 'failure-log (and (or (eq? status 'failure) - (eq? status 'confusion)) - (path->relative (pkg-failure-dest pkg))) - 'dep-failure-log (and (eq? dep-status 'failure) - (path->relative (build-path deps-fail-dir (txt pkg)))) - 'test-success-log (and (eq? test-status 'success) - (path->relative (build-path test-success-dir (txt pkg)))) - 'test-failure-log (and (eq? test-status 'failure) - (path->relative (build-path test-fail-dir (txt pkg)))) - 'min-failure-log (and (eq? min-status 'failure) - (path->relative (build-path min-fail-dir (txt pkg)))) - 'docs (for/list ([doc (in-list docs)]) - (define path (~a "doc/" (~a doc "@" pkg) "/index.html")) - (if (or (not (eq? status 'success)) - conflicts?) - (if (directory-exists? (build-path doc-dir (~a doc "@" pkg))) - (if (set-member? available-pkgs pkg) - (doc/extract doc path) - (doc/salvage doc path)) - (doc/none doc)) - (doc/main doc path))) - 'author (pkg-author pkg) - 'conflicts-log (and conflicts? - (if (set-member? conflict-pkgs pkg) - "conflicts.txt" - (conflicts/indirect "conflicts.txt"))))))) - - ;; Add info for docs in the installer: - (define full-summary-ht - (for/fold ([ht summary-ht]) ([pkg (in-set install-doc-pkgs)]) - (define docs (for/list ([a (in-list (hash-ref install-adds-pkgs pkg))] - #:when (eq? 'doc (car a))) - (define doc (cdr a)) - (define path (~a "doc/" (~a doc "@" pkg) "/index.html")) - (doc/main doc path))) - (hash-set ht pkg (hash 'docs docs)))) - - (call-with-output-file* - (build-path work-dir "summary.rktd") - #:exists 'truncate/replace - (lambda (o) - (write full-summary-ht o) - (newline o))) - - (summary-page summary-ht work-dir)) - - ;; ---------------------------------------- - - (unless skip-site? - (define site-file (build-path work-dir "site.tgz")) - (status "Packing site to ~a\n" site-file) - - (define (wpath . a) (apply build-path work-dir a)) - (define skip-paths (set (wpath "installer") - (wpath "server" "archive") - (wpath "server" "built" "catalog") - (wpath "server" "built" "pkgs") - (wpath "server" "built" "adds") - (wpath "dumpster") - (wpath "table.rktd") - (wpath "state.sqlite") - (wpath "all-doc.tgz") - (wpath "install-doc.tgz") - (wpath "install-adds.rktd") - (wpath "user-list.rktd") - (wpath "prev-doc") - (wpath "old-prev-doc") - (wpath "doc" "docindex.sqlite") - (wpath "site.tgz"))) - (parameterize ([current-directory work-dir]) - (define files (for/list ([f (in-directory #f (lambda (p) - (not (set-member? skip-paths p))))] - #:unless (set-member? skip-paths (path->complete-path f))) - f)) - (call-with-output-file* - site-file - #:exists 'truncate/replace - (lambda (o) - (define-values (i2 o2) (make-pipe 40960)) - (thread (lambda () - (dynamic-wind - void - (lambda () (tar->output files o2)) - (lambda () (close-output-port o2))))) - (gzip-through-ports i2 o #f (current-seconds)))))) - - ;; ---------------------------------------- - - (void)) diff --git a/pkgs/plt-services/meta/pkg-build/pkg-adds.rkt b/pkgs/plt-services/meta/pkg-build/pkg-adds.rkt deleted file mode 100644 index 516e386f0a..0000000000 --- a/pkgs/plt-services/meta/pkg-build/pkg-adds.rkt +++ /dev/null @@ -1,33 +0,0 @@ -#lang racket/base -(require racket/cmdline - pkg/lib) - -;; This module is copied to the virtual machine to extract -;; a package -> documentation mapping. - -(define all-pkgs? #f) - -(define want-pkgs - (command-line - #:once-each - [("--all") "All packages" - (set! all-pkgs? #t)] - #:args - want-pkg - want-pkg)) - -(define ns (make-base-namespace)) - -(define ht - (for/hash ([pkg (in-list - (if all-pkgs? - (installed-pkg-names #:scope 'installation) - want-pkgs))]) - (define dir (pkg-directory pkg)) - (values pkg - (if dir - (pkg-directory->additional-installs dir pkg #:namespace ns) - null)))) - -(write ht) -(newline) diff --git a/pkgs/plt-services/meta/pkg-build/pkg-list.rkt b/pkgs/plt-services/meta/pkg-build/pkg-list.rkt deleted file mode 100644 index f72d161532..0000000000 --- a/pkgs/plt-services/meta/pkg-build/pkg-list.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#lang racket/base -(require racket/cmdline - pkg/lib) - -(define scope 'installation) - -(command-line - #:once-each - [("--user") "User scope" (set! scope 'user)]) - -(write (installed-pkg-names #:scope scope)) - diff --git a/pkgs/plt-services/meta/pkg-build/status.rkt b/pkgs/plt-services/meta/pkg-build/status.rkt deleted file mode 100644 index 8417540050..0000000000 --- a/pkgs/plt-services/meta/pkg-build/status.rkt +++ /dev/null @@ -1,35 +0,0 @@ -#lang racket/base -(require racket/list) - -(provide status - substatus - show-list) - -(define (substatus fmt . args) - (apply printf fmt args) - (flush-output)) - -(define (status fmt . args) - (printf ">> ") - (apply substatus fmt args)) - -(define (show-list nested-strs #:indent [indent ""]) - (define strs (let loop ([strs nested-strs]) - (cond - [(null? strs) null] - [(pair? (car strs)) - (define l (car strs)) - (define len (length l)) - (loop (append - (list (string-append "(" (car l))) - (take (cdr l) (- len 2)) - (list (string-append (last l) ")")) - (cdr strs)))] - [else (cons (car strs) (loop (cdr strs)))]))) - (substatus "~a\n" - (for/fold ([a indent]) ([s (in-list strs)]) - (if ((+ (string-length a) 1 (string-length s)) . > . 72) - (begin - (substatus "~a\n" a) - (string-append indent " " s)) - (string-append a " " s))))) diff --git a/pkgs/plt-services/meta/pkg-build/summary.rkt b/pkgs/plt-services/meta/pkg-build/summary.rkt deleted file mode 100644 index ce18de163f..0000000000 --- a/pkgs/plt-services/meta/pkg-build/summary.rkt +++ /dev/null @@ -1,182 +0,0 @@ -#lang at-exp racket/base -(require racket/format - racket/file - scribble/html - (only-in plt-web site page call-with-registered-roots) - "about.rkt") - -(provide summary-page - (struct-out doc/main) - (struct-out doc/extract) - (struct-out doc/salvage) - (struct-out doc/none) - (struct-out conflicts/indirect)) - -(struct doc/main (name path) #:prefab) -(struct doc/extract (name path) #:prefab) -(struct doc/salvage (name path) #:prefab) -(struct doc/none (name) #:prefab) - -(struct conflicts/indirect (path) #:prefab) - -(define (summary-page summary-ht dest-dir) - (define page-site (site "pkg-build" - #:url "http://pkg-build.racket-lang.org/" - #:share-from (site "www" - #:url "http://racket-lang.org/" - #:generate? #f) - #:navigation (list - (lambda () (force about-page))))) - (define about-page (delay (make-about page-site))) - - (define page-title "Package Build Results") - - (define summary - (for/list ([pkg (in-list (sort (hash-keys summary-ht) stringvalues msg)) - (loop (hash-set output t (cons (cons e? o) - (hash-ref output t null))))])) - (sync/timeout - (lambda () - (apply - sync - (handle-evt (thread-receive-evt) do-message) - (if (zero? (hash-count output)) - (handle-evt (channel-put-evt no-threads-ch (void)) - (lambda (_) - (loop output))) - never-evt) - (map - (lambda (t) - (handle-evt - t - (lambda (_) - (show-output t output) - (loop (hash-remove output t))))) - (hash-keys output)))) - (handle-evt (thread-receive-evt) do-message)))))) - -(define (flush-chunk-output) - (define s (make-semaphore)) - (thread-send manager (cons (current-thread) s)) - (semaphore-wait s)) - -(define (wait-chunk-output) - (channel-get no-threads-ch)) - -;; -------------------------------------------------- - -(module test racket/base - (define o (open-output-bytes)) - (parameterize ([current-output-port o] - [current-error-port o]) - (define-syntax-rule (def id) - (define id - (dynamic-require (module-path-index-join - `(submod "..") - (variable-reference->module-path-index - (#%variable-reference))) - 'id))) - (def thread/chunk-output) - (def flush-chunk-output) - (def wait-chunk-output) - (define t1 (thread/chunk-output - (lambda () - (printf "hi\n") - (eprintf "bye\n") - (flush-chunk-output) - (sync (system-idle-evt)) - (printf "HI\n") - (eprintf "BYE\n")))) - (define t2 (thread/chunk-output - (lambda () - (printf "hola\n") - (eprintf "adios\n") - (flush-chunk-output) - (sync (system-idle-evt)) - (printf "HOLA\n") - (eprintf "ADIOS\n")))) - (wait-chunk-output)) - (let ([l '("hi\nbye" "hola\nadios")] - [s (get-output-string o)] - [sa (lambda (a b) (string-append (car a) - "\n" - (cadr a) - "\n" - (car b) - "\n" - (cadr b) - "\n"))] - [r reverse] - [u (lambda (l) (map string-upcase l))]) - (unless (or (equal? s (sa l (u l))) - (equal? s (sa (r l) (u l))) - (equal? s (sa (r l) (u (r l)))) - (equal? s (sa l (u (r l))))) - (error "mismatch: " s)))) diff --git a/pkgs/plt-services/meta/pkg-build/union-find.rkt b/pkgs/plt-services/meta/pkg-build/union-find.rkt deleted file mode 100644 index 028c7d7bc8..0000000000 --- a/pkgs/plt-services/meta/pkg-build/union-find.rkt +++ /dev/null @@ -1,64 +0,0 @@ -#lang racket/base - -(provide union! find! elect!) - -(define (find! reps key) - (define rep-key (hash-ref reps key key)) - (if (equal? rep-key key) - key - (let ([rep-key (find! reps rep-key)]) - (hash-set! reps key rep-key) - rep-key))) - -(define (elect! reps key) - (define rep-key (find! reps key)) - (unless (equal? rep-key key) - (hash-set! reps rep-key key) - (hash-set! reps key key))) - -(define (union! reps a-key b-key) - (define rep-a-key (find! reps a-key)) - (define rep-b-key (find! reps b-key)) - (unless (equal? rep-a-key rep-b-key) - (hash-set! reps rep-b-key rep-a-key)) - rep-a-key) - -(module+ test - (require rackunit) - - (define t1 (make-hash)) - (void - (union! t1 "1" "2") - (union! t1 "a" "b") - (union! t1 "b" "c") - (union! t1 "d" "e") - (union! t1 "f" "d") - (union! t1 "3" "2") - (union! t1 "g" "d") - (union! t1 "b" "d")) - - (check-equal? (find! t1 "a") "a") - (check-equal? (find! t1 "b") "a") - (check-equal? (find! t1 "b") "a") - (check-equal? (find! t1 "d") "a") - (check-equal? (find! t1 "e") "a") - (check-equal? (find! t1 "f") "a") - (check-equal? (find! t1 "g") "a") - - (elect! t1 "c") - - (check-equal? (find! t1 "a") "c") - (check-equal? (find! t1 "b") "c") - (check-equal? (find! t1 "b") "c") - (check-equal? (find! t1 "d") "c") - (check-equal? (find! t1 "e") "c") - (check-equal? (find! t1 "f") "c") - (check-equal? (find! t1 "g") "c") - - (check-equal? (find! t1 "1") "3") - (check-equal? (find! t1 "2") "3") - (check-equal? (find! t1 "3") "3")) - - - -