diff --git a/pkgs/distro-build-pkgs/distro-build-client/LICENSE.txt b/pkgs/distro-build-pkgs/distro-build-client/LICENSE.txt deleted file mode 100644 index 2f13367cd2..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-client/LICENSE.txt +++ /dev/null @@ -1,11 +0,0 @@ -distro-build -Copyright (c) 2010-2014 PLT Design Inc. - -This package is distributed under the GNU Lesser General Public -License (LGPL). This means that you can link this package into proprietary -applications, provided you follow the rules stated in the LGPL. You -can also modify this package; if you distribute a modified version, -you must distribute it under the terms of the LGPL, which in -particular means that you must release the source code for the -modified software. See http://www.gnu.org/copyleft/lesser.html -for more information. diff --git a/pkgs/distro-build-pkgs/distro-build-client/display-time.rkt b/pkgs/distro-build-pkgs/distro-build-client/display-time.rkt deleted file mode 100644 index c81278b938..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-client/display-time.rkt +++ /dev/null @@ -1,11 +0,0 @@ -#lang racket/base -(require racket/date) - -(provide display-time) - -(define (display-time) - (define now (seconds->date (current-seconds))) - (printf "[~a] The time is now ~a\n" - (parameterize ([date-display-format 'iso-8601]) - (date->string now #t)) - (date->string now #t))) diff --git a/pkgs/distro-build-pkgs/distro-build-client/doc.txt b/pkgs/distro-build-pkgs/distro-build-client/doc.txt deleted file mode 100644 index ceca0de398..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-client/doc.txt +++ /dev/null @@ -1,564 +0,0 @@ -Site Configuration Modules -========================== - -A build farm is normally run via the `installers', `site', or -`snapshot-site' target of the Racket repository's top-level -makefile. Each of those targets uses `installers', which expects a -`CONFIG=...' argument to specify a configuration module file (or uses -"build/site.rkt" as the default). - -A site configuration module starts `#lang distro-build/config' and -uses keywords to specify various options for the configuration. This -format is described is detail further below; for now, it's enough to -know that there are various options, each of which is associated with -a keyword. - -The machine where `make installers' is run is the server machine. -The server machine first prepares packages for installation on -clients. The site configuration's top-level entry is consulted for -a `#:pkgs' and/or `#:doc-search' option, which overrides any `PKGS' -and/or `DOC_SEARCH' configuration from the makefile. - -The site configuration file otherwise describes and configures -client machines hierarchically, where configuration options -propagate down the hierarchy when they are not overridden more -locally. - -Each client is normally built by running commands via `ssh', where the -client's host, `#:host' (with and optional `#:port' and/or `#:user') -indicate the `ssh' target. Each client machine must be set up with a -public-key authentication, because a direct `ssh' is expected to work -without a password prompt. An exception is when the host is -"localhost" and user is #f, in which case a shell is used directly -instead of `ssh'. When `ssh` is used, -R is also used to create a -tunnel back to the server, and the client by default uses that tunnel -for all communication, and the server by default accepts only -connections via "localhost". - -On the client machine, all work is performed at a specified -directory as specified by `#:dir'. The directory defaults to -"build/plt" (Unix, Mac OS X) or "build\\plt" (Windows), except when -the host is "localhost" and the client is #f, in which case the -current directory (i.e., the server's directory) is used. - -Normally, the client directory is a git clone: - - - If the directory exists already on a client machine (and the - machine is not configured for "clean" mode), then if the directory - contains a ".git" subdirectory, it is assumed to be a git clone - and updated with `git pull'. The `git pull' operation can be - disabled by specifying `#:pull?' as #f, and it defaults to #f - in the case that `#:dir' is not specified, the host is - "localhost", and the user is #f. - - - If the directory does not exist, a git repository is - cloned. The repository can be specified with `#:repo'. By - default, the server is used as the source git repository (so - that the server and client are in sync), which means that the - server's directory must be a git clone. - -Note that neither `ssh' nor `git' turn out to be needed when the host -is "localhost", the user is #f, and the directory is not specified -(which corresponds to the defaults in all cases). - -If a build fails for a machine, building continues on other -machines. Success for a given machine means that its installer -ends up in "build/installers" (and failure for a machine means no -installer) as recorded in the "table.rktd" file. - -To use the `site' makefile target, the configuration file must at -least provide a `#:dist-base-url' value, which is a URL at which the -site will be made available. To use the `snapshot-site' makefile -target, then `#:site-dest' will need to be specified, normally as a -path that ends with the value produced by `(current-stamp)'. - -Hint: When developing a configuration file, use an empty set of -packages to a configuration that works as quickly as possible. Then, -change the list of packages to the ones that you actually want in the -installers. - -Machine Requirements --------------------- - -Each Unix or Mac OS X client needs the following available: - - * SSH server with public-key authentication (except "localhost") - * git (unless the working directory is ready) - * gcc, make, etc. - -Each Windows client needs the following: - - * SSH server with public-key authentication, providing either a - Windows command line (like freeSSHd) or bash with access to - cmd.exe (like Cygwin's opensshd) - * git (unless the working directory is ready) - * Microsoft Visual Studio (version >= 9.0, <= 12.0), installed - in the default folder: - C:\Program Files\Microsoft Visual Studio - or - C:\Program Files (x86)\Microsoft Visual Studio - * Nullsoft Scriptable Install System (NSIS) verstion 2.x, installed - in the default folder: - C:\Program Files\NSIS\makensis.exe - or - C:\Program Files (x86)\NSIS\makensis.exe - or installed so that `makensis' in your PATH. - -Site Configuration -------------------- - -A site configuration module is normally written in the -`distro-build/config' language. The configuration describes individual -machines, and groups them with `parallel' or `sequential' to indicate -whether the machine's builds should run sequentially or in parallel. -Options specified at `parallel' or `sequential' are propagated to each -machine in the group. - -Site-configuration keywords (where means no spaces, etc.): - - #:host --- defaults to "localhost" - - #:name --- defaults to host; this string is recorded as a - description of the installer and can be used in a generated table of - installer links; see also "Names and Download Pages" below - - #:port --- SSH port for the client; defaults to 22 - - #:user --- SSH user for the client; defaults to #f, - which means the current user - - #:dir --- defaults to "build/plt" or "build\\plt", or - to the current directory if the host is "localhost" and the user - is #f - - #:server --- the address of the server as accessed by the - client; when ssh remote tunneling works, then "localhost" should - work to reach the server; defaults to the `SERVER' makefile - variable, which in turn defaults to "localhost" - - #:server-port --- the port of the server as accessed by - the client, and also the port started on clients to tunnel back to - the server; defaults to the `SERVER_PORT' makefile variable, which - in turn defaults to 9440 - - #:server-hosts --- addresses that determine the - interfaces on which the server listens; an empty list means all of - the server's interfaces, while `(list "localhost")' listens only - on the loopback device; defaults to the `SERVER_HOSTS` makefile - variable split on commas, which in turn defaults to `(list - "localhost")' - - #:repo --- the git repository for Racket; defaults to - "http://:/.git" - - #:pkgs '( ...) --- packages to install; defaults to the - `PKGS' makefile variable - - #:dist-base-url --- a URL that is used to construct a - default for `#:doc-search' and `#:dist-catalogs', where the - constructed values are consistent with converting a build server's - content into a download site; since URLs are constructed via - relative paths, this URL normally should end with a slash - - #:doc-search --- URL to install as the configuration for - remote documentation searches in generated installers; "" is - replaced with the PLT default; defaults to #:dist-base-url (if - present) extended with "doc/local-redirect/index.html", or the - `DOC_SEARCH' makefile variable - - #:install-name --- string used as the name of the - installation for package operations in the `user' package scope, - where "" keeps the name as the Racket version; the default is - "snapshot" if the value of `#:release?' is false, "" otherwise. - - #:build-stamp --- a string representing a build stamp, - recorded in installes; the default is from the `BUILD_STAMP' - makefile variable or generated if the value of `#:release?' is - false, "" otherwise. - - #:dist-name --- the distribution name; defaults to the - `DIST_NAME' makefile variable - - #:dist-base --- the distribution's installater name prefix; - defaults to the `DIST_BASE' makefile variable - - #:dist-dir --- the distribution's installation directory; - defaults to the `DIST_DIR' makefile variable - - #:dist-suffix --- a suffix for the installer's name, - usually used for an OS variant; defaults to the `DIST_SUFFIX' - makefile variable - - #:dist-catalogs '( ...) --- catalog URLs to install as the - initial catalog configuration in generated installed, where "" is - replaced with the PLT default catalogs; defaults to - `#:dist-base-url' (if present) extended with "catalogs" in a list - followed by "" - - #:readme --- the content of a "README" file - to include in installers, or a function that takes a hash table - for a configuration and returns a string; the default is the - `make-readme' function from `distro-build/readme' (see below) - - #:max-vm --- max number of VMs allowed to run with this - machine, counting the machine; defaults to 1 - - #:vbox --- Virtual Box machine name (as shown, for example, - in the Virtual Box GUI); if provided, the virtual machine is - started and stopped on the server as needed - - #:platform --- 'unix, 'macosx, 'windows, or 'windows/bash - (which means 'windows though an SSH server providing `bash', such - as Cygwin's); defaults to `(system-type)' - - #:configure '( ...) --- arguments to `configure' - - #:bits --- 32 or 64, affects Visual Studio mode - - #:vc --- provided to "vcvarsall/bat" to select the Visual - Studio build mode; the default is "x86" or "x86_amd64", depending - on `#:bits' - - #:sign-identity --- provides an identity to be passed to - `codesign` for code signing on Mac OS X (for all executables in a - distribution), where an empty string disables signing; the default - is "" - - #:j --- parallelism for `make' on Unix and Mac OS X and - for `raco setup' on all platforms; defaults to 1 - - #:timeout --- numbers of seconds to wait before declaring - failure; defaults to 30 minutes - - #:clean? --- if true, then the build process on the client - machine starts by removing ; set this to #f for a shared repo - checkout; the default is determined by the `CLEAN_MODE' makefile - variable, unless `#:host' is "localhost", `#:user' is #f, and - `#:dir' is not specified, in which case the default is #f - - #:pull? --- if true, then the build process on the client - machine starts by a `git pull' in `#:dir'; set to #f, for example, - for a repo checkout that is shared with server; the default is #t, - unless `#:host' is "localhost", `#:user' is #f, and `#:dir' is not - specified, in which case the default is #f - - #:release? --- if true, then create release-mode - installers; the default is determined by the `RELEASE_MODE' - makefile variable - - #:source? --- determines the default value for - `#:source-runtime?' and `#:source-pkgs' - - #:source-runtime? --- if true, then create an archive that - contains the run-time system in source form (possibly with built - packages), instead of a platform-specific installer; a #t value - works best when used with a Unix client machine, since Unix - clients typically have no native-library packages; the default is - the value of `#:source?' - - #:source-pkgs? --- if true, then packages are included in - the installer/archive only in source form; a true value works best - when the `#:source-runtime?' value is also #t; the default is the - value of `#:source?' - - #:versionless? --- if true, avoids including the Racket - version number in an installer's name or in the installation path; - the default is determined by the `VERSIONLESS_MODE' makefile - variable - - #:mac-pkg? --- if true, creates a ".pkg" for Mac OS X (in - single-file format) instead of a ".dmg"; the default is #f - - #:pause-before --- a pause in seconds to - wait before starting a machine, which may help a virtual machine - avoid confusion from being stopped and started too quickly; the - default is 0 - - #:pause-after --- a pause in seconds to - wait after stopping a machine; the default is 0 - - #:custom --- a hash table mapping arbitrary keywords to - arbitrary values; when a value for `#:custom' is overriden in a - nested configuration, the new table is merged with the overriden - one; use such a table for additional configuration entries other - than the built-in ones, where additional entires may be useful to - a `#:readme' procedure - -Top keywords (recognized only in the configuration top-level): - - #:site-dest --- destination for completed build, used - by the `site' and `snapshot-site' makefile targets; the default is - "build/site" - - #:pdf-doc? --- whether to build PDF documentation when - assembling a site; the default is #f - - #:email-to --- a list of addresses to receive - e-mail reporting build results; mail is sent via `sendmail' - unless `#:smtp-...' configuration is supplied - - #:email-from --- address used as the sender of e-mailed - reports; the first string in `#:email-to' is used by default - - #:smtp-server - #:smtp-port - #:smtp-connect <'plain, 'ssl, or 'tls> - #:smtp-user - #:smtp-password - --- configuration for sending e-mail through SMTP instead of - `sendmail'; the `#:smtp-port' default (25, 465, or 587) is picked - based on `#:smtp-connect', which in turn defaults to 'plain; - supply non-#f `#:smtp-user' and `#:smtp-password' when - authentication is required by the server - - #:site-help --- hash table of extra "help" information - for entries on a web page created by the `site' and - `snapshot-site' makefile targets; the hash keys are strings for - row labels in the download table (after splitting on "|" and - removing "{...}"), and the values are X-expressions for the help - content - - #:site-title --- title for the main page generated - by the `site' or `snapshot-site' makefile target; the default - is "Racket Downloads" - - #:max-snapshots --- number of snapshots to keep, used by - the `snapshot-site' makefile target - - #:plt-web-style? --- indicates whether `plt-web` should - be used to generate a site or snapshot page; the default is #t - -More precisely, the `distro-build/config' language is like -`racket/base' except that the module body must have exactly one -expression (plus any number of definitions, etc.) that produces a -site-configuration value. The value is exported as `site-config' -from the module. Any module can act as a site-configuration module -a long as it exports `site-config' as a site-configuration value. - -The `distro-build/config' language also adds the following functions -to `racket/base': - - (machine ... ...) -> site-config? - Produces a site configuration based on the given keyword-based - options. The support keyword arguments are described above. - - (sequential ... ... config ...) - -> site-config? - config : site-config? - Produces a site configuration that runs each `config' - sequentially. The support keyword arguments are described above. - - (parallel ... ... config ...) - -> site-config? - config : site-config? - Produces a site configuration that runs each `config' in - parallel. The support keyword arguments are described above. - - (site-config? v) -> boolean? - (site-config-tag config) -> (or/c 'machine 'sequential 'parallel) - config : site-config? - (site-config-options config) -> (hash/c keyword? any/c) - config : site-config? - (site-config-content config) -> (listof site-config?) - config : site-config? - Site configuation inspection - - (current-mode) -> string? - (current-mode s) -> void? - s : string? - A parameter whose value is the user's requested mode for this - configuration, normally as provided via the makefile's - `CONFIG_MODE' variable. The default mode is "default". The - interpretation of modes is completely up to the - site configuration file. - - (current-stamp) -> string? - Returns a string to identify the current build, normally a - combination of the date and a git commit hash. - -READMEs -------- - -The `distro-build/readme' library provides functions for constructing -a README file's content. Each function takes a hash table mapping -configuration keywords to values. - - (make-readme config) -> string - config : hash? - Produces basic "README" content, using information about the - distribution and the Racket license. The content is constructed - using `config' keywords such as `#:name', `#:platform', - `#:dist-name', and `#:dist-catalogs', and sometimes `current-stamp'. - - (make-macosx-notes config) -> string - config : hash? - Produces "README" content to tell Mac OS X users how to install a - distribution folder. This function is used by `make-readme' when - `#:platform' in `config' is 'macosx. - -Names and Download Pages ------------------------- - -The `#:name' for an installer is used in an HTML table of download -links by the `site' or `snapshot-site' targets. The names are first -sorted. Then, for the purposes of building the table, a "|" separated -by any number of spaces within a name is treated as a hierarchical -delimiter, while anything within "{" and "}" in a hierarchical level -is stripped from the displayed name along with surrounding spaces (so -that it can affect sorting without being displayed). Anything after "; -" within a "|"-separated part is rendered as a detail part of the -label (e.g., in a smaller font). - -For example, the names - - "Racket | {2} Linux | 32-bit" - "Racket | {2} Linux | 64-bit; built on Ubuntu" - "Racket | {1} Windows | 32-bit" - "Racket | {1} Windows | 64-bit" - "Racket | {3} Source" - -are shown (actually or conceptually) as - - Racket - Windows - [32-bit] - [64-bit] - Linux - [32-bit] - [64-bit] - [Source] - -where the square-bracketed entries are hyperlinks and the -angle-bracketed pieces are details. - -Examples --------- - -** Single Installer ** - -The simplest possible configuration file is - - #lang distro-build/config - (machine) - -In fact, this configuration file is created automatically as -"build/site.rkt" (if the file does not exist already) and used as the -default configuration. With this configuration, - - make installers - -creates an installer in "build/installers" for the platform that is -used to create the installer. - -** Installer Web Page *** - -To make a web page that serves both a minimal installer and packages, -create a "site.rkt" file with - - #lang distro-build/config - - (sequential - ;; The packages that will be available: - #:pkgs '("main-distribution") - ;; FIXME: the URL where the installer and packages will be: - #:dist-base-url "http://my-server.domain/snapshot/" - (machine - ;; FIXME: the way the installer is described on the web page: - #:name "Minimal Racket | My Platform" - ;; The packages in this installer: - #:pkgs '())) - -then - - make site CONFIG=site.rkt - -creates a "build/site" directory that you can move to your web server's -"snapshot" directory, so that "build/site/index.html" is the main -page, and so on. - -** Accumulated Shapshots Web Page ** - -To make a web site that provides some number (5, by default) of -snapshots, use `(current-stamp)' when constructing the -`#:dist-base-url' value. Also, use `(current-stamp)' as the directory -for assembling the "site": - - #lang distro-build/config - (sequential - ;; The packages that will be available: - #:pkgs '("gui-lib") - ;; FIXME: the URL where the installer and packages will be: - #:dist-base-url (string-append "http://my-server.domain/snapshots/" - (current-stamp) "/") - ;; The local directory where a snapshot is written - #:site-dest (build-path "build/site" (current-stamp)) - (machine - ;; FIXME: the way the installer is described on the web page: - #:name "Minimal Racket | My Platform" - ;; The packages in this installer: - #:pkgs '())) - -Then, - - make snapshot-site CONFIG=site.rkt - -creates a "build/site" directory that you can move to your web -server's "snapshots" directory, so that "build/site/index.html" is the -main page that initially points to "build/site//index.html", -and so on. To make a newer snapshot, update the git repository, leave -"build/site" in place, and run - - make snapshot-site CONFIG=site.rkt - -again. The new installers will go into a new subdirectory, and -the main "index.html" file will be rewritten to point to them. - -** Multiple Platforms ** - -A configuration module that drives multiple clients to build -installers might look like this: - - #lang distro-build/config - - (sequential - #:pkgs '("drracket") - #:server-hosts '() ; Insecure? See below. - (machine - #:desc "Linux (32-bit, Precise Pangolin)" - #:name "Ubuntu 32" - #:vbox "Ubuntu 12.04" - #:host "192.168.56.102") - (machine - #:desc "Windows (64-bit)" - #:name "Windows 64" - #:host "10.0.0.7" - #:server "10.0.0.1" - #:dir "c:\\Users\\racket\\build\\plt" - #:platform 'windows - #:bits 64)) - -The configuration describes using the hosts "192.168.56.1" and -"10.0.0.7" for Linux and Windows builds, respectively, which are run -one at a time. - -The Linux machine runs in VirtualBox on the server machine (in a -virtual machine named "Ubuntu 12.04"). It contacts the server still as -"localhost", and that works because the ssh connection to the Linux -machine creates a tunnel (at the same port as the server's, wjich -defaults to 9440). - -The Windows machine uses freeSSHd (not a `bash'-based SSH server like -Cygwin) and communicates back to the server as "10.0.0.1" instead of -using an SSH tunnel. To make that work, `#:server-hosts' is specified -as the empty list to make the server listen on all interfaces (instead -of just "localhost") --- which is possibly less secure than the -default restriction that allows build-server connections only via -"localhost". - -With this configuration file in "site.rkt", - - make installers CONFIG=site.rkt - -produces two installers, both in "build/installers", and a hash table -in "table.rktd" that maps "Linux (32-bit, Precise Pangolin)" to the -Linux installer and "Windows (64-bit)" to the Windows installer. diff --git a/pkgs/distro-build-pkgs/distro-build-client/info.rkt b/pkgs/distro-build-pkgs/distro-build-client/info.rkt deleted file mode 100644 index 48249db045..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-client/info.rkt +++ /dev/null @@ -1,11 +0,0 @@ -#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-pkgs/distro-build-client/installer-dmg.rkt b/pkgs/distro-build-pkgs/distro-build-client/installer-dmg.rkt deleted file mode 100644 index b4793f2185..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-client/installer-dmg.rkt +++ /dev/null @@ -1,142 +0,0 @@ -#lang at-exp racket/base -(require racket/system - racket/file - racket/format - racket/runtime-path - ds-store - ds-store/alias) - -(provide installer-dmg - make-dmg) - -(define hdiutil "/usr/bin/hdiutil") -(define codesign "/usr/bin/codesign") - -(define-runtime-path bg-image "macosx-installer/racket-rising.png") - -(define (system*/show . l) - (displayln (apply ~a #:separator " " l)) - (flush-output) - (unless (apply system* l) - (error "failed"))) - -(define (make-dmg volname src-dir dmg bg readme sign-identity) - (define tmp-dmg (make-temporary-file "~a.dmg")) - (define work-dir - (let-values ([(base name dir?) (split-path src-dir)]) - (build-path base "work"))) - (when (file-exists? dmg) (delete-file dmg)) - (delete-directory/files work-dir #:must-exist? #f) - (make-directory* work-dir) - (printf "Copying ~a\n" src-dir) - (define dest-dir (build-path work-dir volname)) - (copy-directory/files src-dir dest-dir - #:keep-modify-seconds? #t) - (when readme - (call-with-output-file* - (build-path work-dir volname "README.txt") - #:exists 'truncate - (lambda (o) - (display readme o)))) - (when bg - (copy-file bg (build-path work-dir ".bg.png"))) - (unless (string=? sign-identity "") - (sign-executables dest-dir sign-identity)) - ;; The following command should work fine, but it looks like hdiutil in 10.4 - ;; is miscalculating the needed size, making it too big in our case (and too - ;; small with >8GB images). It seems that it works to first generate an - ;; uncompressed image and then convert it to a compressed one. - ;; hdiutil create -format UDZO -imagekey zlib-level=9 -ov \ - ;; -mode 555 -volname volname -srcfolder . dmg - ;; So, first create an uncompressed image... - (parameterize ([current-directory work-dir]) - (system*/show hdiutil - "create" "-format" "UDRW" "-ov" - "-mode" "755" "-volname" volname "-srcfolder" "." - tmp-dmg)) - ;; Then do the expected dmg layout... - (when bg - (dmg-layout tmp-dmg volname ".bg.png")) - ;; And create the compressed image from the uncompressed image: - (system*/show hdiutil - "convert" "-format" "UDBZ" "-imagekey" "zlib-level=9" "-ov" - tmp-dmg "-o" dmg) - (delete-file tmp-dmg)) - -(define (sign-executables dest-dir sign-identity) - ;; Sign any executable in "bin", top-level ".app", or either of those in "lib" - (define (check-bins dir) - (for ([f (in-list (directory-list dir #:build? #t))]) - (when (and (file-exists? f) - (member 'execute (file-or-directory-permissions f)) - (member (call-with-input-file - f - (lambda (i) - (define bstr (read-bytes 4 i)) - (and (bytes? bstr) - (= 4 (bytes-length bstr)) - (integer-bytes->integer bstr #f)))) - '(#xFeedFace #xFeedFacf))) - (system*/show codesign "-s" sign-identity f)))) - (define (check-apps dir) - (for ([f (in-list (directory-list dir #:build? #t))]) - (when (and (directory-exists? f) - (regexp-match #rx#".app$" f)) - (define name (let-values ([(base name dir?) (split-path f)]) - (path-replace-suffix name #""))) - (define exe (build-path f "Contents" "MacOS" name)) - (when (file-exists? exe) - (system*/show codesign "-s" sign-identity f))))) - (check-bins (build-path dest-dir "bin")) - (check-bins (build-path dest-dir "lib")) - (check-apps dest-dir) - (check-apps (build-path dest-dir "lib"))) - -(define (dmg-layout dmg volname bg) - (define-values (mnt del?) - (let ([preferred (build-path "/Volumes/" volname)]) - (if (not (directory-exists? preferred)) - ;; Use the preferred path so that the alias is as - ;; clean as possible: - (values preferred #f) - ;; fall back to using a temporary directory - (values (make-temporary-file "~a-mnt" 'directory) #t)))) - (system*/show hdiutil - "attach" "-readwrite" "-noverify" "-noautoopen" - "-mountpoint" mnt dmg) - (define alias (path->alias-bytes (build-path mnt bg) - #:wrt mnt)) - (make-file-or-directory-link "/Applications" (build-path mnt "Applications")) - (define (->path s) (string->path s)) - (write-ds-store (build-path mnt ".DS_Store") - (list - (ds 'same 'BKGD 'blob - (bytes-append #"PctB" - (integer->integer-bytes (bytes-length alias) 4 #t #t) - (make-bytes 4 0))) - (ds 'same 'ICVO 'bool #t) - (ds 'same 'fwi0 'blob - ;; Window location (size overridden below), sideview off: - (fwind 160 320 540 1000 'icnv #f)) - (ds 'same 'fwsw 'long 135) ; window sideview width? - (ds 'same 'fwsh 'long 380) ; window sideview height? - (ds 'same 'icgo 'blob #"\0\0\0\0\0\0\0\4") ; ??? - (ds 'same 'icvo 'blob - ;; folder view options: - #"icv4\0\200nonebotm\0\0\0\0\0\0\0\0\0\4\0\0") - (ds 'same 'icvt 'shor 16) ; icon label size - (ds 'same 'pict 'blob alias) - (ds (->path ".bg.png") 'Iloc 'blob (iloc 900 180)) ; file is hidden, anway - (ds (->path "Applications") 'Iloc 'blob (iloc 500 180)) - (ds (->path volname) 'Iloc 'blob (iloc 170 180)))) - (system*/show hdiutil "detach" mnt) - (when del? - (delete-directory mnt))) - -(define (installer-dmg human-name base-name dist-suffix readme sign-identity) - (define dmg-name (format "bundle/~a-~a~a.dmg" - base-name - (system-library-subpath #f) - dist-suffix)) - (make-dmg human-name "bundle/racket" dmg-name bg-image readme sign-identity) - dmg-name) diff --git a/pkgs/distro-build-pkgs/distro-build-client/installer-exe.rkt b/pkgs/distro-build-pkgs/distro-build-client/installer-exe.rkt deleted file mode 100644 index 5ca6b62b02..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-client/installer-exe.rkt +++ /dev/null @@ -1,434 +0,0 @@ -#lang at-exp racket/base -(require racket/format - racket/list - racket/system - racket/path - racket/runtime-path - setup/getinfo) - -(provide installer-exe) - -(define-runtime-path installer-dir "windows-installer") - -(define (get-exe-actions src-dir filename combine) - (define f (build-path src-dir "lib" filename)) - (for/list ([(k v) (if (file-exists? f) - (call-with-input-file* f read) - (hash))]) - (combine k v))) - -(define (get-extreg src-dir) - (apply - append - (get-exe-actions src-dir "extreg.rktd" - (lambda (k v) - (for/list ([v (in-list v)]) - (append v (list k))))))) - -(define (get-startmenu src-dir) - (get-exe-actions src-dir "startmenu.rktd" - (lambda (k v) k))) - -(define (get-auto-launch src-dir) - (define l - (filter (lambda (p) (real? (cdr p))) - (get-exe-actions src-dir "startmenu.rktd" - cons))) - (if (null? l) - #f - (path-replace-suffix (caar (sort l < #:key cdr)) #""))) - -(define (try-exe f) - (and (file-exists? f) f)) - -(define (nsis-generate dest distname version winplatform - makensis - #:extension-registers [extregs null] - #:start-menus [startmenus null] - #:versionless [versionless? #t] - #:simple? [simple? #f] - #:auto-launch [auto-launch #f]) - (define distdir (regexp-replace* #rx" " distname "-")) - (define destfilename (file-name-from-path dest)) - (define-values (version1 version2 version3 version4) - (apply - values - (take (cdr (regexp-match #rx"^([0-9]*)[.]([0-9]*)[.]([0-9]*)[.]([0-9]*)" - (string-append version ".0.0.0"))) - 4))) - (define got-files (make-hash)) - (define (get-file s) - (unless (hash-ref got-files s #f) - (define dest (build-path "bundle" s)) - (unless (file-exists? dest) - (hash-set! got-files s #t) - (copy-file (build-path installer-dir s) dest))) - s) - (define script - @~a{ -!include "MUI2.nsh" -!include "WinVer.nsh" -!include "nsDialogs.nsh" - -;; ==================== Configuration - -!define RKTVersion "@|version|" -!define RKTVersionLong "@|version1|.@|version2|.@|version3|.@|version4|" -;; Full name for the package, and a short name for installer texts -!define RKTHumanName "@|distname| v@|version| (@|winplatform|)" -!define RKTShortName "@|distname|" -!define RKTStartName "@|distname|@(if versionless? "" @~a{ v@|version|})" -!define RKTDirName "@|distdir|@(if versionless? "" @~a{-@|version|})" -!define RKTRegName "@|distdir|-@|winplatform|-@|version|" -!define RKTProgFiles "$PROGRAMFILES@(if (equal? winplatform "x86_64") "64" "")" -@(if simple? @~a{!define SimpleInstaller} "") -@(if auto-launch @~a{!define RKTLaunchProgram "@|auto-launch|"} "") - -Name "${RKTHumanName}" -OutFile "@|destfilename|" - -BrandingText "${RKTHumanName}" -BGGradient 4040A0 101020 - -SetCompressor /SOLID "LZMA" - -InstallDir "${RKTProgFiles}\${RKTDirName}" -!ifndef SimpleInstaller - InstallDirRegKey HKLM "Software\${RKTRegName}" "" -!endif -!define MUI_STARTMENUPAGE_DEFAULTFOLDER "${RKTStartName}" -!define MUI_ICON "@(get-file "installer.ico")" -!define MUI_UNICON "@(get-file "uninstaller.ico")" -!define MUI_HEADERIMAGE -!define MUI_HEADERIMAGE_BITMAP "@(get-file "header.bmp")" -!define MUI_HEADERIMAGE_BITMAP_RTL "@(get-file "header-r.bmp")" -!define MUI_HEADERIMAGE_RIGHT - -!define MUI_WELCOMEFINISHPAGE_BITMAP "@(get-file "welcome.bmp")" -!define MUI_UNWELCOMEFINISHPAGE_BITMAP "@(get-file "welcome.bmp")" - -!define MUI_WELCOMEPAGE_TITLE "${RKTHumanName} Setup" -!define MUI_UNWELCOMEPAGE_TITLE "${RKTHumanName} Uninstall" -!ifdef SimpleInstaller - !define MUI_WELCOMEPAGE_TEXT "This is a simple installer for ${RKTShortName}.$\r$\n$\r$\nIt will only create the @|distname| folder. To uninstall, simply remove the folder.$\r$\n$\r$\n$_CLICK" -!else - !define MUI_WELCOMEPAGE_TEXT "This wizard will guide you through the installation of ${RKTShortName}.$\r$\n$\r$\nPlease close any running Racket applications so the installer can update the relevant system files.$\r$\n$\r$\n$_CLICK" -!endif -!define MUI_UNWELCOMEPAGE_TEXT "This wizard will guide you through the removal of ${RKTShortName}.$\r$\n$\r$\nBefore starting, make sure no Racket applications are running.$\r$\n$\r$\n$_CLICK" - -!define MUI_FINISHPAGE_TITLE "${RKTHumanName}" -!ifdef SimpleInstaller - !define MUI_FINISHPAGE_RUN - !define MUI_FINISHPAGE_RUN_FUNCTION OpenInstDir - Function OpenInstDir - ExecShell "" "$INSTDIR" - FunctionEnd - !define MUI_FINISHPAGE_RUN_TEXT "Open the installation folder" -@(if auto-launch - @~a{ - !else - !define MUI_FINISHPAGE_RUN "$INSTDIR\${RKTLaunchProgram}.exe" - !define MUI_FINISHPAGE_RUN_TEXT "Run ${RKTLaunchProgram}"} - "") -!endif -!define MUI_FINISHPAGE_LINK "Visit the Racket web site" -!define MUI_FINISHPAGE_LINK_LOCATION "http://racket-lang.org/" - -; !define MUI_UNFINISHPAGE_NOAUTOCLOSE ; to allow users see what was erased - -!define MUI_STARTMENUPAGE_REGISTRY_ROOT "HKLM" -!define MUI_STARTMENUPAGE_REGISTRY_KEY "Software\${RKTRegName}" -!define MUI_STARTMENUPAGE_REGISTRY_VALUENAME "Start Menu Folder" - -; Doesn't work on some non-xp machines -; !define MUI_INSTFILESPAGE_PROGRESSBAR colored - -VIProductVersion "${RKTVersionLong}" -VIAddVersionKey "ProductName" "Racket" -VIAddVersionKey "Comments" "This is the Racket language, see http://racket-lang.org/." -VIAddVersionKey "CompanyName" "PLT Design Inc." -VIAddVersionKey "LegalCopyright" "© PLT Design Inc." -VIAddVersionKey "FileDescription" "Racket Installer" -VIAddVersionKey "FileVersion" "${RKTVersion}" - -;; ==================== Variables - -!ifndef SimpleInstaller - Var MUI_TEMP - Var STARTMENU_FOLDER -!endif - -;; ==================== Interface - -!define MUI_ABORTWARNING - -; Install -!insertmacro MUI_PAGE_WELCOME -!define MUI_PAGE_CUSTOMFUNCTION_LEAVE myTestInstDir -!insertmacro MUI_PAGE_DIRECTORY -!ifndef SimpleInstaller - !insertmacro MUI_PAGE_STARTMENU Application $STARTMENU_FOLDER -!endif -!insertmacro MUI_PAGE_INSTFILES - -; Uncheck and hide the "run" checkbox on vista, since it will run with -; elevated permissions (see also ../nsis-vista-note.txt) -!define MUI_PAGE_CUSTOMFUNCTION_SHOW DisableRunCheckBoxIfOnVista -!insertmacro MUI_PAGE_FINISH -Function DisableRunCheckBoxIfOnVista - ${If} ${AtLeastWinVista} - ; use EnableWindow instead of ShowWindow to just disable it - ShowWindow $mui.FinishPage.Run 0 - ${NSD_Uncheck} $mui.FinishPage.Run - ${EndIf} -FunctionEnd - -!ifndef SimpleInstaller - ; Uninstall - !define MUI_WELCOMEPAGE_TITLE "${MUI_UNWELCOMEPAGE_TITLE}" - !define MUI_WELCOMEPAGE_TEXT "${MUI_UNWELCOMEPAGE_TEXT}" - ; !insertmacro MUI_UNPAGE_WELCOME - !insertmacro MUI_UNPAGE_CONFIRM - !insertmacro MUI_UNPAGE_INSTFILES - ; !insertmacro MUI_UNPAGE_FINISH -!endif - -!ifndef SimpleInstaller - !define MUI_CUSTOMFUNCTION_UNGUIINIT un.myGUIInit -!endif - -!insertmacro MUI_LANGUAGE "English" - -!ifndef SimpleInstaller - !define UNINSTEXE "$INSTDIR\Uninstall.exe" -!endif - -;; ==================== Installer - -!ifdef SimpleInstaller -Function myTestInstDir - IfFileExists "$INSTDIR\*.*" +1 inst_dir_exists - MessageBox MB_YESNO "The directory '$INSTDIR' already exists, continue?" /SD IDYES IDYES inst_dir_exists - Abort - inst_dir_exists: -FunctionEnd -!else -Function myTestInstDir - ; The assumption is that users might have all kinds of ways to get a Racket - ; tree, plus, they might have an old wise-based installation, so it is better - ; to rely on files rather than test registry keys. Note: no version check. - ; if any of these exist, then we assume it's an old installation - IfFileExists "$INSTDIR\Racket.exe" racket_is_installed - @(if auto-launch @~a{IfFileExists "$INSTDIR\${RKTLaunchProgram}.exe" racket_is_installed} "") - IfFileExists "$INSTDIR\collects" racket_is_installed - Goto racket_is_not_installed - racket_is_installed: - IfFileExists "${UNINSTEXE}" we_have_uninstall - MessageBox MB_YESNO "It appears that there is an existing Racket installation in '$INSTDIR', but no Uninstaller was found.$\r$\nContinue anyway (not recommended)?" /SD IDYES IDYES maybe_remove_tree - Abort - we_have_uninstall: - MessageBox MB_YESNO "It appears that there is an existing Racket installation in '$INSTDIR'.$\r$\nDo you want to uninstall it first (recommended)?" /SD IDNO IDNO maybe_remove_tree - HideWindow - ClearErrors - ExecWait '"${UNINSTEXE}" _?=$INSTDIR' - IfErrors uninstaller_problematic - IfFileExists "$INSTDIR\Racket.exe" uninstaller_problematic - BringToFront - Goto racket_is_not_installed - uninstaller_problematic: - MessageBox MB_YESNO "Errors in uninstallation!$\r$\nDo you want to quit and sort things out now (highly recommended)?" /SD IDNO IDNO maybe_remove_tree - Quit - maybe_remove_tree: - MessageBox MB_YESNO "Since you insist, do you want to simply remove the previous directory now?$\r$\n(It is really better if you sort this out manually.)" /SD IDYES IDNO racket_is_not_installed - RMDir /r $INSTDIR - racket_is_not_installed: -FunctionEnd -!endif - -Section "" - SetShellVarContext all - - SetDetailsPrint both - DetailPrint "Installing Racket..." - SetDetailsPrint listonly - SetOutPath "$INSTDIR" - File /a /r "racket\*.*" - !ifndef SimpleInstaller - WriteUninstaller "${UNINSTEXE}" ; Create uninstaller - !endif - - !ifndef SimpleInstaller - SetDetailsPrint both - DetailPrint "Creating Shortcuts..." - SetDetailsPrint listonly - !insertmacro MUI_STARTMENU_WRITE_BEGIN Application - SetOutPath "$INSTDIR" ; Make installed links run in INSTDIR - CreateDirectory "$SMPROGRAMS\$STARTMENU_FOLDER" - @apply[~a - #:separator "\n" - (for/list ([exe-str (in-list startmenus)]) - (define exe exe-str) - (define lnk (path->string (path-replace-suffix exe-str #".lnk"))) - @~a{ CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\@|lnk|" "$INSTDIR\@|exe|"})] - CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\Racket.lnk" "$INSTDIR\Racket.exe" - CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\Racket Folder.lnk" "$INSTDIR" - CreateShortCut "$SMPROGRAMS\$STARTMENU_FOLDER\Uninstall.lnk" "${UNINSTEXE}" - !insertmacro MUI_STARTMENU_WRITE_END - - SetDetailsPrint both - DetailPrint "Setting Registry Keys..." - SetDetailsPrint listonly - WriteRegStr HKLM "Software\${RKTRegName}" "" "$INSTDIR" ; Save folder location - @apply[~a - #:separator "\n" - (apply - append - (for/list ([extreg (in-list extregs)]) - (define kind (list-ref extreg 1)) - (define icon (list-ref extreg 3)) - (define cmd (list-ref extreg 4)) - (define exe-name (list-ref extreg 5)) - (append - (for/list ([ext (in-list (list-ref extreg 2))]) - @~a{ WriteRegStr HKCR ".@|ext|" "" "@|kind|"}) - (list - @~a{ WriteRegStr HKCR "@|kind|" "" "@(list-ref extreg 0)"} - @~a{ WriteRegStr HKCR "@|kind|\DefaultIcon" "" "$INSTDIR\lib\@|icon|"}) - (if cmd - (list - @~a{ WriteRegStr HKCR "@|kind|\shell\open\command" "" '"$INSTDIR\@|exe-name|" @|cmd|'}) - null))))] - ; Example, in case we want some things like this in the future - ; WriteRegStr HKCR "Racket.Document\shell\racket" "" "Run with Racket" - ; WriteRegStr HKCR "Racket.Document\shell\racket\command" "" '"$INSTDIR\Racket.exe" "-r" "%1"' - - WriteRegExpandStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "UninstallString" '"${UNINSTEXE}"' - WriteRegExpandStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "InstallLocation" "$INSTDIR" - WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "DisplayName" "${RKTHumanName}" - WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "DisplayIcon" "$INSTDIR\DrRacket.exe,0" - WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "DisplayVersion" "${RKTVersion}" - ; used to also have "VersionMajor" & "VersionMinor" but looks like it's not needed - WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "HelpLink" "http://racket-lang.org/" - WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "URLInfoAbout" "http://racket-lang.org/" - WriteRegStr HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "Publisher" "PLT Design Inc." - WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "NoModify" "1" - WriteRegDWORD HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" "NoRepair" "1" - !endif - - SetDetailsPrint both - DetailPrint "Installation complete." -SectionEnd - -;; ==================== Uninstaller - -!ifndef SimpleInstaller - -Function un.myGUIInit - ; if any of these exist, then we're fine - IfFileExists "$INSTDIR\Racket.exe" racket_is_installed_un - IfFileExists "$INSTDIR\lib\GRacket.exe" racket_is_installed_un - @(if auto-launch @~a{IfFileExists "$INSTDIR\${RKTLaunchProgram}.exe" racket_is_installed_un} "") - IfFileExists "$INSTDIR\collects" racket_is_installed_un - MessageBox MB_YESNO "It does not appear that Racket is installed in '$INSTDIR'.$\r$\nContinue anyway (not recommended)?" /SD IDYES IDYES racket_is_installed_un - Abort "Uninstall aborted by user" - racket_is_installed_un: -FunctionEnd - -Section "Uninstall" - SetShellVarContext all - - SetDetailsPrint both - DetailPrint "Removing the Racket installation..." - SetDetailsPrint listonly - Delete "$INSTDIR\*.exe" - Delete "$INSTDIR\README*.*" - RMDir /r "$INSTDIR\include" - RMDir /r "$INSTDIR\collects" - RMDir /r "$INSTDIR\lib" - RMDir /r "$INSTDIR\share" - RMDir /r "$INSTDIR\etc" - RMDir /r "$INSTDIR\doc" - ;; these exist in Racket-Full installations - RMDir /r "$INSTDIR\man" - ; RMDir /r "$INSTDIR\src" - Delete "${UNINSTEXE}" - RMDir "$INSTDIR" - ;; if the directory is opened, it will take some time to remove - Sleep 1000 - IfErrors +1 uninstall_inst_dir_ok - MessageBox MB_YESNO "The Racket installation at '$INSTDIR' was not completely removed.$\r$\nForce deletion?$\r$\n(Make sure no Racket applications are running.)" /SD IDYES IDNO uninstall_inst_dir_ok - RMDir /r "$INSTDIR" - IfErrors +1 uninstall_inst_dir_ok - MessageBox MB_OK "Forced deletion did not work either, you will need to clean up '$INSTDIR' manually." /SD IDOK - uninstall_inst_dir_ok: - - SetDetailsPrint both - DetailPrint "Removing Shortcuts..." - SetDetailsPrint listonly - !insertmacro MUI_STARTMENU_GETFOLDER Application $MUI_TEMP - Delete "$SMPROGRAMS\$MUI_TEMP\*.lnk" - ;; Delete empty start menu parent diretories - StrCpy $MUI_TEMP "$SMPROGRAMS\$MUI_TEMP" - startMenuDeleteLoop: - RMDir $MUI_TEMP - GetFullPathName $MUI_TEMP "$MUI_TEMP\.." - IfErrors startMenuDeleteLoopDone - StrCmp $MUI_TEMP $SMPROGRAMS startMenuDeleteLoopDone startMenuDeleteLoop - startMenuDeleteLoopDone: - - SetDetailsPrint both - DetailPrint "Removing Registry Keys..." - SetDetailsPrint listonly - DeleteRegKey /ifempty HKLM "Software\${RKTRegName}\Start Menu Folder" - DeleteRegKey /ifempty HKLM "Software\${RKTRegName}" - @apply[~a - #:separator "\n" - (append - (for*/list ([extreg (in-list extregs)] - [ext (in-list (list-ref extreg 2))]) - @~a{ DeleteRegKey HKCR ".@|ext|"}) - (for/list ([extreg (in-list extregs)]) - @~a{ DeleteRegKey HKCR ".@(list-ref extreg 1)"}))] - DeleteRegKey HKLM "Software\Microsoft\Windows\CurrentVersion\Uninstall\${RKTRegName}" - - SetDetailsPrint both - DetailPrint "Uninstallation complete." -SectionEnd - -!endif -}) - (call-with-output-file* - "bundle/installer.nsi" - #:mode 'text - #:exists 'truncate - (lambda (o) - (display script o) - (newline o))) - (parameterize ([current-directory "bundle"]) - (system* makensis "/V3" "installer.nsi"))) - -(define (installer-exe human-name base-name versionless? dist-suffix readme) - (define makensis (or (find-executable-path "makensis.exe") - (try-exe "c:\\Program Files\\NSIS\\makensis.exe") - (try-exe "c:\\Program Files (x86)\\NSIS\\makensis.exe") - (error 'installer-exe "cannot find \"makensis.exe\""))) - (define platform (let-values ([(base name dir?) (split-path (system-library-subpath #f))]) - (path->string name))) - (define exe-path (format "bundle/~a-~a-win32~a.exe" base-name platform dist-suffix)) - (when readme - (call-with-output-file* - #:exists 'truncate - #:mode 'text - (build-path "bundle" "racket" "README.txt") - (lambda (o) - (display readme o)))) - (nsis-generate exe-path - human-name - (version) - platform - makensis - #:versionless versionless? - #:extension-registers (get-extreg "bundle/racket") - #:start-menus (get-startmenu "bundle/racket") - #:auto-launch (get-auto-launch "bundle/racket")) - exe-path) diff --git a/pkgs/distro-build-pkgs/distro-build-client/installer-pkg.rkt b/pkgs/distro-build-pkgs/distro-build-client/installer-pkg.rkt deleted file mode 100644 index 231f94c309..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-client/installer-pkg.rkt +++ /dev/null @@ -1,157 +0,0 @@ -#lang at-exp racket/base -(require racket/system - racket/file - racket/format - racket/runtime-path - ds-store - ds-store/alias - xml) - -(provide installer-pkg) - -(define pkgbuild "/usr/bin/pkgbuild") -(define productbuild "/usr/bin/productbuild") - -(define-runtime-path bg-image "macosx-installer/pkg-bg.png") - -(define (system*/show . l) - (displayln (apply ~a #:separator " " l)) - (flush-output) - (unless (apply system* l) - (error "failed"))) - -(define (gen-install-script install-dest) - (~a "#!/bin/sh\n" - "echo \"" (regexp-replace* #rx"[\"$]" - install-dest - "\"'\\0'\"") - "\"/bin > /etc/paths.d/racket\n")) - -(define (make-pkg human-name src-dir pkg-name readme sign-identity) - (define install-dest (string-append "/Applications/" human-name)) - (define id (string-append "org.racket-lang." - (regexp-replace* #rx" " - human-name - "-"))) - - (define (make-rel dir-name) - (let-values ([(base name dir?) (split-path src-dir)]) - (build-path base dir-name))) - - (define work-dir (make-rel "work")) - (delete-directory/files work-dir #:must-exist? #f) - (define scripts-dir (make-rel "scripts")) - (delete-directory/files scripts-dir #:must-exist? #f) - (define resources-dir (make-rel "resources")) - (delete-directory/files resources-dir #:must-exist? #f) - - (printf "Creating ~a\n" scripts-dir) - (make-directory* scripts-dir) - (define postinstall (build-path scripts-dir "postinstall")) - (call-with-output-file* - postinstall - (lambda (o) - (write-string (gen-install-script install-dest) o))) - (file-or-directory-permissions postinstall #o770) - - (printf "Creating ~a\n" resources-dir) - (make-directory* resources-dir) - (copy-file bg-image (build-path resources-dir "background.png")) - - (printf "Copying ~a\n" src-dir) - (define dest-dir work-dir) - (copy-directory/files src-dir dest-dir - #:keep-modify-seconds? #t) - (when readme - (call-with-output-file* - (build-path dest-dir "README.txt") - #:exists 'truncate - (lambda (o) - (display readme o)))) - (copy-file (build-path dest-dir "README.txt") - (build-path resources-dir "README.txt")) - - (system*/show pkgbuild - "--root" dest-dir - "--install-location" install-dest - "--scripts" scripts-dir - "--identifier" id - "--version" (version) - (make-rel "racket.pkg")) - (define pkg-xml (make-rel "racket.xml")) - (system*/show productbuild - "--synthesize" - "--package" (make-rel "racket.pkg") - pkg-xml) - (define synthesized (call-with-input-file* - pkg-xml - read-xml)) - (define updated - (struct-copy document synthesized - [element (let ([e (document-element synthesized)]) - (struct-copy element e - [content - (list* - (element #f #f - 'title - null - (list (pcdata #f #f human-name))) - (element #f #f - 'readme - (list (attribute #f #f 'file "README.txt")) - null) - (element #f #f - 'background - (list (attribute #f #f 'file "background.png") - (attribute #f #f 'alignment "topleft") - (attribute #f #f 'scaling "none")) - null) - (element #f #f - 'installation-check - (list (attribute #f #f 'script "check_exists_already()")) - null) - (element #f #f - 'script - null - (list - (cdata #f #f - @~a{ - function check_exists_already () { - if (system.files.fileExistsAtPath(@|(~s install-dest)|)) { - my.result.type = "Fatal"; - my.result.title = "Folder Exists Already"; - my.result.message = ("Cannot install because a " - + @|(~s (~s human-name))| - + " folder" - + " already exists in the Applications folder." - + " Please remove it and try again."); - return false; - } - return true; - }}))) - (element-content e))]))])) - (call-with-output-file* - pkg-xml - #:exists 'truncate - (lambda (o) - (write-xml updated o))) - (apply system*/show - productbuild - (append - (list "--distribution" pkg-xml - "--package-path" (make-rel 'same) - "--resources" resources-dir - "--identifier" id - "--version" (version)) - (if (string=? sign-identity "") - null - (list "--sign" sign-identity)) - (list pkg-name)))) - -(define (installer-pkg human-name base-name dist-suffix readme sign-identity) - (define pkg-name (format "bundle/~a-~a~a.pkg" - base-name - (system-library-subpath #f) - dist-suffix)) - (make-pkg human-name "bundle/racket" pkg-name readme sign-identity) - pkg-name) diff --git a/pkgs/distro-build-pkgs/distro-build-client/installer-sh.rkt b/pkgs/distro-build-pkgs/distro-build-client/installer-sh.rkt deleted file mode 100644 index 5bec2708b2..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-client/installer-sh.rkt +++ /dev/null @@ -1,87 +0,0 @@ -#lang at-exp racket/base -(require racket/system - racket/file - racket/port - racket/format - racket/runtime-path - file/tar) - -(provide installer-sh) - -(define-runtime-path installer-header "unix-installer/installer-header") - -(define (system/show . l) - (displayln (apply ~a #:separator " " l)) - (unless (apply system* (find-executable-path (car l)) (cdr l)) - (error "failed"))) - -(define (system/read . l) - (displayln (apply ~a #:separator " " l)) - (define o (open-output-bytes)) - (parameterize ([current-output-port o]) - (apply system* (find-executable-path (car l)) (cdr l))) - (read (open-input-bytes (get-output-bytes o)))) - -(define (count-lines i) - (if (input-port? i) - (for/sum ([l (in-lines i)]) 1) - (call-with-input-file* i count-lines))) - -(define (generate-installer-sh src-dir dest target-dir-name human-name release? readme) - (system/show "chmod" - "-R" "g+w" src-dir) - (define tmp-tgz (make-temporary-file "~a.tgz")) - (delete-file tmp-tgz) - (printf "Tarring to ~s\n" tmp-tgz) - (when readme - (call-with-output-file* - (build-path src-dir "README") - #:exists 'truncate - (lambda (o) - (display readme o)))) - (parameterize ([current-directory src-dir]) - (apply tar-gzip tmp-tgz (directory-list))) - (define tree-size (system/read "du" "-hs" src-dir)) - (define archive-cksum (system/read "cksum" tmp-tgz)) - (define script - @~a{#!/bin/sh - - # This is a self-extracting shell script for @|human-name|. - # To use it, just run it, or run "sh" with it as an argument. - - DISTNAME="@|human-name|" - TARGET="@|target-dir-name|" - BINSUM="@|archive-cksum|" - ORIGSIZE="@|tree-size|" - RELEASED="@(if release? "yes" "no")"}) - (define installer-lines (+ (count-lines (open-input-string script)) - (count-lines installer-header) - 2)) - (call-with-output-file* - dest - #:exists 'truncate - (lambda (o) - (display script o) - (newline o) - (fprintf o "BINSTARTLINE=\"~a\"\n" installer-lines) - (call-with-input-file* - installer-header - (lambda (i) - (copy-port i o))) - (call-with-input-file* - tmp-tgz - (lambda (i) - (copy-port i o))))) - (system/show "chmod" "+x" dest) - (delete-file tmp-tgz)) - -(define (installer-sh human-name base-name dir-name release? dist-suffix readme) - (define sh-path (format "bundle/~a-~a~a.sh" - base-name - (system-library-subpath #f) - dist-suffix)) - (generate-installer-sh "bundle/racket" sh-path - dir-name human-name - release? - readme) - sh-path) diff --git a/pkgs/distro-build-pkgs/distro-build-client/installer-tgz.rkt b/pkgs/distro-build-pkgs/distro-build-client/installer-tgz.rkt deleted file mode 100644 index 5e813e70a3..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-client/installer-tgz.rkt +++ /dev/null @@ -1,35 +0,0 @@ -#lang at-exp racket/base -(require racket/system - racket/file - racket/format - file/tar) - -(provide installer-tgz) - -(define (system/show . l) - (displayln (apply ~a #:separator " " l)) - (unless (apply system* (find-executable-path (car l)) (cdr l)) - (error "failed"))) - -(define (generate-tgz src-dir dest-path target-dir-name readme) - (system/show "chmod" "-R" "g+w" src-dir) - (define dest (path->complete-path dest-path)) - (when (file-exists? dest) (delete-file dest)) - (printf "Tarring to ~s\n" dest) - (when readme - (call-with-output-file* - (build-path src-dir "README") - #:exists 'truncate - (lambda (o) - (display readme o)))) - (parameterize ([current-directory src-dir]) - (apply tar-gzip dest #:path-prefix target-dir-name (directory-list)))) - -(define (installer-tgz base-name dir-name dist-suffix readme) - (define tgz-path (format "bundle/~a-src~a.tgz" - base-name - dist-suffix)) - (generate-tgz "bundle/racket" tgz-path - dir-name - readme) - tgz-path) diff --git a/pkgs/distro-build-pkgs/distro-build-client/installer.rkt b/pkgs/distro-build-pkgs/distro-build-client/installer.rkt deleted file mode 100644 index bd5e9d76ad..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-client/installer.rkt +++ /dev/null @@ -1,106 +0,0 @@ -#lang racket/base -(require racket/cmdline - "installer-sh.rkt" - "installer-dmg.rkt" - "installer-pkg.rkt" - "installer-exe.rkt" - "installer-tgz.rkt" - net/url - racket/file - racket/path - racket/port - "display-time.rkt") - -(module test racket/base) - -(define release? #f) -(define source? #f) -(define versionless? #f) -(define mac-pkg? #f) -(define upload-to #f) -(define upload-desc "") -(define download-readme #f) - -(define-values (short-human-name human-name base-name dir-name dist-suffix sign-identity) - (command-line - #:once-each - [("--release") "Create a release installer" - (set! release? #t)] - [("--source") "Create a source installer" - (set! source? #t)] - [("--versionless") "Avoid version number in names and paths" - (set! versionless? #t)] - [("--mac-pkg") "Create a \".pkg\" installer on Mac OS X" - (set! mac-pkg? #t)] - [("--upload") url "Upload installer" - (unless (string=? url "") - (set! upload-to url))] - [("--desc") desc "Description to accompany upload" - (set! upload-desc desc)] - [("--readme") readme "URL for README.txt to include" - (unless (string=? readme "") - (set! download-readme readme))] - #:args - (human-name base-name dir-name dist-suffix sign-identity) - (values human-name - (format "~a v~a" human-name (version)) - (if versionless? - base-name - (format "~a-~a" base-name (version))) - (if (or (and release? (not source?)) - versionless?) - dir-name - (format "~a-~a" dir-name (version))) - (if (string=? dist-suffix "") - "" - (string-append "-" dist-suffix)) - sign-identity))) - -(display-time) - -(define readme - (and download-readme - (let () - (printf "Downloading ~a\n" download-readme) - (define i (get-pure-port (string->url download-readme))) - (begin0 - (port->string i) - (close-input-port i))))) - -(define installer-file - (if source? - (installer-tgz base-name dir-name dist-suffix readme) - (case (system-type) - [(unix) (installer-sh human-name base-name dir-name release? dist-suffix readme)] - [(macosx) (if mac-pkg? - (installer-pkg (if (or release? versionless?) - short-human-name - human-name) - base-name dist-suffix readme sign-identity) - (installer-dmg (if versionless? - short-human-name - human-name) - base-name dist-suffix readme sign-identity))] - [(windows) (installer-exe short-human-name base-name (or release? versionless?) - dist-suffix readme)]))) - -(call-with-output-file* - (build-path "bundle" "installer.txt") - #:exists 'truncate/replace - (lambda (o) - (fprintf o "~a\n" installer-file) - (fprintf o "~a\n" upload-desc))) - -(when upload-to - (printf "Upload ~a to ~a\n" installer-file upload-to) - (define i - (put-pure-port - (string->url (format "~a~a" - upload-to - (path->string (file-name-from-path installer-file)))) - (file->bytes installer-file) - (list (string-append "Description: " upload-desc)))) - (unless (equal? (read i) #t) - (error "file upload failed"))) - -(display-time) diff --git a/pkgs/distro-build-pkgs/distro-build-client/macosx-installer/pkg-bg.png b/pkgs/distro-build-pkgs/distro-build-client/macosx-installer/pkg-bg.png deleted file mode 100644 index 1d606577d0..0000000000 Binary files a/pkgs/distro-build-pkgs/distro-build-client/macosx-installer/pkg-bg.png and /dev/null differ diff --git a/pkgs/distro-build-pkgs/distro-build-client/macosx-installer/racket-rising.png b/pkgs/distro-build-pkgs/distro-build-client/macosx-installer/racket-rising.png deleted file mode 100644 index 068a0bcccd..0000000000 Binary files a/pkgs/distro-build-pkgs/distro-build-client/macosx-installer/racket-rising.png and /dev/null differ diff --git a/pkgs/distro-build-pkgs/distro-build-client/set-config.rkt b/pkgs/distro-build-pkgs/distro-build-client/set-config.rkt deleted file mode 100644 index 484bf90d94..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-client/set-config.rkt +++ /dev/null @@ -1,49 +0,0 @@ -#lang racket/base -(require racket/cmdline - racket/file - racket/path) - -(provide set-config) - -(module test racket/base) - -(module+ main - (command-line - #:args - (dest-config-file install-name build-stamp - doc-search . catalog) - (set-config dest-config-file - install-name build-stamp - doc-search catalog))) - -(define (set-config dest-config-file - install-name build-stamp - doc-search catalogs) - (define orig - (if (file-exists? dest-config-file) - (call-with-input-file* dest-config-file read) - (hash))) - - (let* ([table orig] - [table - (if (equal? doc-search "") - table - (hash-set table 'doc-search-url doc-search))] - [table (if (equal? catalogs '("")) - table - (hash-set table 'catalogs - (for/list ([c (in-list catalogs)]) - (if (equal? c "") - #f - c))))] - [table (if (equal? install-name "") - table - (hash-set table 'installation-name install-name))] - [table (hash-set table 'build-stamp build-stamp)]) - (unless (equal? table orig) - (make-directory* (path-only dest-config-file)) - (call-with-output-file dest-config-file - #:exists 'truncate - (lambda (o) - (write table o) - (newline o)))))) diff --git a/pkgs/distro-build-pkgs/distro-build-client/unix-installer/installer-header b/pkgs/distro-build-pkgs/distro-build-client/unix-installer/installer-header deleted file mode 100644 index 6cb7fcb8ee..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-client/unix-installer/installer-header +++ /dev/null @@ -1,507 +0,0 @@ - -############################################################################### -## Command-line flags - -show_help() { - echo "Command-line flags:" - echo "/ --unix-style : install as Unix-style" - echo "\ --in-place : install in-place (not Unix-style)" - echo " --dest : install to " - echo " --create-dir : create destination for Unix-style if it does not exist" - echo " --create-links : create links in for in-place install" - echo " -h, --help : show this help" -} - -where="" -unixstyle="" -accept_dirs="" -SYSDIR="" -SYSDIR_set="" - -while test $# -gt 0 ; do - case "$1" in - -h | --help) - show_help - exit 0 - ;; - --unix-style) - if test "$unixstyle" != "" ; then - echo "conflicting or redundant flag: --unix-style" - exit 1 - fi - unixstyle="Y" - accept_dirs="Y" - shift - ;; - --in-place) - if test "$unixstyle" != "" ; then - echo "conflicting or redundant flag: --in-place" - exit 1 - fi - unixstyle="N" - SYSDIR_set="Y" - shift - ;; - --dest) - shift - if test $# -lt 1 ; then - echo "missing path for --dest" - exit 1 - fi - where="$1" - if test "$where" = "" ; then - echo "empty path for --dest" - exit 1 - fi - shift - ;; - --create-dir) - if test "$create_dir" != "" ; then - echo "redundant flag: --create-dir" - exit 1 - fi - create_dir="Y" - shift - ;; - --create-links) - if test "$SYSDIR" != "" ; then - echo "redundant flag: --create-links" - exit 1 - fi - shift - if test $# -lt 1 ; then - echo "missing path for --create-links" - exit 1 - fi - SYSDIR="$1" - SYSDIR_set="Y" - if test "$SYSDIR" = "" ; then - echo "empty path for --create-links" - exit 1 - fi - shift - ;; - *) - echo "unrecognized command-line argument: $1" - exit 1 - ;; - esac -done - -############################################################################### -## Utilities - -PATH=/usr/bin:/bin - -if test "x`echo -n`" = "x-n"; then - echon() { /bin/echo "$*\c"; } -else - echon() { echo -n "$*"; } -fi - -rm_on_abort="" -failwith() { - err="Error: " - if test "x$1" = "x-noerror"; then err=""; shift; fi - echo "$err$*" 1>&2 - if test ! "x$rm_on_abort" = "x" && test -e "$rm_on_abort"; then - echon " (Removing installation files in $rm_on_abort)" - "$rm" -rf "$rm_on_abort" - echo "" - fi - exit 1 -} -# intentional aborts -abort() { failwith -noerror "Aborting installation."; } -# unexpected exits -exithandler() { echo ""; failwith "Aborting..."; } - -trap exithandler 2 3 9 15 - -lookfor() { - saved_IFS="${IFS}" - IFS=":" - for dir in $PATH; do - if test -x "$dir/$1"; then - eval "$1=$dir/$1" - IFS="$saved_IFS" - return - fi - done - IFS="$saved_IFS" - failwith "could not find \"$1\"." -} - -lookfor rm -lookfor ls -lookfor ln -lookfor tail -lookfor cksum -lookfor tar -lookfor gunzip -lookfor mkdir -lookfor basename -lookfor dirname - -# substitute env vars and tildes -expand_path_var() { - eval "expanded_val=\"\$$1\"" - first_part="${expanded_val%%/*}" - if [ "x$first_part" = "x$expanded_val" ]; then - rest_parts="" - else - rest_parts="/${expanded_val#*/}" - fi - case "x$first_part" in - x*" "* ) ;; - x~* ) expanded_val="`eval \"echo $first_part\"`$rest_parts" ;; - esac - eval "$1=\"$expanded_val\"" -} - -# Need this to make new `tail' respect old-style command-line arguments. Can't -# use `tail -n #' because some old tails won't know what to do with that. -_POSIX2_VERSION=199209 -export _POSIX2_VERSION - -origwd="`pwd`" -installer_file="$0" -cat_installer() { - oldwd="`pwd`"; cd "$origwd" - "$tail" +"$BINSTARTLINE" "$installer_file" - cd "$oldwd" -} - -echo "This program will extract and install $DISTNAME." -echo "" -echo "Note: the required diskspace for this installation is $ORIGSIZE." -echo "" - -############################################################################### -## What kind of installation? - -if test "$unixstyle" = ""; then - echo "Do you want a Unix-style distribution?" - echo " In this distribution mode files go into different directories according" - echo " to Unix conventions. A \"racket-uninstall\" script will be generated" - echo " to be used when you want to remove the installation. If you say 'no'," - echo " the whole Racket directory is kept in a single installation directory" - echo " (movable and erasable), possibly with external links into it -- this is" - echo " often more convenient, especially if you want to install multiple" - echo " versions or keep it in your home directory." - if test ! "x$RELEASED" = "xyes"; then - echo "*** This is a non-release build: such a Unix-style distribution is NOT" - echo "*** recommended, because it cannot be used to install multiple versions" - echo "*** in the default location." - fi - unixstyle="x" - while test "$unixstyle" = "x"; do - echon "Enter yes/no (default: no) > " - read unixstyle - case "$unixstyle" in - [yY]* ) unixstyle="Y" ;; - [nN]* ) unixstyle="N" ;; - "" ) unixstyle="N" ;; - * ) unixstyle="x" ;; - esac - done - echo "" -fi - -############################################################################### -## Where do you want it? -## sets $where to the location: target path for wholedir, prefix for unixstyle - -if test "$where" = ""; then - if test "$unixstyle" = "Y"; then - echo "Where do you want to base your installation of $DISTNAME?" - echo " (If you've done such an installation in the past, either" - echo " enter the same directory, or run 'racket-uninstall' manually.)" - TARGET1="..." - else - echo "Where do you want to install the \"$TARGET\" directory tree?" - TARGET1="$TARGET" - fi - echo " 1 - /usr/$TARGET1 [default]" - echo " 2 - /usr/local/$TARGET1" - echo " 3 - ~/$TARGET1 ($HOME/$TARGET1)" - echo " 4 - ./$TARGET1 (here)" - if test "$unixstyle" = "Y"; then - echo " Or enter a different directory prefix to install in." - else - echo " Or enter a different \"racket\" directory to install in." - fi - echon "> " - read where - - # numeric choice (make "." and "./" synonym for 4) - if test "$unixstyle" = "Y"; then TARGET1="" - else TARGET1="/$TARGET"; fi - case "x$where" in - x | x1 ) where="/usr$TARGET1" ;; - x2 ) where="/usr/local${TARGET1}" ;; - x3 ) where="${HOME}${TARGET1}" ;; - x4 | x. | x./ ) where="`pwd`${TARGET1}" ;; - * ) expand_path_var where ;; - esac -fi - -############################################################################### -## Default system directories prefixed by $1, mimic configure behavior -## used for unixstyle targets and for wholedir links - -set_dirs() { - # unixstyle: uses all of these - # wholedir: uses only bindir, mandir, and appsdir, no need for the others - bindir="$1/bin" - libdir="$1/lib" - incrktdir="$1/include/$TARGET" - librktdir="$1/lib/$TARGET" - sharerktdir="$1/share/$TARGET" - configdir="$1/etc/$TARGET" - appsdir="$1/share/applications" - has_share="N" - if test -d "$1/share"; then has_share="Y"; fi - if test "$has_share" = "N" && test -d "$1/doc"; then docdir="$1/doc/$TARGET" - else docdir="$1/share/$TARGET/doc" - fi - if test "$has_share" = "N" && test -d "$1/man"; then mandir="$1/man" - else mandir="$1/share/man" - fi -} - -############################################################################### -## Integrity check and unpack into $1 -## also sets $INSTDIR to the directory in its canonical form - -unpack_installation() { - T="$1" - # integrity check - echo "" - echon "Checking the integrity of the binary archive... " - SUM="`cat_installer | \"$cksum\"`" || failwith "problems running cksum." - SUM="`set $SUM; echo $1`" - test "$BINSUM" = "$SUM" || failwith "bad CRC checksum." - echo "ok." - # test that the target does not exists - here="N" - if test -d "$T" || test -f "$T"; then - if test -d "$T" && test -x "$T"; then - # use the real name, so "/foo/.." shows as an explicit "/" - oldwd="`pwd`"; cd "$T"; T="`pwd`"; cd "$oldwd" - fi - if test -f "$T"; then echon "\"$T\" exists (as a file)" - elif test ! "`pwd`" = "$T"; then echon "\"$T\" exists" - else here="Y"; echon "\"$T\" is where you ran the installer from" - fi - echon ", delete? " - read R - case "$R" in - [yY]* ) - echon "Deleting old \"$T\"... " - "$rm" -rf "$T" || failwith "could not delete \"$T\"." - echo "done." - ;; - * ) abort ;; - esac - fi - # unpack - rm_on_abort="$T" - "$mkdir" -p "$T" || failwith "could not create directory: $T" - if test "$here" = "Y"; then - cd "$T"; INSTDIR="$T" - echo "*** Note: your original directory was deleted, so you will need" - echo "*** to 'cd' back into it when the installer is done, otherwise" - echo "*** it will look like you have an empty directory." - sleep 1 - else oldwd="`pwd`"; cd "$T"; INSTDIR="`pwd`"; cd "$oldwd" - fi - rm_on_abort="$INSTDIR" - echo "Unpacking into \"$INSTDIR\" (Ctrl+C to abort)..." - cat_installer | "$gunzip" -c \ - | { cd "$INSTDIR" - "$tar" xf - || failwith "problems during unpacking of binary archive." - } - test -d "$INSTDIR/collects" \ - || failwith "unpack failed (could not find \"$T/collects\")." - echo "Done." -} - -############################################################################### -## Whole-directory installations - -wholedir_install() { - - unpack_installation "$where" - rm_on_abort="" - - if test "$SYSDIR_set" != "Y"; then - echo "" - echo "If you want to install new system links within the \"bin\", \"man\"" - echo " and \"share/applications\" subdirectories of a common directory prefix" - echo " (for example, \"/usr/local\") then enter the prefix of an existing" - echo " directory that you want to use. This might overwrite existing symlinks," - echo " but not files." - echon "(default: skip links) > " - read SYSDIR - fi - if test "x$SYSDIR" = "x"; then : - elif test ! -d "$SYSDIR"; then - echo "\"$SYSDIR\" does not exist, skipping links." - elif test ! -x "$SYSDIR" || test ! -w "$SYSDIR"; then - echo "\"$SYSDIR\" is not writable, skipping links." - else - oldwd="`pwd`"; cd "$SYSDIR"; SYSDIR="`pwd`"; cd "$oldwd" - set_dirs "$SYSDIR" - install_links() { # tgtdir(absolute) srcdir(relative to INSTDIR) - if ! test -d "$1"; then - echo "\"$1\" does not exist, skipping." - elif ! test -x "$1" || ! test -w "$1"; then - echo "\"$1\" is not writable, skipping" - else - echo "Installing links in \"$1\"..." - printsep=" " - cd "$1" - for x in `cd "$INSTDIR/$2"; ls`; do - echon "${printsep}$x"; printsep=", " - if test -h "$x"; then rm -f "$x"; fi - if test -d "$x" || test -f "$x"; then - echon " skipped (non-link exists)" - elif ! "$ln" -s "$INSTDIR/$2/$x" "$x"; then - echon " skipped (symlink failed)" - fi - done - echo ""; echo " done." - fi - } - install_links "$bindir" "bin" - install_links "$mandir/man1" "man/man1" - install_links "$appsdir" "share/applications" - fi - -} - -############################################################################### -## Unix-style installations - -dir_createable() { - tdir="`\"$dirname\" \"$1\"`" - if test -d "$tdir" && test -x "$tdir" && test -w "$tdir"; then return 0 - elif test "$tdir" = "/"; then return 1 - else dir_createable "$tdir"; fi -} -show_dir_var() { - if test -f "$2"; then status="error: not a directory!"; err="Y" - elif test ! -d "$2"; then - if dir_createable "$2"; then status="will be created" - else status="error: not writable!"; err="Y"; fi - elif test ! -w "$2"; then status="error: not writable!"; err="Y" - else status="exists" - fi - echo " $1 $2 ($status)" -} - -unixstyle_install() { - - if test -f "$where"; then - failwith "The entered base directory exists as a file: $where" - elif test ! -d "$where"; then - echo "Base directory does not exist: $where" - if test "$create_dir" != "Y"; then - echon " should I create it? (default: yes) " - read R; case "$R" in [nN]* ) abort ;; esac - fi - "$mkdir" -p "$where" || failwith "could not create directory: $where" - elif test ! -w "$where"; then - failwith "The entered base directory is not writable: $where" - fi - cd "$where" || failwith "Base directory does not exist: $where" - where="`pwd`"; cd "$origwd" - - set_dirs "$where" - # loop for possible changes - done="N"; retry="N" - if test "$accept_dirs" = "Y" ; then done="Y"; fi - while test ! "$done" = "Y" || test "x$err" = "xY" ; do - err="N" - if test "$retry" = "N"; then - echo "" - echo "Target Directories:" - show_dir_var "[e] Executables " "$bindir" - show_dir_var "[o] Libraries " "$librktdir" - show_dir_var "[s] Shared files " "$sharerktdir" - show_dir_var "[c] Configuration " "$configdir" - show_dir_var "[d] Documentation " "$docdir" - show_dir_var "[a] .desktop files" "$appsdir" - show_dir_var "[m] Man Pages " "$mandir" - show_dir_var "[l] C Libraries " "$libdir" - show_dir_var "[h] C headers " "$incrktdir" - echo "Enter a letter to change an entry, or enter to continue." - fi - retry="N" - echon "> "; read change_what - read_dir() { - echon "New directory (absolute or relative to $where): "; read new_dir - expand_path_var new_dir - case "$new_dir" in - "/"* ) eval "$1=\"$new_dir\"" ;; - * ) eval "$1=\"$where/$new_dir\"" ;; - esac - } - case "$change_what" in - [eE]* ) read_dir bindir ;; - [dD]* ) read_dir docdir ;; - [lL]* ) read_dir libdir ;; - [hH]* ) read_dir incrktdir ;; - [oO]* ) read_dir librktdir ;; - [sS]* ) read_dir sharerktdir ;; - [cC]* ) read_dir configdir ;; - [aA]* ) read_dir appsdir ;; - [mM]* ) read_dir mandir ;; - "" ) if test "$err" = "N"; then done="Y" - else echo "*** Please fix erroneous paths to proceed"; fi ;; - * ) retry="Y" ;; - esac - done - - if test -x "$bindir/racket-uninstall"; then - echo "" - echo "A previous Racket uninstaller is found at" - echo " \"$bindir/racket-uninstall\"," - echon " should I run it? (default: yes) " - read R - case "$R" in - [nN]* ) abort ;; - * ) echon " running uninstaller..." - "$bindir/racket-uninstall" || failwith "problems during uninstall" - echo " done." ;; - esac - fi - - tmp="$where/$TARGET-tmp-install" - if test -f "$tmp" || test -d "$tmp"; then - echo "\"$tmp\" already exists (needed for the installation)," - echon " ok to remove it? " - read R; case "$R" in [yY]* ) "$rm" -rf "$tmp" ;; * ) abort ;; esac - fi - unpack_installation "$tmp" - - cd "$where" - "$tmp/bin/racket" "$tmp/collects/setup/unixstyle-install.rkt" \ - "move" "$tmp" "$bindir" "$sharerktdir/collects" "$docdir" "$libdir" \ - "$incrktdir" "$librktdir" "$sharerktdir" "$configdir" "$appsdir" "$mandir" \ - || failwith "installation failed" - -} - -############################################################################### -## Run the right installer now - -if test "$unixstyle" = "Y"; then unixstyle_install; else wholedir_install; fi - -echo "" -echo "Installation complete." - -exit - -========== tar.gz file follows ========== diff --git a/pkgs/distro-build-pkgs/distro-build-client/unpack-collects.rkt b/pkgs/distro-build-pkgs/distro-build-client/unpack-collects.rkt deleted file mode 100644 index 7b481b6764..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-client/unpack-collects.rkt +++ /dev/null @@ -1,32 +0,0 @@ -#lang racket/base -(require racket/cmdline - racket/file - racket/port - net/url - file/untgz - "display-time.rkt") - -(module test racket/base) - -(define dest-dir "bundle/racket") - -(define server - (command-line - #:args (server) - server)) - -(define zip-content - (port->bytes - (get-pure-port - (combine-url/relative - (string->url server) - "collects.tgz")))) - -(display-time) - -(define collects-dir (build-path dest-dir "collects")) -(when (directory-exists? collects-dir) - (delete-directory/files collects-dir)) - -(untgz (open-input-bytes zip-content) - #:dest dest-dir) diff --git a/pkgs/distro-build-pkgs/distro-build-client/windows-installer/header-r.bmp b/pkgs/distro-build-pkgs/distro-build-client/windows-installer/header-r.bmp deleted file mode 100644 index 69a3bd4631..0000000000 Binary files a/pkgs/distro-build-pkgs/distro-build-client/windows-installer/header-r.bmp and /dev/null differ diff --git a/pkgs/distro-build-pkgs/distro-build-client/windows-installer/header.bmp b/pkgs/distro-build-pkgs/distro-build-client/windows-installer/header.bmp deleted file mode 100644 index 65467b088e..0000000000 Binary files a/pkgs/distro-build-pkgs/distro-build-client/windows-installer/header.bmp and /dev/null differ diff --git a/pkgs/distro-build-pkgs/distro-build-client/windows-installer/installer.ico b/pkgs/distro-build-pkgs/distro-build-client/windows-installer/installer.ico deleted file mode 100644 index 632f0551f0..0000000000 Binary files a/pkgs/distro-build-pkgs/distro-build-client/windows-installer/installer.ico and /dev/null differ diff --git a/pkgs/distro-build-pkgs/distro-build-client/windows-installer/uninstaller.ico b/pkgs/distro-build-pkgs/distro-build-client/windows-installer/uninstaller.ico deleted file mode 100644 index 2b2e20e2c0..0000000000 Binary files a/pkgs/distro-build-pkgs/distro-build-client/windows-installer/uninstaller.ico and /dev/null differ diff --git a/pkgs/distro-build-pkgs/distro-build-client/windows-installer/welcome.bmp b/pkgs/distro-build-pkgs/distro-build-client/windows-installer/welcome.bmp deleted file mode 100644 index 5415c45e6d..0000000000 Binary files a/pkgs/distro-build-pkgs/distro-build-client/windows-installer/welcome.bmp and /dev/null differ diff --git a/pkgs/distro-build-pkgs/distro-build-lib/LICENSE.txt b/pkgs/distro-build-pkgs/distro-build-lib/LICENSE.txt deleted file mode 100644 index 2f13367cd2..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-lib/LICENSE.txt +++ /dev/null @@ -1,11 +0,0 @@ -distro-build -Copyright (c) 2010-2014 PLT Design Inc. - -This package is distributed under the GNU Lesser General Public -License (LGPL). This means that you can link this package into proprietary -applications, provided you follow the rules stated in the LGPL. You -can also modify this package; if you distribute a modified version, -you must distribute it under the terms of the LGPL, which in -particular means that you must release the source code for the -modified software. See http://www.gnu.org/copyleft/lesser.html -for more information. diff --git a/pkgs/distro-build-pkgs/distro-build-lib/info.rkt b/pkgs/distro-build-pkgs/distro-build-lib/info.rkt deleted file mode 100644 index cb259c254d..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-lib/info.rkt +++ /dev/null @@ -1,12 +0,0 @@ -#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-pkgs/distro-build-server/LICENSE.txt b/pkgs/distro-build-pkgs/distro-build-server/LICENSE.txt deleted file mode 100644 index 2f13367cd2..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/LICENSE.txt +++ /dev/null @@ -1,11 +0,0 @@ -distro-build -Copyright (c) 2010-2014 PLT Design Inc. - -This package is distributed under the GNU Lesser General Public -License (LGPL). This means that you can link this package into proprietary -applications, provided you follow the rules stated in the LGPL. You -can also modify this package; if you distribute a modified version, -you must distribute it under the terms of the LGPL, which in -particular means that you must release the source code for the -modified software. See http://www.gnu.org/copyleft/lesser.html -for more information. diff --git a/pkgs/distro-build-pkgs/distro-build-server/assemble-site.rkt b/pkgs/distro-build-pkgs/distro-build-server/assemble-site.rkt deleted file mode 100644 index 93ea397837..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/assemble-site.rkt +++ /dev/null @@ -1,142 +0,0 @@ -#lang racket/base -(require racket/cmdline - racket/file - net/url - "download-page.rkt" - "indexes.rkt" - (only-in distro-build/config extract-options) - (only-in plt-web site)) - -(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 from-catalog-dir-to-pkgs-dir (build-path 'up)) -(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"))) - -(define site-title (hash-ref config - '#:site-title - "Racket Downloads")) - -(define www-site (and (hash-ref config '#:plt-web-style? #t) - (site "www" - #:url "http://racket-lang.org/" - #:generate? #f))) - -(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) - (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 (relative-path->relative-url-string - (build-path - from-catalog-dir-to-pkgs-dir - 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) -(when (directory-exists? native-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) -(generate-index-html dest-dir log-dir www-site) - -(copy installers-dir) -(generate-index-html dest-dir installers-dir www-site) - -(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) - (generate-index-html dest-dir pdf-doc-dir www-site)) -(copy "stamp.txt") -(copy (build-path "origin" "collects.tgz")) - -(make-download-page (build-path build-dir - installers-dir - "table.rktd") - #:plt-www-site www-site - #:title site-title - #: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-pkgs/distro-build-server/config.rkt b/pkgs/distro-build-pkgs/distro-build-server/config.rkt deleted file mode 100644 index 21dc7de894..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/config.rkt +++ /dev/null @@ -1,205 +0,0 @@ -#lang racket/base - -(require racket/format - (for-syntax syntax/kerncase - racket/base)) - -(provide (except-out (all-from-out racket/base) - #%module-begin) - (rename-out [module-begin #%module-begin]) - sequential - parallel - machine - site-config? - site-config-tag - site-config-options - site-config-content - current-mode - current-stamp - extract-options) - -(module reader syntax/module-reader - distro-build/config) - -(struct site-config (tag options content)) - -(define-syntax-rule (module-begin form ...) - (#%plain-module-begin (site-begin #f form ...))) - -(define-syntax (site-begin stx) - (syntax-case stx () - [(_ #t) #'(begin)] - [(_ #f) - (raise-syntax-error 'site - "did not find an expression for the site configuration")] - [(_ found? next . rest) - (let ([expanded (local-expand #'next 'module (kernel-form-identifier-list))]) - (syntax-case expanded (begin) - [(begin next1 ...) - #`(site-begin found? next1 ... . rest)] - [(id . _) - (and (identifier? #'id) - (ormap (lambda (kw) (free-identifier=? #'id kw)) - (syntax->list #'(require - provide - define-values - define-syntaxes - begin-for-syntax - module - module* - #%require - #%provide)))) - #`(begin #,expanded (site-begin found? . rest))] - [_else - (if (syntax-e #'found?) - (raise-syntax-error 'site - "found second top-level expression" - #'next) - #`(begin - (provide site-config) - (define site-config (let ([v #,expanded]) - (unless (site-config? v) - (error 'site - (~a "expression did not produce a site configuration\n" - " result: ~e\n" - " expression: ~.s") - v - 'next)) - v)) - (site-begin - #t - . rest)))]))])) - -(define sequential - (make-keyword-procedure - (lambda (kws kw-vals . subs) - (constructor kws kw-vals subs - check-group-keyword 'sequential)))) -(define parallel - (make-keyword-procedure - (lambda (kws kw-vals . subs) - (constructor kws kw-vals subs - check-group-keyword 'parallel)))) -(define machine - (make-keyword-procedure - (lambda (kws kw-vals) - (constructor kws kw-vals null - check-machine-keyword 'machine)))) - -(define (constructor kws kw-vals subs check tag) - (site-config - tag - (for/hash ([kw (in-list kws)] - [val (in-list kw-vals)]) - (define r (check kw val)) - (when (eq? r 'bad-keyword) - (error tag - (~a "unrecognized keyword for option\n" - " keyword: ~s") - kw)) - (unless (check kw val) - (error tag - (~a "bad value for keyword\n" - " keyword: ~s\n" - " value: ~e") - kw - val)) - (values kw val)) - (for/list ([sub subs]) - (unless (site-config? sub) - (raise-argument-error tag "site-config?" sub)) - sub))) - -(define (check-group-keyword kw val) - (case kw - [(#:pkgs) (and (list? val) (andmap simple-string? val))] - [(#:doc-search) (string? val)] - [(#:dist-name) (string? val)] - [(#:dist-base) (simple-string? val)] - [(#:dist-dir) (simple-string? val)] - [(#:dist-suffix) (simple-string? val)] - [(#:dist-catalogs) (and (list? val) (andmap string? val))] - [(#:dist-base-url) (string? val)] - [(#:install-name) (string? val)] - [(#:build-stamp) (string? val)] - [(#:max-vm) (real? val)] - [(#:server) (simple-string? val)] - [(#:server-port) (port-no? val)] - [(#:server-hosts) (and (list? val) (andmap simple-string? val))] - [(#:host) (simple-string? val)] - [(#:user) (or (not val) (simple-string? val))] - [(#:port) (port-no? val)] - [(#:dir) (path-string? val)] - [(#:vbox) (string? val)] - [(#:platform) (memq val '(unix macosx windows windows/bash))] - [(#:configure) (and (list? val) (andmap string? val))] - [(#:bits) (or (equal? val 32) (equal? val 64))] - [(#:vc) (string? val)] - [(#:sign-identity) (string? val)] - [(#:timeout) (real? val)] - [(#:j) (exact-positive-integer? val)] - [(#:repo) (string? val)] - [(#:clean?) (boolean? val)] - [(#:pull?) (boolean? val)] - [(#:release?) (boolean? val)] - [(#:source?) (boolean? val)] - [(#:source-runtime?) (boolean? val)] - [(#:source-pkgs?) (boolean? val)] - [(#:versionless?) (boolean? val)] - [(#:mac-pkg?) (boolean? val)] - [(#:site-dest) (path-string? val)] - [(#:site-help) (hash? val)] - [(#:site-title) (string? val)] - [(#:pdf-doc?) (boolean? val)] - [(#:max-snapshots) (real? val)] - [(#:plt-web-style?) (boolean? val)] - [(#:pause-before) (and (real? val) (not (negative? val)))] - [(#:pause-after) (and (real? val) (not (negative? val)))] - [(#:readme) (or (string? val) - (and (procedure? val) - (procedure-arity-includes? val 1)))] - [(#:email-to) (and (list? val) (andmap email? val))] - [(#:email-from) (email? val)] - [(#:smtp-server) (simple-string? val)] - [(#:smtp-port) (port-no? val)] - [(#:smtp-connect) (memq val '(plain ssl tls))] - [(#:smtp-user) (or (not val) (string? val))] - [(#:smtp-password) (or (not val) (string? val))] - [(#:custom) (and (hash? val) - (for/and ([k (in-hash-keys val)]) - (keyword? k)))] - [else 'bad-keyword])) - -(define (check-machine-keyword kw val) - (case kw - [(#:name) (string? val)] - [else (check-group-keyword kw val)])) - -(define (port-no? val) - (and (exact-integer? val) (<= 1 val 65535))) - -(define (simple-string? s) - (and (string? s) - ;; No spaces, quotes, or other things that could - ;; break a command-line, path, or URL construction: - (regexp-match #rx"^[-a-zA-A0-9.]*$" s))) - -(define (email? s) - (and (string? s) - (regexp-match? #rx"@" s))) - -(define current-mode (make-parameter "default")) - -(define current-stamp - (let* ([f (build-path "build" "stamp.txt")] - [s (and (file-exists? f) - (call-with-input-file* f read-line))]) - (lambda () - (if (string? s) - s - "now")))) - -(define (extract-options config-file config-mode) - (parameterize ([current-mode config-mode]) - (site-config-options - (dynamic-require (path->complete-path config-file) 'site-config)))) diff --git a/pkgs/distro-build-pkgs/distro-build-server/download-page.rkt b/pkgs/distro-build-pkgs/distro-build-server/download-page.rkt deleted file mode 100644 index bf907adeaf..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/download-page.rkt +++ /dev/null @@ -1,404 +0,0 @@ -#lang at-exp racket/base -(require racket/format - racket/path - racket/system - racket/list - racket/date - racket/file - net/url - openssl/sha1 - scribble/html - (only-in plt-web site page call-with-registered-roots) - (only-in plt-web/style columns)) - -(provide make-download-page - get-installers-table - (struct-out past-success)) - -(module+ main - (require racket/cmdline) - - (define args null) - (define (arg! kw val) - (set! args (cons (cons kw val) args))) - - (define table-file - (command-line - #:once-each - [("--at") url "URL for installers relative to download page" - (arg! '#:installers-url url)] - [("--dest") file "Write to " - (arg! '#:dest file)] - [("--git") dir "Report information from git clone " - (arg! '#:git-clone dir)] - [("--plt") "Use PLT web page style" - (arg! '#:plt-web-style? #t)] - #:args - (table-file) - table-file)) - - (let ([args (sort args keywordhtml p) - (cond - [(pair? p) - (define has-attr? (or (and (pair? (cadr p)) - (pair? (cadr p))) - (null? (cadr p)))) - (apply element (car p) (if has-attr? - (cadr p) - null) - (map xexpr->html (if has-attr? (cddr p) (cdr p))))] - [(string? p) p] - [(or (symbol? p) (number? p)) (entity p)] - [else (error "unknown xexpr")])) - - (define (get-site-help last-col) - (let ([h (hash-ref site-help last-col #f)]) - (if h - (let* ([id (~a "help" (gensym))] - [toggle (let ([elem (~a "document.getElementById" "('" id "')")]) - (~a elem ".style.display = ((" elem ".style.display == 'inline') ? 'none' : 'inline');" - " return false;"))]) - (list - " " - (div class: "helpbutton" - (a href: "#" - class: "helpbuttonlabel" - onclick: toggle - title: "explain" - nbsp "?" nbsp)) - (div class: "hiddenhelp" - id: id - onclick: toggle - style: "display: none" - (div class: "helpcontent" - (div class: "helptext" - (xexpr->html h)))))) - null))) - - (define page-site (and plt-style? - (site "download-page" - #:url "http://page.racket-lang.org/" - #:navigation (if docs-url - (list nbsp - nbsp - (a href: docs-url "Documentation") - (if pdf-docs-url - (a href: pdf-docs-url "PDF") - nbsp)) - null) - #:share-from (or www-site - (site "www" - #:url "http://racket-lang.org/" - #:generate? #f))))) - - (define orig-directory (current-directory)) - - (define page-headers - (style/inline @~a|{ - .detail { font-size: small; font-weight: normal; } - .checksum, .path { font-family: monospace; } - .group { background-color : #ccccff; padding-left: 0.5ex; } - .major { font-weight : bold; font-size : large; left-border: 1ex; } - .minor { font-weight : bold; } - .download-table { border: 0px solid white; } - .download-table td { display: table-cell; padding: 0px 2px 0px 2px; border: 0px solid white; } - .helpbutton { - display: inline; - font-family: sans-serif; - font-size : x-small; - background-color: #ffffee; - border: 1px solid black; - vertical-align: top; - } - .helpbuttonlabel{ vertical-align: top; } - .hiddenhelp { - width: 0em; - position: absolute; - } - .helpcontent { - width: 20em; - font-size : small; - font-weight : normal; - background-color: #ffffee; - padding: 10px; - border: 1px solid black; - } - a { text-decoration: none; } - }|)) - - (define (strip-detail s) - (if (string? s) - (regexp-replace #rx";.*" s "") - s)) - - (define (add-detail s e) - (define m (and (string? s) - (regexp-match #rx"(?<=; )(.*)$" s))) - (cond - [m - (span e (span class: "detail" - nbsp - (cadr m)))] - [else e])) - - (define page-body - (list - (if page-title - ((if plt-style? h3 h2) page-title) - null) - (table - class: "download-table" - (for/list ([elem (in-list elems)]) - (define key (car elem)) - (define inst (and key (hash-ref table-data key))) - (define mid-cols (if (null? (cdr elem)) - #f - (drop-right (cdr elem) 1))) - (define last-col (last elem)) - (define level-class - (case (length elem) - [(2) (~a "major" (if key "" " group"))] - [(3) "minor"] - [else "subminor"])) - (define num-cols (if current-rx - "7" - "5")) - (cond - [(not mid-cols) - (tr (td colspan: num-cols nbsp))] - [inst - (tr (td - (for/list ([col (in-list mid-cols)]) - (span nbsp nbsp nbsp)) - (add-detail - last-col - (if (past-success? inst) - ;; Show missing installer - (span class: (string-append "no-installer " level-class) - (strip-detail last-col)) - ;; Link to installer - (a class: (string-append "installer " level-class) - href: (url->string - (combine-url/relative - (string->url installers-url) - inst)) - (strip-detail last-col)))) - (get-site-help last-col)) - (td nbsp) - (td (if (past-success? inst) - (span class: "detail" "") - (span class: "detail" - (~r (/ (file-size (build-path (path-only table-file) - inst)) - (* 1024 1024)) - #:precision 1) - " MB"))) - (td nbsp) - (td (if (past-success? inst) - (span class: "detail" - (if (and log-dir - (file-exists? (build-path log-dir key))) - (list - (a href: (url->string - (combine-url/relative - (string->url log-dir-url) - key)) - "build failed") - "; ") - null) - "last success: " - (a href: (~a (past-success-relative-url inst)) - (past-success-name inst))) - (span class: "detail" - "SHA1: " - (span class: "checksum" - (call-with-input-file* - (build-path (path-only table-file) - inst) - sha1))))) - (if current-rx - (list - (td nbsp) - (td (span class: "detail" - (let ([inst-path (if (past-success? inst) - (past-success-file inst) - inst)]) - (if (regexp-match? current-rx inst-path) - (a href: (url->string - (combine-url/relative - (string->url installers-url) - (bytes->string/utf-8 - (regexp-replace current-rx - (string->bytes/utf-8 inst-path) - #"current")))) - "as " ldquo "current" rdquo) - nbsp))))) - null))] - [else - (tr (td class: level-class - colspan: num-cols - (for/list ([col (in-list mid-cols)]) - (span nbsp nbsp nbsp)) - (add-detail - last-col - (strip-detail last-col)) - (get-site-help last-col)))]))) - (if (and docs-url - (not site)) - (p (a href: docs-url "Documentation") - (if pdf-docs-url - (list - nbsp - nbsp - (span class: "detail" - (a href: pdf-docs-url "[also available as PDF]"))) - null)) - null) - (if git-clone - (let ([git (find-executable-path "git")]) - (define origin (let ([s (system*/string git "remote" "show" "origin")]) - (define m (regexp-match #rx"(?m:Fetch URL: (.*)$)" s)) - (if m - (cadr m) - "???"))) - (define stamp (system*/string git "log" "-1" "--format=%H")) - (p - (div (span class: "detail" "Repository: " (span class: "path" origin))) - (div (span class: "detail" "Commit: " (span class: "checksum" stamp))) - (or log-link null))) - null) - (if (and log-link (not git-clone)) - (p log-link) - null) - post-content)) - - (define-values (dest-dir dest-file dest-is-dir?) (split-path dest)) - - (define page-content - (if page-site - (page #:site page-site - #:file (path-element->string dest-file) - #:title page-title - #:extra-headers page-headers - (columns 12 #:row? #t - page-body)) - (html (head (title page-title) - page-headers) - (body page-body)))) - - (call-with-registered-roots - (lambda () - (cond - [page-site - ;; Render to "download-page", then move up: - (define base-dir (if (path? dest-dir) - dest-dir - (current-directory))) - (parameterize ([current-directory base-dir]) - (render-all)) - (define dp-dir (build-path base-dir "download-page")) - (for ([f (in-list (directory-list dp-dir))]) - (define f-dest (build-path base-dir f)) - (delete-directory/files f-dest #:must-exist? #f) - (rename-file-or-directory (build-path dp-dir f) f-dest)) - (delete-directory dp-dir)] - [else - (call-with-output-file* - dest - #:exists 'truncate/replace - (lambda (o) - (output-xml page-content o)))])))) diff --git a/pkgs/distro-build-pkgs/distro-build-server/drive-clients.rkt b/pkgs/distro-build-pkgs/distro-build-server/drive-clients.rkt deleted file mode 100644 index 2258600b6d..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/drive-clients.rkt +++ /dev/null @@ -1,532 +0,0 @@ -#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 - remote-shell/vbox - "email.rkt") - -;; See "config.rkt" for an overview. - -(module test racket/base) - -;; ---------------------------------------- - -(define default-release? #f) -(define default-source? #f) -(define default-versionless? #f) -(define default-clean? #f) -(define dry-run #f) - -(define snapshot-install-name "snapshot") - -(define-values (config-file config-mode - default-server default-server-port default-server-hosts - default-pkgs default-doc-search - default-dist-name default-dist-base default-dist-dir) - (command-line - #:once-each - [("--release") "Create release-mode installers" - (set! default-release? #t)] - [("--source") "Create source installers" - (set! default-source? #t)] - [("--versionless") "Avoid version number in names and paths" - (set! default-versionless? #t)] - [("--clean") "Erase client directories before building" - (set! default-clean? #t)] - [("--dry-run") mode - ("Don't actually use the clients;" - " can be `ok', `fail', `error', `stuck', or `frozen'") - (unless (member mode '("ok" "fail" "error" "stuck" "frozen")) - (raise-user-error 'drive-clients "bad dry-run mode: ~a" mode)) - (set! dry-run (string->symbol mode))] - #:args (config-file config-mode - server server-port server-hosts pkgs doc-search - dist-name dist-base dist-dir) - (values config-file config-mode - server server-port server-hosts pkgs doc-search - dist-name dist-base dist-dir))) - -(define config (parameterize ([current-mode config-mode]) - (dynamic-require (path->complete-path config-file) 'site-config))) - -(unless (site-config? config) - (error 'drive-clients - "configuration module did not provide a site-configuration value: ~e" - config)) - -;; ---------------------------------------- - -(define (merge-options opts c) - (for/fold ([opts opts]) ([(k v) (in-hash (site-config-options c))]) - (if (eq? k '#:custom) - (hash-set opts - '#:custom - (let ([prev (hash-ref opts '#:custom (hash))]) - (for/fold ([prev prev]) ([(k2 v2) (in-hash v)]) - (hash-set prev k2 v2)))) - (hash-set opts k v)))) - -(define (get-opt opts kw [default #f] #:localhost [localhost-default default]) - (hash-ref opts kw (lambda () - (cond - [(equal? default localhost-default) default] - [(and (equal? "localhost" (get-opt opts '#:host "localhost")) - (equal? #f (get-opt opts '#:user #f)) - (equal? #f (get-opt opts '#:dir #f))) - localhost-default] - [else default])))) - -(define (get-content c) - (site-config-content c)) - -(define (client-name opts) - (or (get-opt opts '#:name) - (get-opt opts '#:host) - "localhost")) - -(define (get-path-opt opt key default #:localhost [localhost-default default]) - (define d (get-opt opt key default #:localhost localhost-default)) - (if (path? d) - (path->string d) - d)) - -(define (add-defaults c . l) - (let loop ([c c] [l l]) - (cond - [(null? l) c] - [else (loop (hash-set c (car l) - (hash-ref c (car l) (lambda () (cadr l)))) - (cddr l))]))) - -;; ---------------------------------------- -;; Managing VirtualBox machines - -(define (start-client c max-vm) - (define vbox (get-opt c '#:vbox)) - (when vbox - (start-vbox-vm vbox - #:max-vms max-vm - #:dry-run? dry-run))) - -(define (stop-client c) - (define vbox (get-opt c '#:vbox)) - (when vbox - (stop-vbox-vm vbox))) - -(define (try-until-ready c host port user server-port kind cmd) - (when (get-opt c '#:vbox) - ;; A VM may take a little while to get networking set up and - ;; respond, so give a dummy `cmd` a few tries - (let loop ([tries 3]) - (unless (ssh-script host port user server-port kind cmd) - (sleep 1) - (loop (sub1 tries)))))) - -;; ---------------------------------------- - -(define scp (find-executable-path "scp")) -(define ssh (find-executable-path "ssh")) - -(define (system*/show exe . args) - (displayln (apply ~a #:separator " " - (map (lambda (p) (if (path? p) (path->string p) p)) - (cons exe args)))) - (flush-output) - (case dry-run - [(ok) #t] - [(fail) #f] - [(error) (error "error")] - [(stuck) (semaphore-wait (make-semaphore))] - [(frozen) (break-enabled #f) (semaphore-wait (make-semaphore))] - [else - (apply system* exe args)])) - -(define (ssh-script host port user server-port kind . cmds) - (for/and ([cmd (in-list cmds)]) - (when cmd (display-time)) - (or (not cmd) - (if (and (equal? host "localhost") - (not user)) - (apply system*/show cmd) - (apply system*/show ssh - "-p" (~a port) - ;; create tunnel to connect back to server: - "-R" (~a server-port ":localhost:" server-port) - (if user - (~a user "@" host) - host) - (if (eq? kind 'unix) - ;; ssh needs an extra level of quoting - ;; relative to sh: - (for/list ([arg (in-list cmd)]) - (~a "'" - (regexp-replace* #rx"'" arg "'\"'\"'") - "'")) - ;; windows quoting built into `cmd' aready - cmd)))))) - -(define (q s) - (~a "\"" s "\"")) - -(define (qq l kind) - (case kind - [(unix macosx) - (~a "'" - (apply ~a #:separator " " (map q l)) - "'")] - [(windows windows/bash) - (~a "\"" - (apply - ~a #:separator " " - (for/list ([i (in-list l)]) - (~a "\\\"" - i - ;; A backslash is literal unless followed by a - ;; quote. If `i' ends in backslashes, they - ;; must be doubled, because the \" added to - ;; the end will make them treated as escapes. - (let ([m (regexp-match #rx"\\\\*$" i)]) - (car m)) - "\\\""))) - "\"")])) - -(define (shell-protect s kind) - (case kind - [(windows/bash) - ;; Protect Windows arguments to go through bash, where - ;; unquoted backslashes must be escaped, but quotes are effectively - ;; preserved by the shell, and quoted backslashes should be left - ;; alone; also, "&&" must be quoted to avoid parsing by bash - (regexp-replace* "&&" - (list->string - ;; In practice, the following loop is likely to - ;; do nothing, because constructed command lines - ;; tend to have only quoted backslashes. - (let loop ([l (string->list s)] [in-quote? #f]) - (cond - [(null? l) null] - [(and (equal? #\\ (car l)) - (not in-quote?)) - (list* #\\ #\\ (loop (cdr l) #f))] - [(and in-quote? - (equal? #\\ (car l)) - (pair? (cdr l)) - (or (equal? #\" (cadr l)) - (equal? #\\ (cadr l)))) - (list* #\\ (cadr l) (loop (cddr l) #t))] - [(equal? #\" (car l)) - (cons #\" (loop (cdr l) (not in-quote?)))] - [else - (cons (car l) (loop (cdr l) in-quote?))]))) - "\"\\&\\&\"")] - [else s])) - -(define (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? default-source?)) - (define versionless? (get-opt c '#:versionless? default-versionless?)) - (define source-pkgs? (get-opt c '#:source-pkgs? source?)) - (define source-runtime? (get-opt c '#:source-runtime? source?)) - (define mac-pkg? (get-opt c '#:mac-pkg? #f)) - (define 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 "")) - " VERSIONLESS_MODE=" (if versionless? "--versionless" (q "")) - " PKG_SOURCE_MODE=" (if source-pkgs? - (q "--source --no-setup") - (q "")) - " MAC_PKG_MODE=" (if mac-pkg? "--mac-pkg" (q "")) - " UPLOAD=http://" server ":" server-port "/upload/" - " README=http://" server ":" server-port "/" (q (file-name-from-path readme)))) - -(define (unix-build c platform host port user server server-port repo clean? pull? readme) - (define dir (get-path-opt c '#:dir "build/plt" #:localhost (current-directory))) - (define (sh . args) - (list "/bin/sh" "-c" (apply ~a args))) - (define j (or (get-opt c '#:j) 1)) - (try-until-ready c host port user server-port 'unix (sh "echo hello")) - (ssh-script - host port user - server-port - 'unix - (and clean? - (sh "rm -rf " (q dir))) - (sh "if [ ! -d " (q dir) " ] ; then" - " git clone " (q repo) " " (q dir) " ; " - "fi") - (and pull? - (sh "cd " (q dir) " ; " - "git pull")) - (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" - "x86_amd64"))) - (define j (or (get-opt c '#:j) 1)) - (define (cmd . args) - (list "cmd" "/c" (shell-protect (apply ~a args) platform))) - (try-until-ready c host port user server-port 'windows (cmd "echo hello")) - (ssh-script - host port user - server-port - platform - (and clean? - (cmd "IF EXIST " (q dir) " rmdir /S /Q " (q dir))) - (cmd "IF NOT EXIST " (q dir) " git clone " (q repo) " " (q dir)) - (and pull? - (cmd "cd " (q dir) - " && git pull")) - (cmd "cd " (q dir) - " && racket\\src\\worksp\\msvcprep.bat " vc - " && nmake win32-client" - " JOB_OPTIONS=\"-j " j "\"" - (client-args c server server-port platform readme)))) - -(define (client-build c) - (define host (or (get-opt c '#:host) - "localhost")) - (define port (or (get-opt c '#:port) - 22)) - (define user (get-opt c '#:user)) - (define server (or (get-opt c '#:server) - default-server)) - (define server-port (or (get-opt c '#:server-port) - default-server-port)) - (define repo (or (get-opt c '#:repo) - (~a "http://" server ":" server-port "/.git"))) - (define clean? (get-opt c '#:clean? default-clean? #:localhost #f)) - (define pull? (get-opt c '#:pull? #t #:localhost #f)) - - (define readme-txt (let ([rdme (get-opt c '#:readme make-readme)]) - (if (string? rdme) - rdme - (rdme (add-defaults c - '#:release? default-release? - '#:source? default-source? - '#:versionless? default-versionless? - '#:pkgs (string-split default-pkgs) - '#:install-name (if (get-opt c '#:release? default-release?) - "" - snapshot-install-name) - '#:build-stamp (if (get-opt c '#:release? default-release?) - "" - (current-stamp))))))) - (make-directory* (build-path "build" "readmes")) - (define readme (make-temporary-file - "README-~a" - #f - (build-path "build" "readmes"))) - (call-with-output-file* - readme - #:exists 'truncate - (lambda (o) - (display readme-txt o) - (unless (regexp-match #rx"\n$" readme-txt) - ;; ensure a newline at the end: - (newline o)))) - - (define platform (or (get-opt c '#:platform) (system-type))) - - (begin0 - - ((case platform - [(unix macosx) unix-build] - [else windows-build]) - c platform host port user server server-port repo clean? pull? readme) - - (delete-file readme))) - -;; ---------------------------------------- - -(define stop? #f) - -(define failures (make-hasheq)) -(define (record-failure name) - ;; relies on atomicity of `eq?'-based hash table: - (hash-set! failures (string->symbol name) #t)) - -(define (limit-and-report-failure c timeout-factor - shutdown report-fail - thunk) - (define cust (make-custodian)) - (define timeout (or (get-opt c '#:timeout) - (* 30 60))) - (define orig-thread (current-thread)) - (define timeout? #f) - (begin0 - (parameterize ([current-custodian cust]) - (thread (lambda () - (sleep (* timeout-factor timeout)) - (eprintf "timeout for ~s\n" (client-name c)) - ;; try nice interrupt, first: - (set! timeout? #t) - (break-thread orig-thread) - (sleep 1) - ;; force quit: - (report-fail) - (shutdown))) - (with-handlers ([exn? (lambda (exn) - (when (exn:break? exn) - ;; This is useful only when everything is - ;; sequential, which is the only time that - ;; we'll get break events that aren't timeouts: - (unless timeout? - (set! stop? #t))) - (log-error "~a failed..." (client-name c)) - (log-error (exn-message exn)) - (report-fail) - #f)]) - (thunk))) - (custodian-shutdown-all cust))) - -(define (client-thread c all-seq? proc) - (unless stop? - (define log-dir (build-path "build" "log")) - (define log-file (build-path log-dir (client-name c))) - (make-directory* log-dir) - (printf "Logging build: ~a\n" log-file) - (flush-output) - (define cust (make-custodian)) - (define (go shutdown) - (define p (open-output-file log-file - #:exists 'truncate/replace)) - (file-stream-buffer-mode p 'line) - (define (report-fail) - (record-failure (client-name c)) - (printf "Build FAILED for ~s\n" (client-name c))) - (unless (parameterize ([current-output-port p] - [current-error-port p]) - (proc shutdown report-fail)) - (report-fail)) - (display-time)) - (cond - [all-seq? - (go (lambda () (exit 1))) - (thread void)] - [else - (parameterize ([current-custodian cust]) - (thread - (lambda () - (go (lambda () - (custodian-shutdown-all cust))))))]))) - -;; ---------------------------------------- - -(define start-seconds (current-seconds)) -(display-time) - -(void - (sync - (let loop ([config config] - [all-seq? #t] ; Ctl-C handling is better if nothing is in parallel - [opts (hasheq)]) - (cond - [stop? (thread void)] - [else - (case (site-config-tag config) - [(parallel) - (define new-opts (merge-options opts config)) - (define ts - (map (lambda (c) (loop c #f new-opts)) - (get-content config))) - (thread - (lambda () - (for ([t (in-list ts)]) - (sync t))))] - [(sequential) - (define new-opts (merge-options opts config)) - (define (go) - (for-each (lambda (c) (sync (loop c all-seq? new-opts))) - (get-content config))) - (if all-seq? - (begin (go) (thread void)) - (thread go))] - [else - (define c (merge-options opts config)) - (client-thread - c - all-seq? - (lambda (shutdown report-fail) - (limit-and-report-failure - c 2 shutdown report-fail - (lambda () - (sleep (get-opt c '#:pause-before 0)) - ;; start client, if a VM: - (start-client c (or (get-opt c '#:max-vm) 1)) - ;; catch failure in build step proper, so we - ;; can more likely stop the client: - (begin0 - (limit-and-report-failure - c 1 shutdown report-fail - (lambda () (client-build c))) - ;; stop client, if a VM: - (stop-client c) - (sleep (get-opt c '#:pause-after 0)))))))])])))) - -(display-time) -(define end-seconds (current-seconds)) - -(unless stop? - (let ([opts (merge-options (hasheq) config)]) - (let ([to-email (get-opt opts '#:email-to null)]) - (unless (null? to-email) - (printf "Sending report to ~a\n" (apply ~a to-email #:separator ", ")) - (send-email to-email (lambda (key def) - (get-opt opts key def)) - (get-opt opts '#:build-stamp (current-stamp)) - start-seconds end-seconds - (hash-map failures (lambda (k v) (symbol->string k)))) - (display-time))))) diff --git a/pkgs/distro-build-pkgs/distro-build-server/email.rkt b/pkgs/distro-build-pkgs/distro-build-server/email.rkt deleted file mode 100644 index 5bb24bf4fc..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/email.rkt +++ /dev/null @@ -1,74 +0,0 @@ -#lang racket/base -(require racket/format - net/head - net/smtp - net/sendmail - openssl - racket/tcp) - -(provide send-email) - -(define (send-email to-email get-opt - stamp - start-seconds end-seconds - failures) - (let ([server (get-opt '#:smtp-server #f)] - [from-email (or (get-opt '#:email-from #f) - (car to-email))] - [subject (~a "[build] " - (if (null? failures) - "success" - "FAILURE") - " " stamp)] - [message (append - (if (null? failures) - '("All builds succeeded.") - (cons - "The following builds failed:" - (for/list ([i (in-list failures)]) - (~a " " i)))) - (list - "" - (let ([e (- end-seconds start-seconds)] - [~d (lambda (n) - (~a n #:width 2 #:pad-string "0" #:align 'right))]) - (~a "Elapsed time: " - (~d (quotient e (* 60 60))) - ":" - (~d (modulo (quotient e (* 60)) 60)) - ":" - (~d (modulo e (* 60 60))))) - "" - (~a "Stamp: " stamp)))]) - (cond - [server - (let* ([smtp-connect (get-opt '#:smtp-connect 'plain)] - [port-no (get-opt '#:smtp-port - (case smtp-connect - [(plain) 25] - [(ssl) 465] - [(tls) 587]))]) - (smtp-send-message server - #:port-no port-no - #:tcp-connect (if (eq? 'ssl smtp-connect) - ssl-connect - tcp-connect) - #:tls-encode (and (eq? 'tls smtp-connect) - ports->ssl-ports) - #:auth-user (get-opt '#:smtp-user #f) - #:auth-passwd (get-opt '#:smtp-password #f) - from-email - to-email - (standard-message-header from-email - to-email - null - null - subject) - message))] - [else - (send-mail-message from-email - subject - to-email - null - null - message)]))) diff --git a/pkgs/distro-build-pkgs/distro-build-server/indexes.rkt b/pkgs/distro-build-pkgs/distro-build-server/indexes.rkt deleted file mode 100644 index a0661ee1f5..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/indexes.rkt +++ /dev/null @@ -1,42 +0,0 @@ -#lang racket/base -(require racket/string - scribble/html - plt-web) - -(provide generate-index-html) - -(define (generate-index-html dest-dir sub-dir www-site) - (define content - (for/list ([f (directory-list (build-path dest-dir sub-dir))]) - (define fp (build-path dest-dir sub-dir f)) - (if (file-exists? fp) - (cons f (file-size fp)) - (cons f 'dir)))) - (cond - [www-site - (define web-dir (string-join (map path-element->string (explode-path sub-dir)) "/")) - (log-error "web ~s" web-dir) - (define s - (site web-dir - #:url "http://index.racket-lang.org" - #:share-from www-site - #:always-abs-url? #f)) - (define is (index-site s)) - (index-page is 'same content) - (void)] - [else - (define page-content - (html (head (title "Index")) - (body (table - (for/list ([c (in-list content)]) - (tr (td (a href: (car c) - ((if (eq? 'dir (cdr c)) - (lambda (p) - (format "[~a]" p)) - values) - (car c)))))))))) - (call-with-output-file* - (build-path dest-dir sub-dir "index.html") - (lambda (o) - (output-xml page-content o)))])) - diff --git a/pkgs/distro-build-pkgs/distro-build-server/info.rkt b/pkgs/distro-build-pkgs/distro-build-server/info.rkt deleted file mode 100644 index 8acdb56425..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/info.rkt +++ /dev/null @@ -1,17 +0,0 @@ -#lang info - -(define collection "distro-build") - -(define deps '("base" - "distro-build-client" - "web-server-lib" - "ds-store-lib" - "net-lib" - "scribble-html-lib" - "plt-web-lib" - "remote-shell-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/install-for-docs.rkt b/pkgs/distro-build-pkgs/distro-build-server/install-for-docs.rkt deleted file mode 100644 index 022b158763..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/install-for-docs.rkt +++ /dev/null @@ -1,70 +0,0 @@ -#lang racket/base -(require racket/cmdline - racket/file - racket/string - racket/system - compiler/find-exe - (only-in "config.rkt" extract-options) - distro-build/display-time) - -(module test racket/base) - -(define-values (dir config-file config-mode default-pkgs catalogs) - (command-line - #:args - (dir config-file config-mode default-pkgs . catalog) - (values dir config-file config-mode default-pkgs catalog))) - -(define config (extract-options config-file config-mode)) - -(define pkgs - (or (hash-ref config '#:pkgs #f) - (string-split default-pkgs))) - -(define (build-path/s . a) - (path->string (path->complete-path (apply build-path dir a)))) -(define (build-path/f . a) - (string-append "file://" - (path->string (path->complete-path (apply build-path a))))) - -(define ht - (hash 'doc-dir (build-path/s "doc") - 'lib-dir (build-path/s "lib") - 'share-dir (build-path/s "share") - 'dll-dir (build-path/s "lib") - 'links-file (build-path/s "share" "links.rktd") - 'pkgs-dir (build-path/s "share" "pkgs") - 'bin-dir (build-path/s "bin") - 'include-dir (build-path/s "include") - 'catalogs (map build-path/f catalogs))) - -(make-directory* (build-path dir "etc")) - -(call-with-output-file* - (build-path dir "etc" "config.rktd") - #:exists 'truncate/replace - (lambda (o) - (write ht o) - (newline o))) - -(display-time) -(printf "Running `raco pkg install' for packages:\n") -(for ([pkg (in-list pkgs)]) - (printf " ~a\n" pkg)) -(unless (apply system* (find-exe) - "-G" "build/docs/etc" "-l-" - "raco" "pkg" "install" - "--pkgs" - "-i" "--deps" "search-auto" - pkgs) - (error "install failed")) - -(when (hash-ref config '#:pdf-doc? #f) - (display-time) - (printf "Running `raco setup' PDF documentation:\n") - (unless (system* (find-exe) - "-G" "build/docs/etc" "-l-" - "raco" "setup" "--doc-pdf" "build/pdf-doc") - (error "PDF failed"))) - -(display-time) diff --git a/pkgs/distro-build-pkgs/distro-build-server/install-pkgs.rkt b/pkgs/distro-build-pkgs/distro-build-server/install-pkgs.rkt deleted file mode 100644 index f7150e890d..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/install-pkgs.rkt +++ /dev/null @@ -1,23 +0,0 @@ -#lang racket/base -(require racket/cmdline - racket/string - (only-in "config.rkt" extract-options)) - -(module test racket/base) - -(define-values (config-file config-mode default-pkgs flags) - (command-line - #:args - (config-file config-mode pkgs . flag) - (values config-file config-mode pkgs flag))) - -(define pkgs (or (hash-ref (extract-options config-file config-mode) - '#:pkgs - #f) - (string-split default-pkgs))) - -(parameterize ([current-command-line-arguments - (list->vector (append (list "pkg" "install") - flags - pkgs))]) - (dynamic-require 'raco #f)) diff --git a/pkgs/distro-build-pkgs/distro-build-server/manage-snapshots.rkt b/pkgs/distro-build-pkgs/distro-build-server/manage-snapshots.rkt deleted file mode 100644 index 53a857f117..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/manage-snapshots.rkt +++ /dev/null @@ -1,139 +0,0 @@ -#lang racket/base -(require racket/cmdline - racket/file - net/url - scribble/html - "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 site-title (hash-ref config - '#:site-title - "Racket Downloads")) - -(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 - #:title site-title - #:plt-web-style? (hash-ref config '#:plt-web-style? #t) - #: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 (list - (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-pkgs/distro-build-server/pack-built.rkt b/pkgs/distro-build-pkgs/distro-build-server/pack-built.rkt deleted file mode 100644 index 1914ef50ba..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/pack-built.rkt +++ /dev/null @@ -1,59 +0,0 @@ -#lang racket/base -(require pkg - pkg/lib - racket/format - net/url - racket/set - racket/file - racket/path - openssl/sha1 - racket/cmdline) - -(module test racket/base) - -(define create-mode 'built) - -(define pkg-info-file - (command-line - #:once-each - [("--mode") mode "Create package archives for " - (set! create-mode (string->symbol mode))] - #:args (pkg-info-file) - pkg-info-file)) - -(define build-dir "build") -(define dest-dir (build-path build-dir (~a create-mode))) -(define native-dir (build-path build-dir "native" "pkgs")) -(define pkg-dest-dir (path->complete-path (build-path dest-dir "pkgs"))) -(define catalog-dir (build-path dest-dir "catalog")) -(define catalog-pkg-dir (build-path catalog-dir "pkg")) -(make-directory* pkg-dest-dir) -(make-directory* catalog-pkg-dir) - -(define pkg-details (call-with-input-file* pkg-info-file read)) - -(for ([pkg (in-list (installed-pkg-names))]) - (define native-zip (build-path native-dir (path-add-suffix pkg ".zip"))) - (unless (file-exists? native-zip) - (define ht (hash-ref pkg-details pkg (hash))) - (define dest-zip (build-path pkg-dest-dir (~a pkg ".zip"))) - (pkg-create 'zip pkg - #:source 'name - #:dest pkg-dest-dir - #:mode create-mode) - (call-with-output-file* - (build-path catalog-pkg-dir pkg) - #:exists 'truncate - (lambda (o) - (write (hash 'source (path->string (find-relative-path - (simple-form-path catalog-dir) - (simple-form-path dest-zip))) - 'checksum (call-with-input-file* dest-zip sha1) - 'name pkg - 'author (hash-ref ht 'author "plt@racket-lang.org") - 'description (hash-ref ht 'author "library") - 'tags (hash-ref ht 'tags '()) - 'dependencies (hash-ref ht 'dependencies '()) - 'modules (hash-ref ht 'modules '())) - o) - (newline o))))) diff --git a/pkgs/distro-build-pkgs/distro-build-server/pack-collects.rkt b/pkgs/distro-build-pkgs/distro-build-server/pack-collects.rkt deleted file mode 100644 index a7f9ecb3ff..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/pack-collects.rkt +++ /dev/null @@ -1,19 +0,0 @@ -#lang racket/base -(require file/tar - file/gzip - racket/file) - -(module test racket/base) - -(define origin-dir (build-path "build" "origin")) - -(make-directory* origin-dir) - -(define tgz-file - (path->complete-path (build-path origin-dir "collects.tgz"))) - -(when (file-exists? tgz-file) - (delete-file tgz-file)) - -(parameterize ([current-directory (build-path "racket")]) - (tar-gzip tgz-file "collects")) diff --git a/pkgs/distro-build-pkgs/distro-build-server/pkg-info.rkt b/pkgs/distro-build-pkgs/distro-build-server/pkg-info.rkt deleted file mode 100644 index 0ed55059b4..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/pkg-info.rkt +++ /dev/null @@ -1,37 +0,0 @@ -#lang racket/base -(require pkg/lib - racket/cmdline - net/url) - -(define dest-file #f) - -(define catalog - (command-line - #:once-each - [("-o") file "Output file" - (set! dest-file file)] - #:args - (catalog) - catalog)) - -(define catalog-url - (if (regexp-match? #rx"^[a-z]+:" catalog) - (string->url catalog) - (path->url (path->complete-path catalog)))) - -(define details - (parameterize ([current-pkg-catalogs (list catalog-url)]) - (get-all-pkg-details-from-catalogs))) - -(define (write-out o) - (write details o) - (newline o)) - -(if dest-file - (call-with-output-file* dest-file - #:exists 'truncate/replace - write-out) - (write-out (current-output-port))) - - -(module test racket/base) diff --git a/pkgs/distro-build-pkgs/distro-build-server/readme.rkt b/pkgs/distro-build-pkgs/distro-build-server/readme.rkt deleted file mode 100644 index 3c30e9487d..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/readme.rkt +++ /dev/null @@ -1,141 +0,0 @@ -#lang at-exp racket/base -(require racket/format - net/url - (only-in "config.rkt" current-stamp)) - -(provide make-readme - make-source-notes - make-macosx-notes) - -(define (maybe-stamp config) - (if (hash-ref config '#:release? #f) - "" - @~a{ (@(current-stamp))})) - -(define (make-readme config) - @~a{ - The Racket Programming Language - =============================== - - This is the - @|(drop-sort-annotations (hash-ref config '#:name "Racket"))| - distribution for version @(version)@(maybe-stamp config).@; - - @(if (let ([src? (hash-ref config '#:source? #f)]) - (or (hash-ref config '#:source-runtime? src?) - (hash-ref config '#:source-pkgs? src?))) - (string-append "\n" (make-source-notes config) "\n") - "")@; - @(if (and (not (hash-ref config '#:source-runtime? - (hash-ref config '#:source? #f))) - (eq? (hash-ref config '#:platform (system-type)) 'macosx)) - (string-append "\n" (make-macosx-notes config) "\n") - "")@; - @(let* ([catalogs (filter - (lambda (s) (not (equal? s ""))) - (or (hash-ref config '#:dist-catalogs #f) - (let ([v (hash-ref config '#:dist-base-url #f)]) - (and v - (list (url->string - (combine-url/relative (string->url v) "catalog/"))))) - null))] - [s (if (= 1 (length catalogs)) "" "s")] - [is (if (= 1 (length catalogs)) "is" "are")]) - (if (null? catalogs) - "" - @~a{ - - The distribution has been configured so that when you install or - update packages, the package catalog@|s| at@; - @(apply ~a (for/list ([catalog (in-list catalogs)]) - @~a{@"\n" @|catalog|})) - @|is| consulted first. - - }))@; - @(let* ([name (hash-ref config '#:install-name "")]) - (if (or (equal? name "") - (equal? name (version))) - "" - @~a{ - - The distribution has been configured so that the installation - name is - @name - Multiple installations with this name share `user'-scoped packages, - which makes it easier to upgrade from such an installation to this one. - To avoid sharing (which is better for keeping multiple installations - active) use `raco pkg config -i --set name ...' to choose a different - name for this installation. - - }))@; - - Visit http://racket-lang.org/ for more Racket resources. - - - License - ------- - - Racket - Copyright (c) 2010-2014 PLT Design Inc. - - Racket is distributed under the GNU Lesser General Public License - (LGPL). This means that you can link Racket into proprietary - applications, provided you follow the rules stated in the LGPL. You can - also modify Racket; if you distribute a modified version, you must - distribute it under the terms of the LGPL, which in particular means - that you must release the source code for the modified software. See - share/COPYING_LESSER.txt for more information.}) - -(define (drop-sort-annotations s) - ;; Any number of spaces is allowed around "{...}" and "|", - ;; so normalize that space while also removing "{...}": - (regexp-replace* #rx" *[|] *" - (regexp-replace* #rx" *{[^}]*} *" s "") - " | ")) - -(define (make-source-notes config) - (define src? (hash-ref config '#:source? #f)) - (define rt-src - @~a{This distribution provides source for the Racket run-time system; - for build and installation instructions, see "src/README".}) - (define pkg-src - @~a{(The distribution also includes the core Racket collections and any - installed packages in source form.)}) - (define pkg-built - @~a{Besides the run-time system's source, the distribution provides - pre-built versions of the core Racket bytecode, as well as pre-built - versions of included packages and documentation --- which makes it - suitable for quick installation on a Unix platform for which - executable binaries are not already provided.}) - (cond - [(and (hash-ref config '#:source-runtime? src?) - (not (hash-ref config '#:source-pkgs? src?))) - (~a rt-src "\n" pkg-built)] - [(and (hash-ref config '#:source-runtime? src?) - (hash-ref config '#:source-pkgs? src?)) - (~a rt-src "\n" pkg-src)] - [else - @~a{The distribution includes any pre-installed packages in source form.}])) - -(define (make-macosx-notes config) - (define vers-suffix - (if (hash-ref config '#:versionless? #f) - "" - @~a{ v@(version)})) - (if (hash-ref config '#:mac-pkg? #f) - @~a{The installation directory is - /Applications/@(string-append - (hash-ref config '#:dist-name "Racket") - (if (hash-ref config '#:release? #f) - "" - vers-suffix)) - The installer also adjusts "/etc/paths.d/racket" to point to that - directory's "bin" directory, which adjusts the default PATH - environment variable for all users.} - @~a{Install by dragging the enclosing - @|(hash-ref config '#:dist-name "Racket")|@|vers-suffix| - folder to your Applications folder --- or wherever you like. You can - move the folder at any time, but do not move applications or other - files within the folder. If you want to use the Racket command-line - programs, then (optionally) add the path of the "bin" subdirectory to - your PATH environment variable.})) diff --git a/pkgs/distro-build-pkgs/distro-build-server/serve-catalog.rkt b/pkgs/distro-build-pkgs/distro-build-server/serve-catalog.rkt deleted file mode 100644 index 3e36907b69..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/serve-catalog.rkt +++ /dev/null @@ -1,181 +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 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 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) - (for/or ([d (in-list dirs)]) - (define f (build-path d "catalog" "pkg" name)) - (and (file-exists? f) - ;; Change leading "../" to "./" in source, because - ;; we've shifted "pkg" relative to the site root - ;; by skipping over "catalog" in the URL. - (let ([ht (call-with-input-file* - f - read)]) - (hash-set ht - 'source - (regexp-replace #rx"^[.][.]/" - (hash-ref ht 'source) - "./")))))) - -(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 "pkgs" directories: - (for/list ([d (in-list dirs)]) - (path->complete-path d)) - ;; 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-pkgs/distro-build-server/set-server-config.rkt b/pkgs/distro-build-pkgs/distro-build-server/set-server-config.rkt deleted file mode 100644 index f8558c85cd..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/set-server-config.rkt +++ /dev/null @@ -1,33 +0,0 @@ -#lang racket/base -(require racket/cmdline - racket/file - racket/path - (only-in "config.rkt" extract-options) - "url-options.rkt" - distro-build/set-config) - -(module test racket/base) - -(define-values (dest-config-file config-file config-mode - install-name build-stamp - default-doc-search default-catalogs) - (command-line - #:args - (dest-config-file config-file config-mode - install-name build-stamp - doc-search . catalog) - (values dest-config-file config-file config-mode - install-name build-stamp - doc-search catalog))) - -(define config (if (equal? config-file "") - (hash) - (extract-options config-file config-mode))) - -(define doc-search (choose-doc-search config default-doc-search)) - -(define catalogs (choose-catalogs config default-catalogs)) - -(set-config dest-config-file - install-name build-stamp - doc-search catalogs) diff --git a/pkgs/distro-build-pkgs/distro-build-server/url-options.rkt b/pkgs/distro-build-pkgs/distro-build-server/url-options.rkt deleted file mode 100644 index 99cd1be27d..0000000000 --- a/pkgs/distro-build-pkgs/distro-build-server/url-options.rkt +++ /dev/null @@ -1,22 +0,0 @@ -#lang racket/base -(require net/url) - -(provide choose-doc-search - choose-catalogs) - -(define (choose-doc-search config default-doc-search) - (or (hash-ref config '#:doc-search #f) - (let ([v (hash-ref config '#:dist-base-url #f)]) - (and v - (url->string - (combine-url/relative (string->url v) "doc/local-redirect/index.html")))) - default-doc-search)) - -(define (choose-catalogs config default-catalogs) - (or (hash-ref config '#:dist-catalogs #f) - (let ([v (hash-ref config '#:dist-base-url #f)]) - (and v - (list (url->string - (combine-url/relative (string->url v) "catalog/")) - ""))) - default-catalogs)) diff --git a/pkgs/distro-build-pkgs/distro-build/LICENSE.txt b/pkgs/distro-build-pkgs/distro-build/LICENSE.txt deleted file mode 100644 index 2f13367cd2..0000000000 --- a/pkgs/distro-build-pkgs/distro-build/LICENSE.txt +++ /dev/null @@ -1,11 +0,0 @@ -distro-build -Copyright (c) 2010-2014 PLT Design Inc. - -This package is distributed under the GNU Lesser General Public -License (LGPL). This means that you can link this package into proprietary -applications, provided you follow the rules stated in the LGPL. You -can also modify this package; if you distribute a modified version, -you must distribute it under the terms of the LGPL, which in -particular means that you must release the source code for the -modified software. See http://www.gnu.org/copyleft/lesser.html -for more information. diff --git a/pkgs/distro-build-pkgs/distro-build/info.rkt b/pkgs/distro-build-pkgs/distro-build/info.rkt deleted file mode 100644 index b3f7a6ebb5..0000000000 --- a/pkgs/distro-build-pkgs/distro-build/info.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#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/plt-services/info.rkt b/pkgs/plt-services/info.rkt index 070c17abd4..8e94505bbe 100644 --- a/pkgs/plt-services/info.rkt +++ b/pkgs/plt-services/info.rkt @@ -10,10 +10,8 @@ ;; "Fake" dependencies to make them included ;; in a default build: "main-distribution-test" - "distro-build" "honu" "gui-pkg-manager" - "remote-shell" ;; Actual dependencies: "eli-tester" @@ -28,8 +26,7 @@ "compatibility-lib" "plt-web" "web-server-lib" - "rackunit-lib" - "remote-shell-lib")) + "rackunit-lib")) (define pkg-desc "Miscellaneous management and maintenance tools used by the Racket development team") diff --git a/pkgs/plt-services/meta/info.rkt b/pkgs/plt-services/meta/info.rkt index 8f629f385c..181042426d 100644 --- a/pkgs/plt-services/meta/info.rkt +++ b/pkgs/plt-services/meta/info.rkt @@ -1,12 +1,13 @@ #lang info (define name "Infrastructure code") -(define compile-omit-paths '("images/taking-screenshots/racket-widget.scm")) +(define compile-omit-paths '("images/taking-screenshots/racket-widget.scm" + "tests/unix-installer.rkt")) (define test-omit-paths '("images/mkheart.rkt" "pkg-index/official" "pkg-index/planet-compat" - "pkg-push")) + "tests/unix-installer.rkt")) (define test-responsibles '(("props" (eli jay)) diff --git a/pkgs/plt-services/meta/props b/pkgs/plt-services/meta/props index 19dfae8f3c..854d5da886 100755 --- a/pkgs/plt-services/meta/props +++ b/pkgs/plt-services/meta/props @@ -691,7 +691,6 @@ path/s is either such a string or a list of them. "pkgs/deinprogramm/deinprogramm/quickcheck/quickcheck.scm" drdr:command-line #f "pkgs/deinprogramm/deinprogramm/quickcheck/random.scm" drdr:command-line #f "pkgs/distributed-places-pkgs" responsible (mflatt) -"pkgs/distro-build-pkgs" responsible (mflatt) "pkgs/draw-pkgs" responsible (mflatt) "pkgs/drracket-pkgs" responsible (robby) "pkgs/drracket-pkgs/drracket/gui-debugger" responsible (gmarceau mflatt) @@ -1132,7 +1131,6 @@ path/s is either such a string or a list of them. "pkgs/redex-pkgs/redex-examples/redex/examples/racket-machine/randomized-tests.rkt" drdr:timeout 300 "pkgs/redex-pkgs/redex-test/redex/tests/run-tests.rkt" drdr:timeout 360 "pkgs/redex-pkgs/redex-test/redex/tests/ryr-test.rkt" drdr:timeout 200 drdr:random #t -"pkgs/remote-shell-pkgs" responsible (mflatt) "pkgs/sandbox-lib" responsible (eli) "pkgs/scheme-lib" responsible (mflatt) "pkgs/scheme-lib/scheme/match.rkt" responsible (samth) diff --git a/pkgs/remote-shell-pkgs/remote-shell-doc/LICENSE.txt b/pkgs/remote-shell-pkgs/remote-shell-doc/LICENSE.txt deleted file mode 100644 index a53fa9c37e..0000000000 --- a/pkgs/remote-shell-pkgs/remote-shell-doc/LICENSE.txt +++ /dev/null @@ -1,11 +0,0 @@ -remote-shell-doc -Copyright (c) 2010-2014 PLT Design Inc. - -This package is distributed under the GNU Lesser General Public -License (LGPL). This means that you can link this package into proprietary -applications, provided you follow the rules stated in the LGPL. You -can also modify this package; if you distribute a modified version, -you must distribute it under the terms of the LGPL, which in -particular means that you must release the source code for the -modified software. See http://www.gnu.org/copyleft/lesser.html -for more information. diff --git a/pkgs/remote-shell-pkgs/remote-shell-doc/info.rkt b/pkgs/remote-shell-pkgs/remote-shell-doc/info.rkt deleted file mode 100644 index fe6f3f137c..0000000000 --- a/pkgs/remote-shell-pkgs/remote-shell-doc/info.rkt +++ /dev/null @@ -1,16 +0,0 @@ -#lang info - -(define collection "remote-shell") - -(define deps '("base")) -(define build-deps '("racket-doc" - "remote-shell-lib" - "scribble-lib")) -(define update-implies '("remote-shell-lib")) - -(define pkg-desc "documentation part of \"remote-shell\"") - -(define pkg-authors '(mflatt)) - - -(define scribblings '(("remote-shell.scrbl" (multi-page)))) diff --git a/pkgs/remote-shell-pkgs/remote-shell-doc/remote-shell.scrbl b/pkgs/remote-shell-pkgs/remote-shell-doc/remote-shell.scrbl deleted file mode 100644 index 896eb668bc..0000000000 --- a/pkgs/remote-shell-pkgs/remote-shell-doc/remote-shell.scrbl +++ /dev/null @@ -1,196 +0,0 @@ -#lang scribble/manual -@(require (for-label racket/base - racket/contract - remote-shell/ssh - remote-shell/vbox)) - -@title{Remote Shells and Virtual Machines} - -The @filepath{remote-shell} collection provides tools for running -shell commands on a remote or virtual machine, including tools for -starting, stopping, and managing VirtualBox virtual-machine instances. - -@table-of-contents[] - -@; ---------------------------------------- - -@section{Remote Shells} - -@defmodule[remote-shell/ssh] - -@defproc[(remote? [v any/c]) boolean?]{ - -Returns @racket[#t] if @racket[v] is a remote-host representation -produced by @racket[remote], @racket[#f] otherwise.} - -@defproc[(remote [#:host host string?] - [#:user user string? ""] - [#:env env (listof (cons/c string? string?)) '()] - [#:remote-tunnels remote-tunnels (listof (cons/c (integer-in 1 65535) - (integer-in 1 65535))) - null] - [#:key key (or/c #f path-string?) #f] - [#:timeout timeout-secs real? 600]) - remote?]{ - -Creates a representation of a remote host. The @racket[host] argument -specifies the host for an @exec{ssh} connection. If @racket[user] is -empty, then the current user name is used for the remote host. - -The @racket[env] argument specifies environment variables to set -before running any command on the remote host. - -The @racket[remote-tunnels] argument specifies ports to tunnel from -the remote host back to the local host. The first port number in each -pair is the port number on the remote host, and the second port number -is the port that it tunnels to on the local host. - -If @racket[key] is not @racket[#f], then it is used as the path to an identity -file used for public-key authentication. - -The @racket[timeout] argument specifies a timeout after which a remote -command will be considered failed.} - - -@defproc[(ssh [remote remote?] - [command (or/c string? path-string?)] - [#:mode mode (or/c 'error 'result 'output) 'error] - [#:failure-log failure-dest (or/c #f path-string?) #f] - [#:success-log success-dest (or/c #f path-string?) #f] - [#:show-time? show-time? any/c #f]) - (or/c void? boolean? (cons/c boolean? bytes?))]{ - -Runs a shell command at @racket[remote], were the @racket[command]s -are concatenated (with no additional spaces) to specify the remote -shell command. The remote command is implemented with @exec{ssh} as -found by @racket[find-system-path]. - -If @racket[mode] is @racket['error], then the result is -@racket[(void)] or an exception is raised if the remote command fails -with an connection error, an error exit code, or by timing out. If -@racket[mode] is @racket['result], then the result is @racket[#t] for -success or @racket[#f] for failure. If @racket[mode] is -@racket['cons], then the result is a pair containing whether the -command succeeded and a byte string for the command's output -(including error output). - -If @racket[failure-dest] is not @racket[#f], then if the command -fails, the remote output (including error output) is recorded to the -specified file. If @racket[success-dest] is not @racket[#f], then if -the command fails, the remote output (including error output) is -recorded to the specified file.} - -@defproc[(scp [remote remote?] - [source path-string?] - [dest path-string?] - [#:mode mode (or/c 'error 'result 'output) 'error]) - (or/c void? boolean?)]{ - -Copies a file to/from a remote host. Use @racket[at-remote] to form -either the @racket[source] or @racket[dest] argument. The remote -command is implemented with @exec{scp} as found by -@racket[find-system-path]. - -If @racket[mode] is @racket['error], then the result is -@racket[(void)] or an exception is raised if the remote command -fails. If @racket[mode] is @racket['result], then the result is -@racket[#t] for success or @racket[#f] for failure.} - - -@defproc[(at-remote [remote remote?] - [path path-string?]) - string?]{ - -Combines @racket[remote] and @racket[path] to form an argument for -@racket[scp] to specify a path at the remote host.} - - -@defproc[(make-sure-remote-is-ready [remote remote?] - [#:tries tries exact-nonnegative-integer? 3]) - void?]{ - -Runs a simple command at @racket[remote] to check that it receives -connections, trying up to @racket[tries] times.} - - -@; ---------------------------------------- - -@section{Managing VirtualBox Machines} - -@defmodule[remote-shell/vbox] - -@defproc[(start-vbox-vm [name string?] - [#:max-vms max-vms real? 1] - [#:log-status log-status (string? #:rest any/c . -> . any) printf] - [#:pause-seconds pause-seconds real? 3] - [#:dry-run? dry-run? any/c #f]) - void?]{ - -Starts a VirtualBox virtual machine @racket[name] that is in a saved, -powered off, or running state (where a running machine continues to -run). - -The start will fail if @racket[max-vms] virtual machines are already -currently running. This limit is a precaution against starting too -many virtual-machine instances, which can overwhelm the host operating -system. - -The @racket[log-status] argument is used to report actions and status -information. - -After the machine is started, @racket[start-vbox-vm] pauses for the -amount of time specified by @racket[pause-seconds], which gives the -virtual machine time to find its bearings. - -If @racket[dry-run] is @racket[#t], then the machine is not actually -started, but status information is written using @racket[log-status] -to report the action that would have been taken.} - - -@defproc[(stop-vbox-vm [name string?] - [#:save-state? save-state? any/c #t] - [#:log-status log-status (string? #:rest any/c . -> . any) printf] - [#:dry-run? dry-run? any/c #f]) - void?]{ - -Stops a VirtualBox virtual machine @racket[name] that is in a running -state. If @racket[save-state?] is true, then the machine is put into -saved state, otherwise the current machine state is discarded and the -machine is powered off. - -The @racket[log-status] argument is used to report actions and status -information. - -If @racket[dry-run] is @racket[#t], then the machine is not actually -started, but status information is written using @racket[log-status] -to report the action that would have been taken.} - - -@defproc[(take-vbox-snapshot [name string?] - [snapshot-name string?]) - void?]{ - -Takes a snapshot of a virtual machine (which may be running), creating -the snapshot named @racket[snapshot-name].} - - -@defproc[(restore-vbox-snapshot [name string?] - [snapshot-name string?]) - void?]{ - -Changes the current state of a virtual machine to be the one recorded -as @racket[snapshot-name]. The virtual machine must not be running.} - -@defproc[(delete-vbox-snapshot [name string?] - [snapshot-name string?]) - void?]{ - -Deletes @racket[snapshot-name] for the virtual machine @racket[name].} - - -@defproc[(exists-vbox-snapshot? [name string?] - [snapshot-name string?]) - boolean?]{ - -Reports whether @racket[snapshot-name] exists for the virtual machine -@racket[name].} diff --git a/pkgs/remote-shell-pkgs/remote-shell-lib/LICENSE.txt b/pkgs/remote-shell-pkgs/remote-shell-lib/LICENSE.txt deleted file mode 100644 index e7ef6b1756..0000000000 --- a/pkgs/remote-shell-pkgs/remote-shell-lib/LICENSE.txt +++ /dev/null @@ -1,11 +0,0 @@ -remote-shell-lib -Copyright (c) 2010-2014 PLT Design Inc. - -This package is distributed under the GNU Lesser General Public -License (LGPL). This means that you can link this package into proprietary -applications, provided you follow the rules stated in the LGPL. You -can also modify this package; if you distribute a modified version, -you must distribute it under the terms of the LGPL, which in -particular means that you must release the source code for the -modified software. See http://www.gnu.org/copyleft/lesser.html -for more information. diff --git a/pkgs/remote-shell-pkgs/remote-shell-lib/info.rkt b/pkgs/remote-shell-pkgs/remote-shell-lib/info.rkt deleted file mode 100644 index a94070f4ff..0000000000 --- a/pkgs/remote-shell-pkgs/remote-shell-lib/info.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang info - -(define collection "remote-shell") - -(define deps '("base")) -(define build-deps '()) - -(define pkg-desc "implementation (no documentation) part of \"remote-shell\"") - -(define pkg-authors '(mflatt)) diff --git a/pkgs/remote-shell-pkgs/remote-shell-lib/ssh.rkt b/pkgs/remote-shell-pkgs/remote-shell-lib/ssh.rkt deleted file mode 100644 index b6e832ca3a..0000000000 --- a/pkgs/remote-shell-pkgs/remote-shell-lib/ssh.rkt +++ /dev/null @@ -1,177 +0,0 @@ -#lang racket/base -(require racket/system - racket/format - racket/port - racket/date - racket/contract) - -(provide remote? - (contract-out - (rename create-remote remote - ((#:host string?) - (#:user string? - #:key (or/c #f path-string?) - #:env (listof (cons/c string? string?)) - #:timeout real? - #:remote-tunnels (listof (cons/c (integer-in 1 65535) - (integer-in 1 65535)))) - . ->* . remote?)) - [ssh ((remote?) - (#:mode (or/c 'error 'result 'output) - #:failure-log (or/c #f path-string?) - #:success-log (or/c #f path-string?) - #:show-time? any/c) - #:rest (listof (or/c string? path-string?)) - . ->* . any)] - [scp ((remote? path-string? path-string?) - (#:mode (or/c 'error 'result)) - . ->* . - void?)] - [make-sure-remote-is-ready ((remote?) - (#:tries exact-nonnegative-integer?) - . ->* . - void?)] - [at-remote (remote? path-string? . -> . string?)])) - -(struct remote (host user timeout remote-tunnels env key) - #:constructor-name make-remote) - -(define create-remote - (let () - (define (remote #:host host - #:user [user ""] - #:key [key #f] - #:timeout [timeout 600] - #:remote-tunnels [remote-tunnels null] - #:env [env null]) - (make-remote host user timeout remote-tunnels env key)) - remote)) - -(define scp-exe (find-executable-path "scp")) -(define ssh-exe (find-executable-path "ssh")) - -(define (remote-user+host remote) - (if (not (equal? (remote-user remote) "")) - (~a (remote-user remote) "@" (remote-host remote)) - (remote-host remote))) - -(define (at-remote remote path) - (~a (remote-user+host remote) ":" path)) - -(define (system*/show exe . args) - (displayln (apply ~a #:separator " " - (map (lambda (p) (if (path? p) (path->string p) p)) - (cons exe args)))) - (flush-output) - (apply system* exe args)) - -(define (ssh remote - #:mode [mode 'error] - #:failure-log [failure-dest #f] - #:success-log [success-dest #f] - #:show-time? [show-time? #f] - . args) - (define cmd - (append - (list "/usr/bin/env") - (for/list ([e (in-list (remote-env remote))]) - (~a (car e) "=" (cdr e))) - (list - "/bin/sh" "-c" (apply ~a args)))) - - (define saved (and (or failure-dest success-dest) - (open-output-bytes))) - (define (tee o1 o2) - (cond - [(not o1) - (values o2 void)] - [else - (define-values (i o) (make-pipe 4096)) - (values o - (let ([t (thread (lambda () - (copy-port i o1 o2)))]) - (lambda () - (close-output-port o) - (sync t))))])) - (define-values (stdout sync-out) (tee saved (current-output-port))) - (define-values (stderr sync-err) (tee saved (current-error-port))) - - (define timeout? #f) - (define orig-thread (current-thread)) - (define timeout (remote-timeout remote)) - (define key (remote-key remote)) - (define timeout-thread - (thread (lambda () - (sleep timeout) - (set! timeout? #t) - (break-thread orig-thread)))) - - (define (show-time) - (when show-time? - (printf "The time is now ~a\n" - (date->string (seconds->date (current-seconds)) #t)))) - - (define ok? - (parameterize ([current-output-port stdout] - [current-error-port stderr]) - (with-handlers ([exn? (lambda (exn) - (cond - [timeout? - (eprintf "~a\n" (exn-message exn)) - (eprintf "Timeout after ~a seconds\n" timeout) - #f] - [else (raise exn)]))]) - (show-time) - (begin0 - (if (and (equal? (remote-host remote) "localhost") - (equal? (remote-user remote) "")) - (apply system*/show cmd) - (apply system*/show ssh-exe - (append - ;; create tunnels to connect back to server: - (apply - append - (for/list ([tunnel (in-list (remote-remote-tunnels remote))]) - (list "-R" (~a (car tunnel) ":localhost:" (cdr tunnel))))) - (list (remote-user+host remote)) - (if key (list "-i" key) null) - ;; ssh needs an extra level of quoting - ;; relative to sh: - (for/list ([arg (in-list cmd)]) - (~a "'" - (regexp-replace* #rx"'" arg "'\"'\"'") - "'"))))) - (kill-thread timeout-thread) - (show-time))))) - (sync-out) - (sync-err) - (let ([dest (if ok? success-dest failure-dest)]) - (when dest - (call-with-output-file* - dest - #:exists 'truncate/replace - (lambda (o) (write-bytes (get-output-bytes saved) o))))) - (case mode - [(result) ok?] - [(output) (cons ok? (get-output-bytes saved))] - [else - (unless ok? - (error 'ssh "failed"))])) - -(define (scp remote src dest #:mode [mode 'error]) - (define key (remote-key remote)) - (define ok? (apply system*/show scp-exe (append (if key (list "-i" key) null) (list src dest)))) - (case mode - [(result) ok?] - [else - (unless ok? - (error 'scp "failed"))])) - -(define (make-sure-remote-is-ready remote - #:tries [tries 3]) - (let loop ([tries tries]) - (unless (ssh remote - "echo hello" - #:mode (if (zero? tries) 'error 'result)) - (sleep 1) - (loop (sub1 tries))))) diff --git a/pkgs/remote-shell-pkgs/remote-shell-lib/vbox.rkt b/pkgs/remote-shell-pkgs/remote-shell-lib/vbox.rkt deleted file mode 100644 index 277d52a16e..0000000000 --- a/pkgs/remote-shell-pkgs/remote-shell-lib/vbox.rkt +++ /dev/null @@ -1,138 +0,0 @@ -#lang racket/base -(require racket/system - racket/string - racket/contract) - -(provide - (contract-out - [start-vbox-vm - ((string?) - (#:max-vms real? - #:dry-run? any/c - #:log-status (string? #:rest any/c . -> . any) - #:pause-seconds real?) - . ->* . - void?)] - [stop-vbox-vm - ((string?) - (#:save-state? any/c - #:dry-run? any/c - #:log-status (string? #:rest any/c . -> . any)) - . ->* . - void?)] - [take-vbox-snapshot (string? string? . -> . void?)] - [restore-vbox-snapshot (string? string? . -> . void?)] - [delete-vbox-snapshot (string? string? . -> . void?)] - [exists-vbox-snapshot? (string? string? . -> . boolean?)])) - -(define VBoxManage (find-executable-path "VBoxManage")) -(define use-headless? #t) - -(define (system*/string . args) - (define s (open-output-string)) - (and - (parameterize ([current-output-port s]) - (apply system* args)) - (get-output-string s))) - -(define (vbox-state vbox) - (define s (or (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 (printf/flush fmt . args) - (apply printf fmt args) - (flush-output)) - -(define (start-vbox-vm vbox - #:max-vms [max-vm 1] - #:dry-run? [dry-run? #f] - #:log-status [log-status printf/flush] - #:pause-seconds [pause-seconds 3]) - (define (check-count) - (define s (system*/string VBoxManage "list" "runningvms")) - (unless ((length (string-split s "\n")) . < . max-vm) - (error 'start-vbox "too many virtual machines running (>= ~a) to start: ~s" - max-vm - vbox))) - (log-status "Starting VirtualBox machine ~s\n" vbox) - (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-vbox-vm "could not get virtual machine started: ~s" vbox)) - ;; pause a little to let the VM get networking ready, etc. - (sleep pause-seconds))) - -(define (stop-vbox-vm vbox - #:save-state? [save-state? #t] - #:dry-run? [dry-run? #f] - #:log-status [log-status printf/flush]) - (log-status "Stopping VirtualBox machine ~s\n" vbox) - (unless dry-run? - (vbox-control vbox (if save-state? "savestate" "poweroff")) - (unless (memq (vbox-state vbox) '(saved off)) - (error 'stop-vbox-vm "virtual machine isn't in the expected state: ~s" vbox)))) - -(define (take-vbox-snapshot vbox name) - (unless (system* VBoxManage "snapshot" vbox "take" name) - (error 'take-vbox-snapshot "failed"))) - -(define (restore-vbox-snapshot vbox name) - (unless (system* VBoxManage "snapshot" vbox "restore" name) - (error 'restore-vbox-snapshot "failed"))) - -(define (delete-vbox-snapshot vbox name) - (unless (system* VBoxManage "snapshot" vbox "delete" name) - (error 'delete-vbox-snapshot "failed"))) - -(define (exists-vbox-snapshot? vbox name) - (define s (system*/string VBoxManage "snapshot" vbox "list" "--machinereadable")) - (unless s - (error 'exists-vbox-snapshot? "failed")) - (regexp-match? (regexp (format "SnapshotName[-0-9]*=\"~a" (regexp-quote name))) - s)) diff --git a/pkgs/remote-shell-pkgs/remote-shell/LICENSE.txt b/pkgs/remote-shell-pkgs/remote-shell/LICENSE.txt deleted file mode 100644 index abd704261b..0000000000 --- a/pkgs/remote-shell-pkgs/remote-shell/LICENSE.txt +++ /dev/null @@ -1,11 +0,0 @@ -remote-shell -Copyright (c) 2010-2014 PLT Design Inc. - -This package is distributed under the GNU Lesser General Public -License (LGPL). This means that you can link this package into proprietary -applications, provided you follow the rules stated in the LGPL. You -can also modify this package; if you distribute a modified version, -you must distribute it under the terms of the LGPL, which in -particular means that you must release the source code for the -modified software. See http://www.gnu.org/copyleft/lesser.html -for more information. diff --git a/pkgs/remote-shell-pkgs/remote-shell/info.rkt b/pkgs/remote-shell-pkgs/remote-shell/info.rkt deleted file mode 100644 index 3b074c5add..0000000000 --- a/pkgs/remote-shell-pkgs/remote-shell/info.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang info - -(define collection 'multi) - -(define deps '("remote-shell-lib" "remote-shell-doc")) -(define implies '("remote-shell-lib" "remote-shell-doc")) - -(define pkg-desc "Tools for running on remote and virtual-machine hosts") - -(define pkg-authors '(mflatt))