Split distro-build and remote-shell pkgs from the main repository.
`distro-build` is at: https://github.com/racket/distro-build `remote-shell` is at: https://github.com/racket/remote-shell
This commit is contained in:
Sam Tobin-Hochstadt
parent
bb6e28f777
commit
b9b59a3aeb
|
|
@ -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.
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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 <vers>
|
||||
or
|
||||
C:\Program Files (x86)\Microsoft Visual Studio <vers>
|
||||
* 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 <string*> means no spaces, etc.):
|
||||
|
||||
#:host <string*> --- defaults to "localhost"
|
||||
|
||||
#:name <string> --- 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 <integer> --- SSH port for the client; defaults to 22
|
||||
|
||||
#:user <string*/false> --- SSH user for the client; defaults to #f,
|
||||
which means the current user
|
||||
|
||||
#:dir <path-string> --- defaults to "build/plt" or "build\\plt", or
|
||||
to the current directory if the host is "localhost" and the user
|
||||
is #f
|
||||
|
||||
#:server <string*> --- 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 <integer> --- 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 <list-of-string*> --- 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 <string> --- the git repository for Racket; defaults to
|
||||
"http://<server>:<server-port>/.git"
|
||||
|
||||
#:pkgs '(<string*> ...) --- packages to install; defaults to the
|
||||
`PKGS' makefile variable
|
||||
|
||||
#:dist-base-url <string> --- 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 <string> --- 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> --- 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 <string> --- 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 <string> --- the distribution name; defaults to the
|
||||
`DIST_NAME' makefile variable
|
||||
|
||||
#:dist-base <string*> --- the distribution's installater name prefix;
|
||||
defaults to the `DIST_BASE' makefile variable
|
||||
|
||||
#:dist-dir <string*> --- the distribution's installation directory;
|
||||
defaults to the `DIST_DIR' makefile variable
|
||||
|
||||
#:dist-suffix <string*> --- a suffix for the installer's name,
|
||||
usually used for an OS variant; defaults to the `DIST_SUFFIX'
|
||||
makefile variable
|
||||
|
||||
#:dist-catalogs '(<string> ...) --- 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 <string-or-procedure> --- 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 <real> --- max number of VMs allowed to run with this
|
||||
machine, counting the machine; defaults to 1
|
||||
|
||||
#:vbox <string> --- 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 <symbol> --- 'unix, 'macosx, 'windows, or 'windows/bash
|
||||
(which means 'windows though an SSH server providing `bash', such
|
||||
as Cygwin's); defaults to `(system-type)'
|
||||
|
||||
#:configure '(<string> ...) --- arguments to `configure'
|
||||
|
||||
#:bits <integer> --- 32 or 64, affects Visual Studio mode
|
||||
|
||||
#:vc <string*> --- provided to "vcvarsall/bat" to select the Visual
|
||||
Studio build mode; the default is "x86" or "x86_amd64", depending
|
||||
on `#:bits'
|
||||
|
||||
#:sign-identity <string> --- 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 <integer> --- parallelism for `make' on Unix and Mac OS X and
|
||||
for `raco setup' on all platforms; defaults to 1
|
||||
|
||||
#:timeout <number> --- numbers of seconds to wait before declaring
|
||||
failure; defaults to 30 minutes
|
||||
|
||||
#:clean? <boolean> --- if true, then the build process on the client
|
||||
machine starts by removing <dir>; 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? <boolean> --- 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? <boolean> --- if true, then create release-mode
|
||||
installers; the default is determined by the `RELEASE_MODE'
|
||||
makefile variable
|
||||
|
||||
#:source? <boolean> --- determines the default value for
|
||||
`#:source-runtime?' and `#:source-pkgs'
|
||||
|
||||
#:source-runtime? <boolean> --- 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? <boolean> --- 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? <boolean> --- 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? <boolean> --- if true, creates a ".pkg" for Mac OS X (in
|
||||
single-file format) instead of a ".dmg"; the default is #f
|
||||
|
||||
#:pause-before <nonnegative-number> --- 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 <nonnegative-number> --- a pause in seconds to
|
||||
wait after stopping a machine; the default is 0
|
||||
|
||||
#:custom <hash-table> --- 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 <path-string> --- destination for completed build, used
|
||||
by the `site' and `snapshot-site' makefile targets; the default is
|
||||
"build/site"
|
||||
|
||||
#:pdf-doc? <boolean> --- whether to build PDF documentation when
|
||||
assembling a site; the default is #f
|
||||
|
||||
#:email-to <listof-of-string> --- a list of addresses to receive
|
||||
e-mail reporting build results; mail is sent via `sendmail'
|
||||
unless `#:smtp-...' configuration is supplied
|
||||
|
||||
#:email-from <string> --- address used as the sender of e-mailed
|
||||
reports; the first string in `#:email-to' is used by default
|
||||
|
||||
#:smtp-server <string*>
|
||||
#:smtp-port <string*>
|
||||
#:smtp-connect <'plain, 'ssl, or 'tls>
|
||||
#:smtp-user <string-or-#f>
|
||||
#:smtp-password <string-or-#f>
|
||||
--- 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> --- 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 <string> --- title for the main page generated
|
||||
by the `site' or `snapshot-site' makefile target; the default
|
||||
is "Racket Downloads"
|
||||
|
||||
#:max-snapshots <number> --- number of snapshots to keep, used by
|
||||
the `snapshot-site' makefile target
|
||||
|
||||
#:plt-web-style? <boolean> --- 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 <opt-kw> <opt-val> ... ...) -> site-config?
|
||||
Produces a site configuration based on the given keyword-based
|
||||
options. The support keyword arguments are described above.
|
||||
|
||||
(sequential <opt-kw> <opt-val> ... ... config ...)
|
||||
-> site-config?
|
||||
config : site-config?
|
||||
Produces a site configuration that runs each `config'
|
||||
sequentially. The support keyword arguments are described above.
|
||||
|
||||
(parallel <opt-kw> <opt-val> ... ... 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] <build on Ubuntu>
|
||||
[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/<stamp>/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 <stamp> 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.
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 11 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 16 KiB |
|
|
@ -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))))))
|
||||
|
|
@ -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 <path> : install to <path>"
|
||||
echo " --create-dir : create destination for Unix-style if it does not exist"
|
||||
echo " --create-links <dir> : create links in <dir> 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 ==========
|
||||
|
|
@ -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)
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 34 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 34 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 25 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 25 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 201 KiB |
|
|
@ -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.
|
||||
|
|
@ -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))
|
||||
|
|
@ -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.
|
||||
|
|
@ -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))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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 <dest>"
|
||||
(arg! '#:dest file)]
|
||||
[("--git") dir "Report information from git clone <dir>"
|
||||
(arg! '#:git-clone dir)]
|
||||
[("--plt") "Use PLT web page style"
|
||||
(arg! '#:plt-web-style? #t)]
|
||||
#:args
|
||||
(table-file)
|
||||
table-file))
|
||||
|
||||
(let ([args (sort args keyword<? #:key car)])
|
||||
(keyword-apply make-download-page
|
||||
(map car args)
|
||||
(map cdr args)
|
||||
(list table-file))))
|
||||
|
||||
(define (get-installers-table table-file)
|
||||
(define table (call-with-input-file table-file read))
|
||||
(unless (hash? table)
|
||||
(raise-user-error
|
||||
'make-download-page
|
||||
(~a "given file does not contain a hash table\n"
|
||||
" file: ~a")
|
||||
table-file))
|
||||
table)
|
||||
|
||||
(struct past-success (name relative-url file) #:prefab)
|
||||
|
||||
(define (make-download-page table-file
|
||||
#:past-successes [past-successes (hash)]
|
||||
#:dest [dest "index.html"]
|
||||
#:installers-url [installers-url "./"]
|
||||
#:log-dir [log-dir #f]
|
||||
#:log-dir-url [log-dir-url #f]
|
||||
#:docs-url [docs-url #f]
|
||||
#:pdf-docs-url [pdf-docs-url #f]
|
||||
#:title [page-title "Racket Downloads"]
|
||||
#:current-rx [current-rx #f]
|
||||
#:git-clone [git-clone #f]
|
||||
#:help-table [site-help (hash)]
|
||||
#:post-content [post-content null]
|
||||
#:plt-www-site [www-site #f]
|
||||
#:plt-web-style? [plt-style? (and www-site #t)])
|
||||
|
||||
(define base-table (get-installers-table table-file))
|
||||
|
||||
(define table-data (for/fold ([table-data base-table]) ([(k v) (in-hash past-successes)])
|
||||
(if (hash-ref table-data k #f)
|
||||
table-data
|
||||
(hash-set table-data k v))))
|
||||
|
||||
(define (system*/string . args)
|
||||
(define s (open-output-string))
|
||||
(parameterize ([current-output-port s])
|
||||
(apply system* args))
|
||||
(get-output-string s))
|
||||
|
||||
(define log-link
|
||||
(and log-dir-url
|
||||
(div (a class: "detail" href: log-dir-url "Build Logs"))))
|
||||
|
||||
(define sorted
|
||||
(sort (hash-keys table-data) string<?))
|
||||
(define sorted-and-split
|
||||
(map (lambda (s)
|
||||
(map (lambda (e)
|
||||
(regexp-replace* #rx" *{[^}]*} *"
|
||||
e
|
||||
""))
|
||||
(regexp-split #rx" *[|] *" s)))
|
||||
sorted))
|
||||
|
||||
(define elems
|
||||
(let loop ([l sorted-and-split]
|
||||
[keys sorted]
|
||||
[prev null]
|
||||
[started? #f])
|
||||
(define len (length prev))
|
||||
(define (add-sep l)
|
||||
(if (and started?
|
||||
(null? prev))
|
||||
(cons '(#f) l)
|
||||
l))
|
||||
(cond
|
||||
[(null? l) `((#f) (#f ,nbsp))]
|
||||
[(not (equal? prev (take (car l) len)))
|
||||
;; move out a layer:
|
||||
(loop l keys (drop-right prev 1) #t)]
|
||||
[(= (add1 len) (length (car l)))
|
||||
;; a leaf entry:
|
||||
(add-sep
|
||||
(cons (cons (car keys)
|
||||
(append (make-list len nbsp)
|
||||
(list (list-ref (car l) len))))
|
||||
(loop (cdr l) (cdr keys) prev #t)))]
|
||||
[else
|
||||
;; add a heder
|
||||
(define section (list-ref (car l) len))
|
||||
(add-sep
|
||||
(cons (cons #f
|
||||
(append (make-list len nbsp)
|
||||
(list section)))
|
||||
(loop l keys (append prev (list section)) #t)))])))
|
||||
|
||||
(define (xexpr->html 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)))]))))
|
||||
|
|
@ -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;"
|
||||
" <mode> can be `ok', `fail', `error', `stuck', or `frozen'")
|
||||
(unless (member mode '("ok" "fail" "error" "stuck" "frozen"))
|
||||
(raise-user-error 'drive-clients "bad dry-run mode: ~a" mode))
|
||||
(set! dry-run (string->symbol mode))]
|
||||
#:args (config-file config-mode
|
||||
server server-port server-hosts pkgs doc-search
|
||||
dist-name dist-base dist-dir)
|
||||
(values config-file config-mode
|
||||
server server-port server-hosts pkgs doc-search
|
||||
dist-name dist-base dist-dir)))
|
||||
|
||||
(define config (parameterize ([current-mode config-mode])
|
||||
(dynamic-require (path->complete-path config-file) 'site-config)))
|
||||
|
||||
(unless (site-config? config)
|
||||
(error 'drive-clients
|
||||
"configuration module did not provide a site-configuration value: ~e"
|
||||
config))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (merge-options opts c)
|
||||
(for/fold ([opts opts]) ([(k v) (in-hash (site-config-options c))])
|
||||
(if (eq? k '#:custom)
|
||||
(hash-set opts
|
||||
'#:custom
|
||||
(let ([prev (hash-ref opts '#:custom (hash))])
|
||||
(for/fold ([prev prev]) ([(k2 v2) (in-hash v)])
|
||||
(hash-set prev k2 v2))))
|
||||
(hash-set opts k v))))
|
||||
|
||||
(define (get-opt opts kw [default #f] #:localhost [localhost-default default])
|
||||
(hash-ref opts kw (lambda ()
|
||||
(cond
|
||||
[(equal? default localhost-default) default]
|
||||
[(and (equal? "localhost" (get-opt opts '#:host "localhost"))
|
||||
(equal? #f (get-opt opts '#:user #f))
|
||||
(equal? #f (get-opt opts '#:dir #f)))
|
||||
localhost-default]
|
||||
[else default]))))
|
||||
|
||||
(define (get-content c)
|
||||
(site-config-content c))
|
||||
|
||||
(define (client-name opts)
|
||||
(or (get-opt opts '#:name)
|
||||
(get-opt opts '#:host)
|
||||
"localhost"))
|
||||
|
||||
(define (get-path-opt opt key default #:localhost [localhost-default default])
|
||||
(define d (get-opt opt key default #:localhost localhost-default))
|
||||
(if (path? d)
|
||||
(path->string d)
|
||||
d))
|
||||
|
||||
(define (add-defaults c . l)
|
||||
(let loop ([c c] [l l])
|
||||
(cond
|
||||
[(null? l) c]
|
||||
[else (loop (hash-set c (car l)
|
||||
(hash-ref c (car l) (lambda () (cadr l))))
|
||||
(cddr l))])))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Managing VirtualBox machines
|
||||
|
||||
(define (start-client c max-vm)
|
||||
(define vbox (get-opt c '#:vbox))
|
||||
(when vbox
|
||||
(start-vbox-vm vbox
|
||||
#:max-vms max-vm
|
||||
#:dry-run? dry-run)))
|
||||
|
||||
(define (stop-client c)
|
||||
(define vbox (get-opt c '#:vbox))
|
||||
(when vbox
|
||||
(stop-vbox-vm vbox)))
|
||||
|
||||
(define (try-until-ready c host port user server-port kind cmd)
|
||||
(when (get-opt c '#:vbox)
|
||||
;; A VM may take a little while to get networking set up and
|
||||
;; respond, so give a dummy `cmd` a few tries
|
||||
(let loop ([tries 3])
|
||||
(unless (ssh-script host port user server-port kind cmd)
|
||||
(sleep 1)
|
||||
(loop (sub1 tries))))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define scp (find-executable-path "scp"))
|
||||
(define ssh (find-executable-path "ssh"))
|
||||
|
||||
(define (system*/show exe . args)
|
||||
(displayln (apply ~a #:separator " "
|
||||
(map (lambda (p) (if (path? p) (path->string p) p))
|
||||
(cons exe args))))
|
||||
(flush-output)
|
||||
(case dry-run
|
||||
[(ok) #t]
|
||||
[(fail) #f]
|
||||
[(error) (error "error")]
|
||||
[(stuck) (semaphore-wait (make-semaphore))]
|
||||
[(frozen) (break-enabled #f) (semaphore-wait (make-semaphore))]
|
||||
[else
|
||||
(apply system* exe args)]))
|
||||
|
||||
(define (ssh-script host port user server-port kind . cmds)
|
||||
(for/and ([cmd (in-list cmds)])
|
||||
(when cmd (display-time))
|
||||
(or (not cmd)
|
||||
(if (and (equal? host "localhost")
|
||||
(not user))
|
||||
(apply system*/show cmd)
|
||||
(apply system*/show ssh
|
||||
"-p" (~a port)
|
||||
;; create tunnel to connect back to server:
|
||||
"-R" (~a server-port ":localhost:" server-port)
|
||||
(if user
|
||||
(~a user "@" host)
|
||||
host)
|
||||
(if (eq? kind 'unix)
|
||||
;; ssh needs an extra level of quoting
|
||||
;; relative to sh:
|
||||
(for/list ([arg (in-list cmd)])
|
||||
(~a "'"
|
||||
(regexp-replace* #rx"'" arg "'\"'\"'")
|
||||
"'"))
|
||||
;; windows quoting built into `cmd' aready
|
||||
cmd))))))
|
||||
|
||||
(define (q s)
|
||||
(~a "\"" s "\""))
|
||||
|
||||
(define (qq l kind)
|
||||
(case kind
|
||||
[(unix macosx)
|
||||
(~a "'"
|
||||
(apply ~a #:separator " " (map q l))
|
||||
"'")]
|
||||
[(windows windows/bash)
|
||||
(~a "\""
|
||||
(apply
|
||||
~a #:separator " "
|
||||
(for/list ([i (in-list l)])
|
||||
(~a "\\\""
|
||||
i
|
||||
;; A backslash is literal unless followed by a
|
||||
;; quote. If `i' ends in backslashes, they
|
||||
;; must be doubled, because the \" added to
|
||||
;; the end will make them treated as escapes.
|
||||
(let ([m (regexp-match #rx"\\\\*$" i)])
|
||||
(car m))
|
||||
"\\\"")))
|
||||
"\"")]))
|
||||
|
||||
(define (shell-protect s kind)
|
||||
(case kind
|
||||
[(windows/bash)
|
||||
;; Protect Windows arguments to go through bash, where
|
||||
;; unquoted backslashes must be escaped, but quotes are effectively
|
||||
;; preserved by the shell, and quoted backslashes should be left
|
||||
;; alone; also, "&&" must be quoted to avoid parsing by bash
|
||||
(regexp-replace* "&&"
|
||||
(list->string
|
||||
;; In practice, the following loop is likely to
|
||||
;; do nothing, because constructed command lines
|
||||
;; tend to have only quoted backslashes.
|
||||
(let loop ([l (string->list s)] [in-quote? #f])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(and (equal? #\\ (car l))
|
||||
(not in-quote?))
|
||||
(list* #\\ #\\ (loop (cdr l) #f))]
|
||||
[(and in-quote?
|
||||
(equal? #\\ (car l))
|
||||
(pair? (cdr l))
|
||||
(or (equal? #\" (cadr l))
|
||||
(equal? #\\ (cadr l))))
|
||||
(list* #\\ (cadr l) (loop (cddr l) #t))]
|
||||
[(equal? #\" (car l))
|
||||
(cons #\" (loop (cdr l) (not in-quote?)))]
|
||||
[else
|
||||
(cons (car l) (loop (cdr l) in-quote?))])))
|
||||
"\"\\&\\&\"")]
|
||||
[else s]))
|
||||
|
||||
(define (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)))))
|
||||
|
|
@ -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)])))
|
||||
|
|
@ -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)))]))
|
||||
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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))
|
||||
|
|
@ -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))))))))
|
||||
|
|
@ -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 <mode>"
|
||||
(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)))))
|
||||
|
|
@ -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"))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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.}))
|
||||
|
|
@ -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 <dir> subdirectory"
|
||||
(set! from-dir dir)]
|
||||
#:args (config-file config-mode server-hosts server-port . during-cmd)
|
||||
(values config-file config-mode
|
||||
server-hosts (string->number server-port)
|
||||
during-cmd)))
|
||||
|
||||
(define server-hosts
|
||||
(hash-ref (extract-options config-file config-mode)
|
||||
'#:server-hosts
|
||||
(string-split default-server-hosts ",")))
|
||||
(define server-port
|
||||
(hash-ref (extract-options config-file config-mode)
|
||||
'#:server-port
|
||||
default-server-port))
|
||||
|
||||
(define build-dir (path->complete-path "build"))
|
||||
(define built-dir (build-path build-dir from-dir))
|
||||
(define native-dir (build-path build-dir "native"))
|
||||
|
||||
(define dirs (list built-dir native-dir))
|
||||
|
||||
(define (pkg-name->info req name)
|
||||
(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))))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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))
|
||||
|
|
@ -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.
|
||||
|
|
@ -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))
|
||||
|
|
@ -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")
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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].}
|
||||
|
|
@ -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.
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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.
|
||||
|
|
@ -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))
|
||||
Loading…
Reference in New Issue
Block a user