suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

completed the planet library documentation and, in the process,

Browse Source 
cleaned up various dependencies and exports from some of the libraries
This commit is contained in:
Robby Findler 2011-07-06 18:18:22 +08:00
parent b98e1b189a
commit fbccf38d50
17 changed files with 1672 additions and 1478 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/planet/cachepath.rkt
View File

@ -2,12 +2,11 @@
(require "config.rkt")
(provide get-planet-cache-path)
;; get-planet-cache-path : -> path[absolute, file]
;; the path to the cache.rktd file for the planet installation
;; (n.b. this used to have the side effect of creating the path
;; if it didn't exist, but since this function may be run at
;; setup time and setup-time programs must not create this sort
;; of directory, it doesn't do that anymore)
(define (get-planet-cache-path)
(let ((path (build-path (PLANET-DIR) "cache.rktd")))
path))

52
collects/planet/config.rkt
View File

@ -1,27 +1,25 @@
(module config racket/base
(require "private/define-config.rkt")
(define-parameters
(PLANET-SERVER-NAME "planet.racket-lang.org")
(PLANET-SERVER-PORT 270)
(PLANET-CODE-VERSION "300")
(PLANET-BASE-DIR (let ([plt-planet-dir-env-var (getenv "PLTPLANETDIR")])
(if plt-planet-dir-env-var
(string->path plt-planet-dir-env-var)
(build-path (find-system-path 'addon-dir)
"planet"
(PLANET-CODE-VERSION)))))
(PLANET-DIR (build-path (PLANET-BASE-DIR) (version)))
(CACHE-DIR (build-path (PLANET-DIR) "cache"))
(UNINSTALLED-PACKAGE-CACHE (build-path (PLANET-BASE-DIR) "packages"))
(LINKAGE-FILE (build-path (PLANET-DIR) "LINKAGE"))
(HARD-LINK-FILE (build-path (PLANET-BASE-DIR) (version) "HARD-LINKS"))
(LOGGING-ENABLED? #t)
(LOG-FILE (build-path (PLANET-DIR) "INSTALL-LOG"))
(DEFAULT-PACKAGE-LANGUAGE (version))
(USE-HTTP-DOWNLOADS? #t)
(HTTP-DOWNLOAD-SERVLET-URL (let ([plt-planet-url-env-var (getenv "PLTPLANETURL")])
(or plt-planet-url-env-var
"http://planet.racket-lang.org/servlets/planet-servlet.ss")))
(PLANET-ARCHIVE-FILTER #f)))
#lang racket/base
(require "private/define-config.rkt")
(define-parameters
(PLANET-SERVER-NAME "planet.racket-lang.org")
(PLANET-SERVER-PORT 270)
(PLANET-CODE-VERSION "300")
(PLANET-BASE-DIR (let ([plt-planet-dir-env-var (getenv "PLTPLANETDIR")])
(if plt-planet-dir-env-var
(string->path plt-planet-dir-env-var)
(build-path (find-system-path 'addon-dir)
"planet"
(PLANET-CODE-VERSION)))))
(PLANET-DIR (build-path (PLANET-BASE-DIR) (version)))
(CACHE-DIR (build-path (PLANET-DIR) "cache"))
(UNINSTALLED-PACKAGE-CACHE (build-path (PLANET-BASE-DIR) "packages"))
(LINKAGE-FILE (build-path (PLANET-DIR) "LINKAGE"))
(HARD-LINK-FILE (build-path (PLANET-BASE-DIR) (version) "HARD-LINKS"))
(LOG-FILE (build-path (PLANET-DIR) "INSTALL-LOG"))
(DEFAULT-PACKAGE-LANGUAGE (version))
(USE-HTTP-DOWNLOADS? #t)
(HTTP-DOWNLOAD-SERVLET-URL (let ([plt-planet-url-env-var (getenv "PLTPLANETURL")])
(or plt-planet-url-env-var
"http://planet.racket-lang.org/servlets/planet-servlet.ss")))
(PLANET-ARCHIVE-FILTER #f))

17
collects/planet/planet-archives.rkt
View File

@ -3,29 +3,18 @@
"config.rkt"
"cachepath.rkt")
(provide repository-tree
get-installed-planet-archives
(provide get-installed-planet-archives
get-hard-linked-packages
get-all-planet-packages
get-planet-cache-path)
(define (repository-tree)
(define (id x) x)
(filter-tree-by-pattern
(directory->tree
(CACHE-DIR)
(lambda (x)
(not (regexp-match? #rx"/(?:[.]git.*|[.]svn|CVS)$" (path->string x))))
4)
(list id id id string->number string->number)))
;; get-installed-planet-dirs : -> listof (list path[absolute, dir] string string (listof string) nat nat)
;; get-installed-planet-archives : -> listof (list path[absolute, dir] string string (listof string) nat nat)
;; directories of all normally-installed planet archives [excluding hard links]
(define (get-installed-planet-archives)
(with-handlers ((exn:fail:filesystem:no-directory? (lambda (e) '())))
(tree-apply
(lambda (rep-name owner package maj min)
(let ((x (list
(let ((x (list
(build-path (CACHE-DIR) owner package (number->string maj) (number->string min))
owner
package

483
collects/planet/planet.scrbl
View File

@ -464,488 +464,7 @@ reader.
The @racketmodname[planet] module (as opposed to the reader used with
@hash-lang[]) implements the @exec{raco planet} command-line tool.
@section{Utility Libraries}
The planet collection provides configuration and utilities for using PLaneT.
@subsection{Resolver}
@defmodule[planet/resolver]
The primary purpose of this library to for @racket[require] to find
@PLaneT packages. It also, however, provides some utilities for manipulating
the resolvers behavior.
@defproc[(resolve-planet-path [planet-path any/c]) path?]{
Returns the path where the file named by the require spec @racket[planet-path] is located in the current installation.
}
@defparam[download? dl? boolean?]{
A parameter that controls if @PLaneT attempts to download a planet package that isn't already present.
If the package isn't present, the resolver will raise the @racket[exn:fail:planet?] exception
instead of downloading it.
}
@defparam[install? inst? boolean?]{
A parameter that controls if @PLaneT attempts to install a planet package that isn't already installed.
If the package isn't installed, the resolver will raise the @racket[exn:fail:planet?] exception
instead of installing it.
}
@subsection{Client Configuration}
@defmodule[planet/config]
The @racketmodname[planet/config] library provides several parameters
useful for configuring how PLaneT works.
Note that while these parameters can be useful to modify
programmatically, PLaneT code runs at module-expansion time, so
most user programs cannot set them until PLaneT has already
run. Therefore, to meaningfully change these settings, it is best to
manually edit the config.rkt file.
@defparam[PLANET-DIR dir path-string?]{
The root PLaneT directory. If the environment variable
@indexed-envvar{PLTPLANETDIR} is
set, default is its value; otherwise the default is the directory in
which @filepath{config.rkt} is found.}
@defparam[CACHE-DIR dir path-string?]{
The root of the PLaneT client's cache directory.}
@defparam[UNINSTALLED-PACKAGE-CACHE dir path-string?]{
The root of the PLaneT client's uninstalled-packages cache. PLaneT
stores package distribution files in this directory, and searches for
them in this directory for them if necessary. Unlike the main PLaneT
cache, which contains compiled files and is specific to each
particular version of Racket, the uninstalled package cache is
shared by all versions of Racket that use the same package
repository, and it is searched if a package is not installed in the
primary cache and cannot be downloaded from the central PLaneT repository
(for instance due to a loss of Internet connectivity). This behavior
is intended to primarily benefit users who upgrade their Racket
installations frequently.}
@defparam[LINKAGE-FILE file path-string?]{
The file to use as the first place PLaneT looks to determine how a
particular PLaneT dependence in a file should be satisfied. The
contents of this file are used to ensure that no "magic upgrades"
occur after a package is installed. The default is the file @filepath{LINKAGE}
in the root PLaneT directory.}
@defparam[LOG-FILE file (or/c path-string? false?)]{
If @racket[#f], indicates that no logging should take place. Otherwise
specifies the file into which logging should be written. The default
is the file @filepath{INSTALL-LOG} in the root PLaneT directory.}
@defboolparam[USE-HTTP-DOWNLOADS? bool]{
PLaneT can use two different protocols to retrieve packages. If @racket[#t],
PLaneT will use the HTTP protocol; if @racket[#f] it will use the custom-built
PLaneT protocol. The default value for this parameter is @racket[#t] and setting
this parameter to @racket[#f] is not recommended.}
@defparam[HTTP-DOWNLOAD-SERVLET-URL url string?]{
The URL for the servlet that will provide PLaneT packages if
@racket[USE-HTTP-DOWNLOADS?] is @racket[#t], represented as a string.
This defaults to the value of the @indexed-envvar{PLTPLANETURL} environment
variable if it is set and otherwise is
@racket["http://planet.racket-lang.org/servlets/planet-servlet.rkt"].}
@defparam[PLANET-SERVER-NAME host string?]{
The name of the PLaneT server to which the client should connect if
@racket[USE-HTTP-DOWNLOADS?] is @racket[#f]. The default value for this parameter is
@racket["planet.racket-lang.org"].}
@defparam[PLANET-SERVER-PORT port natural-number?]{
The port on the server the client should connect to if
@racket[USE-HTTP-DOWNLOADS?] is @racket[#f]. The default value for this parameter is
@racket[270].}
@subsection[#:tag "util.rkt"]{Package Archive}
@defmodule[planet/util]
The @racketmodname[planet/util] library supports examination of the pieces of
PLaneT. It is meant primarily to support debugging and to allow easier
development of higher-level package-management tools. The
functionality exposed by @seclink["cmdline"]{the @exec{raco planet} command-line tool} is
also available programmatically through this library.
@defproc[(download/install-pkg [owner string?]
[pkg (and/c string? #rx"[.]plt")]
[maj natural-number/c]
[min natural-number/c])
(or/c pkg? #f)]{
Downloads and installs the package specifed by the given owner name,
package name, major and minor version number. Returns false if no such
package is available; otherwise returns a package structure for the
installed package.
The @racket[pkg] argument must end with @racket[".plt"].
}
@defproc[(install-pkg [pkg-spec pkg-spec?]
[file path-string?]
[maj natural-number/c]
[min natural-number/c])
(or/c pkg-spec? #f)]{
Installs the package represented by the arguments, using
the @racket[pkg-spec] argument to find the path and name of
the package to install.
See @racket[get-package-spec] to build a @racket[pkg-spec] argument.
Returns a new @racket[pkg-spec?] corresponding to the package
that was actually installed.
}
@defproc[(get-package-spec [owner string?]
[pkg (and/c string? #rx"[.]plt")]
[maj (or/c #f natural-number/c) #f]
[min (or/c #f natural-number/c) #f])
pkg-spec?]{
Builds a @racket[pkg-spec?] corresponding to the package specified by
@racket[owner], @racket[pkg], @racket[maj], and @racket[min].
The @racket[pkg] argument must end with the string @racket[".plt"].
}
@defproc[(pkg-spec? [v any/c]) boolean?]{
Recognizes the result of @racket[get-package-spec] (and @racket[install-pkg]).
}
@defparam[current-cache-contents contents
(listof
(list/c string?
(listof
(list/c string?
(cons/c natural-number/c
(listof natural-number/c))))))]{
Holds a listing of all package names and versions installed in the
local cache.}
@defproc[(current-linkage)
(listof (list/c path-string?
(list/c string?
(list/c string?)
natural-number/c
natural-number/c)))]{
Returns the current linkage table.
The linkage table is an association between file locations (encoded as path strings)
and concrete planet package versions. If a require line in the associated file requests a package,
this table is consulted to determine a particular concrete package to satisfy the request.}
@defproc[(make-planet-archive [directory path-string?]
[output-file (or/c path? path-string?)
(string-append (path->string name) ".plt")])
path-string?]{
Makes a .plt archive file suitable for PLaneT whose contents are all
files in the given directory and returns that file's name. If the
optional filename argument is provided, that filename will be used as
the output file's name.}
@defproc[(unpack-planet-archive [plt-file (or/c path? path-string?)]
[output-dir (or/c path? path-string?)])
any]{
Unpacks the PLaneT archive with the given filename, placing its contents
into the given directory (creating that path if necessary).}
@defproc[(remove-pkg [owner string?]
[pkg (and/c string? #rx"[.]plt")]
[maj natural-number/c]
[min natural-number/c])
any]{
Removes the specified package from the local planet cache.
The @racket[pkg] argument must end with the string @racket[".plt"].
}
@defproc[(display-plt-file-structure [plt-file (or/c path-string? path?)])
any]{
Print a tree representing the file and directory structure of the
PLaneT archive .plt file named by @racket[plt-file] to @racket[(current-output-port)].}
@defproc[(display-plt-archived-file [plt-file (or/c path-string? path?)]
[file-to-print string?])
any]{
Print the contents of the file named @racket[file-to-print] within the
PLaneT archive .plt file named by @racket[plt-file] to @racket[(current-output-port)].}
@defproc[(unlink-all) any]{
Removes the entire linkage table from the system, which will force all
modules to relink themselves to PLaneT modules the next time they run.}
@defproc[(add-hard-link [owner string?]
[pkg (and/c string? #rx"[.]plt$")]
[maj natural-number/c]
[min natural-number/c]
[dir path?])
any]{
Adds a development link between the specified package and the given
directory; once a link is established, PLaneT will treat the cache as
having a package with the given owner, name, and version whose files
are located in the given path. This is intended for package
development; users only interested in using PLaneT packages
available online should not need to create any development links.
If the specified package already has a development link, this function
first removes the old link and then adds the new one.
The @racket[pkg] argument must end with the string @racket[".plt"].
}
@defproc[(remove-hard-link [owner string?]
[pkg (and/c string? #rx"[.]plt")]
[maj natural-number/c]
[min natural-number/c]
[#:quiet? quiet? boolean? #false])
any]{
Removes any hard link that may be associated with the given package.
The @racket[pkg] argument must end with the string @racket[".plt"].
The @racket[maj] and @racket[min] arguments must be integers. This
procedure signals an error if no such link exists, unless
@racket[#:quiet?] is @racket[#true].
}
@defproc[(resolve-planet-path [spec quoted-planet-require-spec?])
path?]{
Returns the file system path to the file specified by the given quoted
planet require specification. This function downloads and installs the
specified package if necessary, but does not verify that the actual
file within it actually exists.}
@deftogether[(
@defform[(this-package-version)]
@defform[(this-package-version-name)]
@defform[(this-package-version-owner)]
@defform[(this-package-version-maj)]
@defform[(this-package-version-min)]
)]{
Aliases of the same bindings from @racketmodname[planet/version] for backward
compatibility.
}
@defproc[(path->package-version [p path?])
(or/c (list/c string? string? natural-number/c natural-number/c) #f)]{
Given a path that corresponds to a PLaneT package (or some part of one),
produces a list corresponding to its name and version, exactly like
@racket[(this-package-version)]. Given any other path, produces @racket[#f].
}
@defproc[(exn:fail:planet? [val any/c]) boolean?]{
Returns @racket[#t] if @racket[val] is an exception indicating a planet-specific failure.
}
@subsection[#:tag "version.rkt"]{Package Version}
Provides bindings for @|PLaneT| developers that automatically
produce references to the name and version of the containing @|PLaneT| package
so the same code may be reused across releases without accidentally referring to
a different version of the same package.
@defmodule[planet/version]
@deftogether[(
@defform[(this-package-version)]
@defform*[[(this-package-version-symbol)
(this-package-version-symbol suffix-id)]]
@defform[(this-package-version-name)]
@defform[(this-package-version-owner)]
@defform[(this-package-version-maj)]
@defform[(this-package-version-min)]
)]{
Macros that expand into expressions that evaluate to information about the name,
owner, and version number of the package in which they
appear. @racket[this-package-version] returns a list consisting of a string
naming the package's owner, a string naming the package, a number indicating the
package major version and a number indicating the package minor version, or
@racket[#f] if the expression appears outside the context of a package.
The macros @racket[this-package-version-name],
@racket[this-package-version-owner], @racket[this-package-version-maj], and
@racket[this-package-version-min] produce the relevant fields of the package
version list.
@racket[this-package-version-symbol] produces a symbol
suitable for use in @racket[planet] module paths. For instance, in version
@racketmodfont{1:0} of the package @racketmodfont{package.plt} owned by
@racketmodfont{author}, @racket[(this-package-version-symbol dir/file)] produces
@racket['author/package:1:0/dir/file]. In the same package,
@racket[(this-package-version-symbol)] produces @racket['author/package:1:0].
}
@defform[(this-package-in suffix-id ...)]{
A @racket[require] sub-form that requires modules from within the same @|PLaneT|
package version as the require, as referred to by each @racket[suffix-id]. For
instance, in version @racketmodfont{1:0} of the package
@racketmodfont{package.plt} owned by @racketmodfont{author},
@racket[(require (this-package-in dir/file))] is equivalent to
@racket[(require (planet author/package:1:0/dir/file))].
@italic{Note:} Use @racket[this-package-in] when documenting @|PLaneT| packages
with Scribble to associate each documented binding with the appropriate package.
}
@subsection[#:tag "syntax.rkt"]{Macros and Syntax Objects}
@defmodule[planet/syntax]
Provides bindings useful for @|PLaneT|-based macros.
@deftogether[(
@defproc[(syntax-source-planet-package [stx syntax?]) (or/c list? #f)]
@defproc[(syntax-source-planet-package-owner [stx syntax?]) (or/c string? #f)]
@defproc[(syntax-source-planet-package-name [stx syntax?]) (or/c string? #f)]
@defproc[(syntax-source-planet-package-major [stx syntax?]) (or/c integer? #f)]
@defproc[(syntax-source-planet-package-minor [stx syntax?]) (or/c integer? #f)]
@defproc[(syntax-source-planet-package-symbol
[stx syntax?]
[suffix (or/c symbol? #f) #f])
(or/c symbol? #f)]
)]{
Produce output analogous to @racket[this-package-version],
@racket[this-package-version-owner], @racket[this-package-version-name],
@racket[this-package-version-maj], @racket[this-package-version-min], and
@racket[this-package-version-symbol] based on the source location of
@racket[stx].
}
@defproc[(make-planet-require-spec
[stx syntax?]
[suffix (or/c symbol? #f) #f])
syntax?]{
Produces a @racket[require] sub-form for the module referred to by
@racket[suffix] in the @|PLaneT| package containing the source location of
@racket[stx].
}
@subsection[#:tag "scribble.rkt"]{Scribble Documentation}
@defmodule[planet/scribble]
Provides bindings for documenting @|PLaneT| packages.
@defform[(this-package-in suffix-id ...)]{
This binding from @racketmodname[planet/version] is also exported from
@racketmodname[planet/scribble], as it is useful for @racket[for-label] imports
in Scribble documentation.
}
@deftogether[(
@defform[(racketmod/this-package maybe-file suffix-id datum ...)]
@defform*[((racketmodname/this-package suffix-id)
(racketmodname/this-package (#,(racket unsyntax) suffix-expr)))]
@defform[(racketmodlink/this-package suffix-id pre-content-expr ...)]
@defform[(defmodule/this-package maybe-req suffix-id maybe-sources pre-flow ...)]
@defform*[((defmodulelang/this-package suffix-id maybe-sources pre-flow ...)
(defmodulelang/this-package suffix-id
#:module-paths (mod-suffix-id ...) maybe-sources
pre-flow ...))]
@defform[(defmodulereader/this-package suffix-id maybe-sources pre-flow ...)]
@defform[(defmodule*/this-package maybe-req (suffix-id ...+)
maybe-sources pre-flow ...)]
@defform*[((defmodulelang*/this-package (suffix-id ...+)
maybe-sources pre-flow ...)
(defmodulelang*/this-package (suffix-id ...+)
#:module-paths (mod-suffix-id ...) maybe-sources
pre-flow ...))]
@defform[(defmodulereader*/this-package (suffix-id ...+)
maybe-sources pre-flow ...)]
@defform[(defmodule*/no-declare/this-package maybe-req (suffix-id ...+)
maybe-sources pre-flow ...)]
@defform*[((defmodulelang*/no-declare/this-package (suffix-id ...+)
maybe-sources pre-flow ...)
(defmodulelang*/no-declare/this-package (suffix-id ...+)
#:module-paths (mod-suffix-id ...) maybe-sources pre-flow ...))]
@defform[(defmodulereader*/no-declare/this-package (suffix-id ...+)
maybe-sources pre-flow ...)]
@defform[(declare-exporting/this-package suffix-id ... maybe-sources)]
)]{
Variants of @racket[racketmod], @racket[racketmodname],
@racket[racketmodlink], @racket[defmodule], @racket[defmodulereader],
@racket[defmodulelang], @racket[defmodule*], @racket[defmodulelang*],
@racket[defmodulereader*], @racket[defmodule*/no-declare],
@racket[defmodulelang*/no-declare],
@racket[defmodulereader*/no-declare], and @racket[declare-exporting],
respectively, that implicitly refer to the PLaneT package that
contains the enclosing module.
The full module name passed to @racket[defmodule], etc is formed by
appending the @racket[suffix-id] or @racket[mod-suffix-id] to the
symbol returned by @racket[(this-package-version-symbol)], separated
by a @litchar{/} character, and tagging the resulting symbol as a
@racket[planet] module path. As a special case, if @racket[suffix-id]
is @racketid[main], the suffix is omitted.
For example, within a package named @tt{package.plt} by @tt{author},
version @tt{1:0}, the following are equivalent:
@racketblock[
(defmodule/this-package dir/file)
@#,elem{=} (defmodule (planet author/package:1:0/dir/file))
]
and
@racketblock[
(defmodule/this-package main)
@#,elem{=} (defmodule (planet author/package:1:0))
]
}
@subsection{Terse Status Updates}
@defmodule[planet/terse-info]
This module provides access to some PLaneT status information. This
module is first loaded by PLaneT in the initial namespace (when
PLaneT's resolver is loaded), but PLaneT uses @racket[dynamic-require] to load
this module each time it wants to announce information. Similarly, the
state of which procedures are registered (via @racket[planet-terse-register])
is saved in the namespace, making the listening and information producing
namespace-specific.
@defproc[(planet-terse-register
[proc (-> (or/c 'download 'install 'docs-build 'finish)
string?
any/c)])
void?]{
Registers @racket[proc] as a function to be called when
@racket[planet-terse-log] is called.
Note that @racket[proc] is called
asynchronously (ie, on some thread other than the one calling @racket[planet-terse-register]).
}
@defproc[(planet-terse-log [id (or/c 'download 'install 'finish)]
[msg string?]) void?]{
This function is called by PLaneT to announce when things are happening. See also
@racket[planet-terse-set-key].
}
@defproc[(planet-terse-set-key [key any/c]) void?]{
This sets a @seclink["threadcells" #:doc '(lib "scribblings/reference/reference.scrbl")]{thread cell}
to the value of @racket[key].
The value of the thread cell is used as an index into a table to determine which
of the functions passed to @racket[planet-terse-register] to call when
@racket[planet-terse-log] is called.
The table holding the key uses ephemerons and a weak hash table to ensure that
when the @racket[key] is unreachable, then the procedures passed to @racket[planet-terse-log]
cannot be reached through the table.
}
@include-section["private/util.scrbl"]
@section{Developing Packages for PLaneT}

4
collects/planet/parsereq.rkt → collects/planet/private/parsereq.rkt
View File

@ -1,8 +1,8 @@
#lang racket/base
(require mzlib/match
"private/short-syntax-helpers.rkt"
"private/data.rkt")
"short-syntax-helpers.rkt"
"data.rkt")
(provide (struct-out request)
parse-package-string

12
collects/planet/private/planet-shared.rkt
View File

@ -611,3 +611,15 @@ Various common pieces of code that both the client and server need to access
;; tree->list : tree[x] -> sexp-tree[x]
(define (tree->list tree)
(cons (branch-node tree) (map tree->list (branch-children tree))))
(define (repository-tree)
(define (id x) x)
(filter-tree-by-pattern
(directory->tree
(CACHE-DIR)
(lambda (x)
(not (regexp-match? #rx"/(?:[.]git.*|[.]svn|CVS)$" (path->string x))))
4)
(list id id id string->number string->number)))

815
collects/planet/private/resolver.rkt Normal file
View File

@ -0,0 +1,815 @@
#lang racket/base
#| resolver.rkt -- PLaneT client
1. Introduction
The PLaneT system is a method for automatically sharing code packages, both as
libraries and as full applications, that gives every user of a PLaneT client
the illusion of having a local copy of every code package on the server, but is
parsimonious in its transmission. It consists of a centralized server that
holds all packages and individual clients that hold some portion of the archive
locally. Maintenance of that archive should be transparent, and is the complete
responsibility of the PLaneT client.
2. Client behavior
The PLaneT client receives user requests (i.e., the "(require (planet ...))"
forms) and loads the appropriate modules in response. In the course of handling
these requests it may download new code packages from the PLaneT server.
2.1 User interface
The structure of user PLaneT invocations is listed below.
PLANET-REQUEST ::= (planet FILE-NAME PKG-SPEC [PATH ...]?)
FILE-NAME ::= string
PKG-SPEC ::= string | (FILE-PATH ... PKG-NAME)
| (FILE-PATH ... PKG-NAME VER-SPEC)
VER-SPEC ::= Nat | (Nat MINOR)
MINOR ::= Nat | (Nat Nat) | (= Nat) | (+ Nat) | (- Nat)
FILE-PATH ::= string
PKG-NAME ::= string
OWNER-NAME ::= string
PATH ::= string
All strings must be legal filename strings.
When encountered, a planet-request is interpreted as requiring the given file
name from the given logical package, specified by the package spec and the
collection specification, if given. If no VER-SPEC is provided, the most recent
version is assumed. If no owner-name/path ... clause is provided, the default
package is assumed.
2. PLaneT protocol
PLaneT clients support two protocols for communicating with the PLaneT server:
the standard HTTP GET/response system (currently the default) and a specialized
TCP-based protocol that may become more important if PLaneT becomes smarter
about downloading packages behind the scenes.
In the following sections we describe the specialized protocol only.
2.1 Overview
1. PLaneT client establishes TCP connection to PLaneT server.
2. Client transmits a version specifier.
3. Server either refuses that version and closes connection or accepts.
4. Client transmits a sequence of requests terminated by a special
end-of-request marker. Simultaneously, server transmits responses to those
requests.
5. Once the server has handled every request, it closes the connection.
I am concerned about the overhead of opening and closing TCP connections for a
large program with many requires, so I want to allow many requests and
responses over the same connection. Unfortunately there's a wrinkle: the
standard client, implemented the obvious way, would be unable to send more than
one request at a time because it gets invoked purely as a response to a require
form and must load an appropriate file before it returns. This means I can't
batch up multiple requires, at least not with an obvious implementation.
A possible solution would be to implement an install program that walks over
the syntax tree of a program and gathers all requires, then communicates with
the server and learns what additional packages would be necessary due to those
requires, and then downloads all of them at once. We would have to implement
both methods simultaneously, though, to allow for REPL-based PLaneT use and
dynamic-require (unless we want it to be a runtime exception to use PLaneT from
the REPL or via dynamic-require, something I'd rather not do), so I want a
protocol that will allow both forms of access easily. This protocol does that,
and doesn't require too much additional overhead in the case that the client
only takes one package at a time.
2.2 Communication Details
After a TCP connection is established, the client transmits a
VERSION-SPECIFIER:
VERSION-SPECIFIER ::= "PLaneT/1.0\n"
The server responds with a VERSION-RESPONSE:
VERSION-RESPONSE ::=
| 'ok "\n"
| ('invalid string) "\n"
where the string in the invalid case is descriptive text intended for display
to the user that may indicate some specific message about the nature of the
error.
If the server sends 'invalid, the server closes the connection. Otherwise, the
client may send any number of requests, followed by an end-of-request marker:
REQUESTS ::= { REQUEST "\n"}* 'end "\n"
REQUEST ::= (SEQ-NO 'get PKG-LANG PKG-NAME (Nat | #f) (Nat | #f) (Nat | #f)
[OWNER-NAME PATH ...]?)
PKG-LANG ::= String
SEQ-NO ::= Nat
The fields in a request are a uniquely identifying sequence number, the literal
symbol 'get, the name of the package to receive, the required major version and
the lowest and highest acceptable version (with #f meaning that there is no
constraint for that field, and a #f in major-version field implying that both
other fields must also be #f), and the package path.
As the client is transmitting a REQUESTS sequence, the server begins responding
to it with RESPONSE structures, each with a sequence number indicating to which
request it is responding (except in the case of input too garbled to extract a
sequence number):
RESPONSE ::=
| ('error 'malformed-input string) "\n"
| (SEQ-NO 'error 'malformed-request string) "\n"
| (SEQ-NO 'bad-language string) "\n"
| (SEQ-NO 'get 'ok Nat Nat Nat) "\n" BYTE-DATA
| (SEQ-NO 'get 'error ERROR-CODE string) "\n"
ERROR-CODE ::= 'not-found
If the server receives a malformed request, it may close connection after
sending a malformed-request response without processing any other
requests. Otherwise it must process all requests even in the event of an
error. On a successful get, the three numbers the server returns are the
matched package's major version, the matched package's minor version, and the
number of bytes in the package.
3 Client Download Policies
Racket invokes the PLaneT client once for each instance of a require-planet
form in a program being run (i.e., the transitive closure of the "requires"
relation starting from some specified root module; this closure is calculable
statically). At each of these invocations, the client examines its internal
cache to see if an appropriate module exists that matches the specification
given by the user (for details see the next section). If one does, the client
loads that module and returns. If none does, it initiates a transaction with
the server using the PLaneT protocol described in the previous subsection and
sends a single request consisting of the user's request. It installs the
resulting .plt file and then loads the appropriate file.
The client keeps a cache of downloaded packages locally. It does so in the
$PLTCOLLECTS/planet/cache/ directory and subdirectories, in an intuitive
manner: each item in the package's path in the PLaneT require line correspond
to a subdirectory in the cache directory, starting with the owner name. (They
should be unpacked relative to some user-specific rather than
installation-specific place, possibly, but that's difficult to do so we won't
do it yet).
To check whether a package is installed when attempting to satisfy a
requirement, the client checks its cache to see if an appropriate entry exists
in its link-table for that require line. If one exists, it uses the named
package directly. If none exists, it checks to see if there is an appropriate
subdirectory.
||#
;; This `resolver' no longer fits the normal protocol for a
;; module name resolver, because it accepts an extra argument in
;; the second case. The extra argument is a parameterization
;; to use for installation actions.
(define resolver
(case-lambda
[(name) (void)]
[(spec module-path stx load? orig-paramz)
;; ensure these directories exist
(make-directory* (PLANET-DIR))
(make-directory* (CACHE-DIR))
(establish-diamond-property-monitor)
(planet-resolve spec
(current-module-declare-name)
stx
load?
orig-paramz)]))
(require racket/tcp
racket/port
racket/match
racket/path
racket/file
racket/date
net/url
net/head
"../config.rkt"
"planet-shared.rkt"
"linkage.rkt"
"parsereq.rkt"
"../terse-info.rkt"
compiler/cm)
(provide (rename-out [resolver planet-module-name-resolver])
resolve-planet-path
pkg-spec->full-pkg-spec
get-package-from-cache
get-package-from-server
download-package
pkg->download-url
pkg-promise->pkg
install-pkg
get-planet-module-path/pkg
download?
install?
(struct-out exn:fail:planet))
;; if #f, will not install packages and instead raise a exn:fail:install? error
(define install? (make-parameter #t))
;; if #f, will not download packages and instead raise a exn:fail:install? error
(define download? (make-parameter #t))
(define-struct (exn:fail:planet exn:fail) ())
;; update doc index only once for a set of installs:
(define planet-nested-install (make-parameter #f))
;; =============================================================================
;; DIAMOND PROPERTY STUFF
;; make sure a module isn't loaded twice with two different versions
;; =============================================================================
(define VER-CACHE-NAME #f)
(define (establish-diamond-property-monitor)
(unless VER-CACHE-NAME (set! VER-CACHE-NAME (gensym)))
(unless (namespace-variable-value VER-CACHE-NAME #t (lambda () #f))
(namespace-set-variable-value! VER-CACHE-NAME (make-hash))))
(define (the-version-cache) (namespace-variable-value VER-CACHE-NAME))
(define (pkg->diamond-key pkg) (cons (pkg-name pkg) (pkg-route pkg)))
(define (pkg-matches-bounds? pkg bound-info)
(match-let ([(list maj lo hi) bound-info])
(and (= maj (pkg-maj pkg))
(or (not lo) (>= (pkg-min pkg) lo))
(or (not hi) (<= (pkg-min pkg) hi)))))
;; COMPAT ::= 'none | 'all | `(all-except ,VER-SPEC ...) | `(only ,VER-SPEC ...)
;; build-compatibility-fn : COMPAT -> PKG -> bool
(define (build-compatibility-fn compat-data)
(define pre-fn
(match compat-data
[`none (lambda (_) #f)]
[`all (lambda (_) #t)]
[`(all-except ,vspec ...)
(let ([bounders (map (λ (x) (version->bounds x (λ (_) #f))) vspec)])
(if (andmap (lambda (x) x) bounders)
(lambda (v)
(not (ormap (lambda (bounder) (pkg-matches-bounds? v bounder))
bounders)))
#f))]
[`(only ,vspec ...)
(let ([bounders (map (λ (x) (version->bounds x (λ (_) #f))) vspec)])
(if (andmap (lambda (x) x) bounders)
(lambda (v)
(andmap (lambda (bounder) (pkg-matches-bounds? v bounder))
bounders))
#f))]
[_ #f]))
(or pre-fn (lambda (x) #f)))
;; can-be-loaded-together? : pkg pkg -> boolean
;; side constraint: pkg1 and pkg2 are versions of the same package assumption:
;; pkg1 and pkg2 are versions of the same package determines if the two
;; versions are side-by-side compatible
(define (can-be-loaded-together? pkg1 pkg2)
(cond [(pkg> pkg1 pkg2) (can-be-loaded-together? pkg2 pkg1)]
[(pkg= pkg1 pkg2) #t]
[(pkg< pkg1 pkg2)
(let* ([info (pkg->info pkg2)]
[compat? (build-compatibility-fn
(info 'can-be-loaded-with (lambda () 'none)))])
(compat? pkg1))]))
;; stx->origin-string : stx option -> string
;; returns a description [e.g. file name, line#] of the given syntax
(define (stx->origin-string stx)
(if stx (format "~a" (syntax-source stx)) "[unknown]"))
(define (add-pkg-to-diamond-registry! pkg stx)
(let ([loaded-packages
(hash-ref (the-version-cache) (pkg->diamond-key pkg) '())])
(unless (list? loaded-packages)
(error 'PLaneT "Inconsistent state: expected loaded-packages to be a list, received: ~s" loaded-packages))
(let ([all-violations '()])
(for-each
(lambda (already-loaded-pkg-record)
(let* ([already-loaded-pkg (car already-loaded-pkg-record)]
[prior-stx (cadr already-loaded-pkg-record)]
[prior-stx-origin-string (stx->origin-string prior-stx)])
(unless (can-be-loaded-together? pkg already-loaded-pkg)
(set!
all-violations
(cons
(list
stx
(make-exn:fail
(format
"Package ~a loaded twice with multiple incompatible versions:
~a attempted to load version ~a.~a while version ~a.~a was already loaded by ~a"
(pkg-name pkg)
(stx->origin-string stx)
(pkg-maj pkg)
(pkg-min pkg)
(pkg-maj already-loaded-pkg)
(pkg-min already-loaded-pkg)
prior-stx-origin-string)
(current-continuation-marks)))
all-violations)))))
loaded-packages)
(unless (null? all-violations)
(let ([worst (or (assq values all-violations) (car all-violations))])
(raise (cadr worst)))))
(hash-set! (the-version-cache)
(pkg->diamond-key pkg)
(cons (list pkg stx) loaded-packages))))
;; =============================================================================
;; MAIN LOGIC
;; Handles the overall functioning of the resolver
;; =============================================================================
;; planet-resolve : PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> symbol
;; resolves the given request. Returns a name corresponding to the module in
;; the correct environment
(define (planet-resolve spec rmp stx load? orig-paramz)
;; install various parameters that can affect the compilation of a planet package back to their original state
(parameterize ([current-compile (call-with-parameterization orig-paramz current-compile)]
[current-eval (call-with-parameterization orig-paramz current-eval)]
[use-compiled-file-paths (call-with-parameterization orig-paramz use-compiled-file-paths)]
[current-library-collection-paths (call-with-parameterization orig-paramz current-library-collection-paths)])
(let-values ([(path pkg) (get-planet-module-path/pkg spec rmp stx)])
(when load? (add-pkg-to-diamond-registry! pkg stx))
(do-require path (pkg-path pkg) rmp stx load?))))
;; resolve-planet-path : planet-require-spec -> path
;; retrieves the path to the given file in the planet package. downloads and
;; installs the package if necessary
(define (resolve-planet-path spec)
(let-values ([(path pkg) (get-planet-module-path/pkg spec #f #f)])
path))
;; get-planet-module-path/pkg :PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG)
;; returns the matching package and the file path to the specific request
(define (get-planet-module-path/pkg spec rmp stx)
(request->pkg (spec->req spec stx) rmp stx))
;; request->pkg : request (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG)
(define (request->pkg req rmp stx)
(let* ([result (get-package rmp (request-full-pkg-spec req))])
(cond [(string? result)
(raise-syntax-error 'require result stx)]
[(pkg? result)
(values (apply build-path (pkg-path result)
(append (request-path req) (list (request-file req))))
result)])))
;; PKG-GETTER ::= module-path pspec
;; (pkg -> A)
;; ((uninstalled-pkg -> void)
;; (pkg -> void)
;; ((string | #f) -> string | #f) -> A)
;; -> A
;;
;; a pkg-getter is a function that tries to fetch a package; it is written in a
;; quasi-cps style; the first argument is what it calls to succeed, and the
;; second argument is what it calls when it fails. In the second case, it must
;; provide two things: a function to take action if a match is found
;; eventually, and a function that gets to mess with the error message if the
;; entire message eventually fails.
;; get-package : (resolved-module-path | #f) FULL-PKG-SPEC -> (PKG | string)
;; gets the package specified by pspec requested by the module in the given
;; module path, or returns a descriptive error message string if that's not
;; possible
(define (get-package rmp pspec)
(let loop ([getters (*package-search-chain*)]
[pre-install-updaters '()]
[post-install-updaters '()]
[error-reporters '()])
(if (null? getters)
;; we have failed to fetch the package, generate an appropriate error
;; message and bail
(let ([msg (foldl (λ (f str) (f str)) #f error-reporters)])
(or msg (format "Could not find package matching ~s"
(list (pkg-spec-name pspec)
(pkg-spec-maj pspec)
(list (pkg-spec-minor-lo pspec)
(pkg-spec-minor-hi pspec))
(pkg-spec-path pspec)))))
;; try the next error reporter. recursive call is in the failure
;; continuation
((car getters)
rmp
pspec
(λ (pkg)
(when (uninstalled-pkg? pkg)
(for-each (λ (u) (u pkg)) pre-install-updaters))
(let ([installed-pkg (pkg-promise->pkg pkg)])
(for-each (λ (u) (u installed-pkg)) post-install-updaters)
installed-pkg))
(λ (pre-updater post-updater error-reporter)
(loop (cdr getters)
(cons pre-updater pre-install-updaters)
(cons post-updater post-install-updaters)
(cons error-reporter error-reporters)))))))
;; =============================================================================
;; PHASE 2: CACHE SEARCH
;; If there's no linkage, there might still be an appropriate cached module
;; (either installed or uninstalled)
;; =============================================================================
;; get/installed-cache : pkg-getter
(define (get/installed-cache _ pkg-spec success-k failure-k)
(let ([p (lookup-package pkg-spec)])
(if p (success-k p) (failure-k void void (λ (x) x)))))
;; get-package-from-cache : FULL-PKG-SPEC -> PKG | #f
(define (get-package-from-cache pkg-spec)
(lookup-package pkg-spec))
;; get/uninstalled-cache-dummy : pkg-getter
;; always fails, but records the package to the uninstalled package cache upon
;; the success of some other getter later in the chain.
(define (get/uninstalled-cache-dummy _ pkg-spec success-k failure-k)
(failure-k save-to-uninstalled-pkg-cache! void (λ (x) x)))
;; get/uninstalled-cache : pkg-getter
;; note: this does not yet work with minimum-required-version specifiers if you
;; install a package and then use an older mzscheme
(define (get/uninstalled-cache _ pkg-spec success-k failure-k)
(let ([p (lookup-package pkg-spec (UNINSTALLED-PACKAGE-CACHE))])
(if (and p (file-exists? (build-path (pkg-path p)
(pkg-spec-name pkg-spec))))
(begin
(planet-log "found local, uninstalled copy of package at ~a"
(build-path (pkg-path p)
(pkg-spec-name pkg-spec)))
(success-k
;; note: it's a little sloppy that lookup-pkg returns PKG structures,
;; since it doesn't actually know whether or not the package is
;; installed. hence I have to convert what appears to be an installed
;; package into an uninstalled package
(make-uninstalled-pkg (build-path (pkg-path p) (pkg-spec-name pkg-spec))
pkg-spec
(pkg-maj p)
(pkg-min p))))
(failure-k void void (λ (x) x)))))
;; save-to-uninstalled-pkg-cache! : uninstalled-pkg -> path[file]
;; copies the given uninstalled package into the uninstalled-package cache,
;; replacing any old file that might be there. Returns the path it copied the
;; file into.
(define (save-to-uninstalled-pkg-cache! uninst-p)
(let* ([pspec (uninstalled-pkg-spec uninst-p)]
[owner (car (pkg-spec-path pspec))]
[name (pkg-spec-name pspec)]
[maj (uninstalled-pkg-maj uninst-p)]
[min (uninstalled-pkg-min uninst-p)]
[dir (build-path (UNINSTALLED-PACKAGE-CACHE)
owner
name
(number->string maj)
(number->string min))]
[full-pkg-path (build-path dir name)])
(make-directory* dir)
(unless (equal? (normalize-path (uninstalled-pkg-path uninst-p))
(normalize-path full-pkg-path))
(when (file-exists? full-pkg-path) (delete-file full-pkg-path))
(copy-file (uninstalled-pkg-path uninst-p) full-pkg-path))
full-pkg-path))
;; =============================================================================
;; PHASE 3: SERVER RETRIEVAL
;; Ask the PLaneT server for an appropriate package if we don't have one
;; locally.
;; =============================================================================
(define (get/server _ pkg-spec success-k failure-k)
(let ([p (get-package-from-server pkg-spec)])
(cond
[(pkg-promise? p) (success-k p)]
[(string? p)
;; replace any existing error message with the server download error
;; message
(planet-log p)
(failure-k void void (λ (_) p))])))
;; get-package-from-server : FULL-PKG-SPEC -> PKG-PROMISE | #f | string[error message]
;; downloads the given package file from the PLaneT server and installs it in
;; the uninstalled-packages cache, then returns a promise for it
(define (get-package-from-server pkg)
(match (download-package pkg)
[(list #t tmpfile-path maj min)
(let* ([upkg (make-uninstalled-pkg tmpfile-path pkg maj min)]
[cached-path (save-to-uninstalled-pkg-cache! upkg)]
[final (make-uninstalled-pkg cached-path pkg maj min)])
(unless (equal? (normalize-path tmpfile-path)
(normalize-path cached-path))
(delete-file tmpfile-path)) ;; remove the tmp file, we're done with it
final)]
[(list #f str)
(string-append "PLaneT could not find the requested package: " str)]
[(? string? s)
(string-append "PLaneT could not download the requested package: " s)]))
(define (download-package pkg)
(unless (download?)
(raise (make-exn:fail:planet
(format
"PLaneT error: cannot download package ~s since the download? parameter is set to #f"
(list (car (pkg-spec-path pkg)) (pkg-spec-name pkg)))
(current-continuation-marks))))
((if (USE-HTTP-DOWNLOADS?) download-package/http download-package/planet)
pkg))
(define (current-time)
(let ([date (seconds->date (current-seconds))])
(parameterize ([date-display-format 'rfc2822])
(format "~a ~a:~a:~a"
(date->string date)
(date-hour date)
(date-minute date)
(date-second date)))))
;; pkg-promise->pkg : pkg-promise -> pkg
;; "forces" the given pkg-promise (i.e., installs the package if it isn't
;; installed yet)
(define (pkg-promise->pkg p)
(cond [(pkg? p) p]
[(uninstalled-pkg? p)
(install-pkg (uninstalled-pkg-spec p)
(uninstalled-pkg-path p)
(uninstalled-pkg-maj p)
(uninstalled-pkg-min p))]))
;; install-pkg : FULL-PKG-SPEC path[file] Nat Nat -> PKG
;; install the given pkg to the planet cache and return a PKG representing the
;; installed file
(define (install-pkg pkg path maj min)
(let ([pkg-path (pkg-spec-path pkg)]
[pkg-name (pkg-spec-name pkg)]
[pkg-string (pkg-spec->string pkg)])
(unless (install?)
(raise (make-exn:fail:planet
(format
"PLaneT error: cannot install package ~s since the install? parameter is set to #f"
(list (car pkg-path) pkg-name maj min))
(current-continuation-marks))))
(let* ([owner (car pkg-path)]
[extra-path (cdr pkg-path)]
[the-dir
(apply build-path (CACHE-DIR)
(append pkg-path (list pkg-name
(number->string maj)
(number->string min))))]
[was-nested? (planet-nested-install)])
(if (directory-exists? the-dir)
(raise (make-exn:fail
"PLaneT error: trying to install already-installed package"
(current-continuation-marks)))
(parameterize ([planet-nested-install #t])
(planet-terse-log 'install pkg-string)
(with-logging
(LOG-FILE)
(lambda ()
(printf "\n============= Installing ~a on ~a =============\n"
pkg-name
(current-time))
;; oh man is this a bad hack!
(parameterize ([current-namespace (make-base-namespace)])
(let ([ipp (dynamic-require 'setup/plt-single-installer
'install-planet-package)]
[rud (dynamic-require 'setup/plt-single-installer
'reindex-user-documentation)]
[msfh (dynamic-require 'compiler/cm 'manager-skip-file-handler)])
(parameterize ([msfh (manager-skip-file-handler)]
[use-compiled-file-paths (list (string->path "compiled"))])
(ipp path the-dir (list owner pkg-name
extra-path maj min))
(unless was-nested?
(planet-terse-log 'docs-build pkg-string)
(printf "------------- Rebuilding documentation index -------------\n")
(rud)))))))
(planet-terse-log 'finish pkg-string)
(make-pkg pkg-name pkg-path
maj min the-dir 'normal))))))
;; download-package : FULL-PKG-SPEC -> RESPONSE
;; RESPONSE ::= (list #f string) | (list #t path[file] Nat Nat)
;; downloads the given package and returns (list bool string): if bool is #t,
;; the path is to a file that contains the package. If bool is #f, the package
;; didn't exist and the string is the server's informative message.
;; raises an exception if some protocol failure occurs in the download process
(define (download-package/planet pkg)
(define stupid-internal-define-syntax
(let ([msg (format "downloading ~a from ~a via planet protocol"
(pkg-spec->string pkg)
(PLANET-SERVER-NAME))])
(planet-terse-log 'download (pkg-spec->string pkg))
(planet-log msg)))
(define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT)))
(define (close-ports) (close-input-port ip) (close-output-port op))
(define (request-pkg-list pkgs)
(for-each/n (lambda (pkg seqno)
(write-line (list* seqno 'get
(DEFAULT-PACKAGE-LANGUAGE)
(pkg-spec-name pkg)
(pkg-spec-maj pkg)
(pkg-spec-minor-lo pkg)
(pkg-spec-minor-hi pkg)
(pkg-spec-path pkg))
op))
pkgs)
(write-line 'end op)
(flush-output op))
(define (state:initialize)
(fprintf op "PLaneT/1.0\n")
(flush-output op)
(match (read ip)
['ok (state:send-pkg-request)]
[(list 'invalid (? string? msg)) (state:abort (string-append "protocol version error: " msg))]
[bad-msg (state:abort (format "server protocol error (received invalid response): ~a" bad-msg))]))
(define (state:send-pkg-request)
(request-pkg-list (list pkg))
(state:receive-package))
(define (state:receive-package)
(match (read ip)
[(list _ 'get 'ok (? nat? maj) (? nat? min) (? nat? bytes))
(let ([filename (make-temporary-file "planettmp~a.plt")])
(read-char ip) ; throw away newline that must be present
(read-n-chars-to-file bytes ip filename)
(list #t filename maj min))]
[(list _ 'error 'malformed-request (? string? msg))
(state:abort (format "Internal error (malformed request): ~a" msg))]
[(list _ 'get 'error 'not-found (? string? msg))
(state:failure (format "Server had no matching package: ~a" msg))]
[(list _ 'get 'error (? symbol? code) (? string? msg))
(state:abort (format "Unknown error ~a receiving package: ~a" code msg))]
[bad-response (state:abort (format "Server returned malformed message: ~e" bad-response))]))
(define (state:abort msg)
(raise (make-exn:i/o:protocol msg (current-continuation-marks))))
(define (state:failure msg) (list #f msg))
(with-handlers ([void (lambda (e) (close-ports) (raise e))])
(begin0
(state:initialize)
(close-ports))))
;; ------------------------------------------------------------
;; HTTP VERSION OF THE PROTOCOL
;; pkg->servlet-args : FULL-PKG-SPEC -> environment[from net/url]
;; gets the appropriate query arguments to request the given package from the
;; PLaneT HTTP download servlet
(define (pkg->servlet-args pkg)
(let ([get (lambda (access) (format "~s" (access pkg)))])
`((lang . ,(format "~s" (DEFAULT-PACKAGE-LANGUAGE)))
(name . ,(get pkg-spec-name))
(maj . ,(get pkg-spec-maj))
(min-lo . ,(get pkg-spec-minor-lo))
(min-hi . ,(get pkg-spec-minor-hi))
(path . ,(get pkg-spec-path)))))
;; get-http-response-code : header[from net/head] -> string or #f
;; gets the HTTP response code in the given header
(define (get-http-response-code header)
(let ([parsed (regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header)])
(and parsed (cadr parsed))))
;; pkg->download-url : FULL-PKG-SPEC -> url
;; gets the download url for the given package
(define (pkg->download-url pkg)
(struct-copy url
(string->url (HTTP-DOWNLOAD-SERVLET-URL))
[query (pkg->servlet-args pkg)]))
;; download-package/http : FULL-PKG-SPEC -> RESPONSE
;; a drop-in replacement for download-package that uses HTTP rather than the
;; planet protocol. The HTTP protocol does not allow any kind of complicated
;; negotiation, but it appears that many more users can make HTTP requests than
;; requests from nonstandard protocols.
(define (download-package/http pkg)
(let/ec return
(let loop ([attempts 1])
(when (> attempts 5)
(return "Download failed too many times (possibly due to an unreliable network connection)"))
(let ([msg (format "downloading ~a from ~a via HTTP~a"
(pkg-spec->string pkg)
(PLANET-SERVER-NAME)
(if (= attempts 1)
""
(format ", attempt #~a" attempts)))])
(planet-terse-log 'download (pkg-spec->string pkg))
(planet-log "~a" msg))
(with-handlers ([exn:fail:network? (λ (e) (return (exn-message e)))])
(let* ([target (pkg->download-url pkg)]
[ip (get-impure-port target)]
[head (purify-port ip)]
[response-code/str (get-http-response-code head)]
[response-code (and response-code/str
(string->number response-code/str))])
(define (abort msg)
(close-input-port ip)
(return msg))
(case response-code
[(#f)
(abort (format "Server returned invalid HTTP response code ~s"
response-code/str))]
[(200)
(let ([maj/str (extract-field "Package-Major-Version" head)]
[min/str (extract-field "Package-Minor-Version" head)]
[content-length/str (extract-field "Content-Length" head)])
(unless (and maj/str min/str content-length/str
(nat? (string->number maj/str))
(nat? (string->number min/str))
(nat? (string->number content-length/str)))
(abort "Server did not include valid major and minor version information"))
(let* ([filename (make-temporary-file "planettmp~a.plt")]
[maj (string->number maj/str)]
[min (string->number min/str)]
[content-length (string->number content-length/str)]
[op (open-output-file filename #:exists 'truncate/replace)])
(copy-port ip op)
(close-input-port ip)
(close-output-port op)
(if (= (file-size filename) content-length)
(list #t filename maj min)
(loop (add1 attempts)))))]
[(404)
(begin0 (list #f (format "Server had no matching package: ~a"
(read-line ip)))
(close-input-port ip))]
[(400)
(abort (format "Internal error (malformed request): ~a"
(read-line ip)))]
[(500)
(abort (format "Server internal error: ~a"
(apply string-append
(let loop ()
(let ([line (read-line ip)])
(if (eof-object? line)
'()
(list* line "\n" (loop))))))))]
[else
(abort (format "Internal error (unknown HTTP response code ~a)"
response-code))]))))))
;; formats the pkg-spec back into a string the way the user typed it in,
;; except it never shows the minor version number (since some later one may actually be being used)
;; assumes that the pkg-spec comes from the command-line
(define (pkg-spec->string pkg)
(format "~a/~a~a"
(if (pair? (pkg-spec-path pkg))
(car (pkg-spec-path pkg))
"<<unknown>>") ;; this shouldn't happen
(regexp-replace #rx"\\.plt$" (pkg-spec-name pkg) "")
(if (pkg-spec-maj pkg)
(format ":~a" (pkg-spec-maj pkg))
"")))
;; =============================================================================
;; MODULE MANAGEMENT
;; Handles interaction with the module system
;; =============================================================================
;; do-require : path path symbol syntax -> symbol
;; requires the given filename, which must be a module, in the given path.
(define (do-require file-path package-path module-path stx load?)
(parameterize ([current-load-relative-directory package-path])
((current-module-name-resolver) file-path module-path stx load?)))
(define *package-search-chain*
(make-parameter
(list get/linkage
get/installed-cache
get/uninstalled-cache-dummy
get/server
get/uninstalled-cache)))
;; ============================================================
;; UTILITY
;; A few small utility functions
;; make-directory*/paths : path -> (listof path)
;; like make-directory*, but returns what directories it actually created
(define (make-directory*/paths dir)
(let ([dir (if (string? dir) (string->path dir) dir)])
(let-values ([(base name dir?) (split-path dir)])
(cond [(directory-exists? dir) '()]
[(directory-exists? base) (make-directory dir) (list dir)]
[else (let ([dirs (make-directory*/paths base)])
(make-directory dir)
(cons dir dirs))]))))

651
collects/planet/private/util.scrbl Normal file
View File

@ -0,0 +1,651 @@
#lang scribble/manual
@(require
(for-label
racket/base
scribble/manual
planet/resolver
planet/config
planet/util
planet/version
planet/syntax
planet/scribble))
@title{Utility Libraries}
The planet collection provides configuration and utilities for using PLaneT.
@section{Resolver}
@defmodule[planet/resolver]
The primary purpose of this library to for @racket[require] to find
@PLaneT packages. It also, however, provides some utilities for manipulating
the resolvers behavior.
@defproc*[(((planet-module-name-resolver [r-m-p resolved-module-path?])
void?)
((planet-module-name-resolver [spec (or/c module-path? path?)]
[module-path (or/c #f resolved-module-path?)]
[stx (or/c #f syntax?)]
[load boolean?]
[orig-paramz parameterization?])
resolved-module-path?))]{
This implements the @|PLaneT| module resolution process. It is @racket[dynamic-require]d
by racket when the first planet module require is needed. It acts much like a
@racket[current-module-name-resolver] would, but racket provides it with a special
@racket[parameterization?] (giving it special privileges) that it uses when installing new packages.
}
@defproc[(get-planet-module-path/pkg [spec (or/c module-path? path?)]
[module-path (or/c #f resolved-module-path?)]
[stx (or/c #f syntax?)])
(values path? pkg?)]{
Returns the path corresponding to the planet package (interpreting the arguments
the same way as @racket[planet-module-name-resolver] and @racket[(current-module-name-resolver)]).
}
@defproc[(resolve-planet-path [planet-path any/c]) path?]{
Returns the path where the file named by the require spec @racket[planet-path] is located in the current installation.
}
@defparam[download? dl? boolean?]{
A parameter that controls if @PLaneT attempts to download a planet package that isn't already present.
If the package isn't present, the resolver will raise the @racket[exn:fail:planet?] exception
instead of downloading it.
}
@defparam[install? inst? boolean?]{
A parameter that controls if @PLaneT attempts to install a planet package that isn't already installed.
If the package isn't installed, the resolver will raise the @racket[exn:fail:planet?] exception
instead of installing it.
}
@section{Client Configuration}
@defmodule[planet/config]
The @racketmodname[planet/config] library provides several parameters
useful for configuring how PLaneT works.
Note that while these parameters can be useful to modify
programmatically, PLaneT code runs at module-expansion time, so
most user programs cannot set them until PLaneT has already
run. Therefore, to meaningfully change these settings, it is best to
manually edit the @filepath{config.rkt} file.
@defparam[PLANET-BASE-DIR dir path-string?]{
The root of the tree where planet stores all of its files. Defaults to
@racketblock[(let ([plt-planet-dir-env-var (getenv "PLTPLANETDIR")])
(if plt-planet-dir-env-var
(string->path plt-planet-dir-env-var)
(build-path (find-system-path 'addon-dir)
"planet"
(PLANET-CODE-VERSION))))]
}
@defparam[PLANET-DIR dir path-string?]{
The root of the version-specific PLaneT files.
Defaults to @racket[(build-path (PLANET-BASE-DIR) (version))].
}
@defparam[CACHE-DIR dir path-string?]{
The root of the PLaneT client's cache directory.}
@defparam[UNINSTALLED-PACKAGE-CACHE dir path-string?]{
The root of the PLaneT client's uninstalled-packages cache. PLaneT
stores package distribution files in this directory, and searches for
them in this directory for them if necessary. Unlike the main PLaneT
cache, which contains compiled files and is specific to each
particular version of Racket, the uninstalled package cache is
shared by all versions of Racket that use the same package
repository, and it is searched if a package is not installed in the
primary cache and cannot be downloaded from the central PLaneT repository
(for instance due to a loss of Internet connectivity). This behavior
is intended to primarily benefit users who upgrade their Racket
installations frequently.}
@defparam[LINKAGE-FILE file path-string?]{
The file to use as the first place PLaneT looks to determine how a
particular PLaneT dependence in a file should be satisfied. The
contents of this file are used to ensure that no "magic upgrades"
occur after a package is installed. The default is the file @filepath{LINKAGE}
in the root PLaneT directory.}
@defparam[LOG-FILE file (or/c path-string? false?)]{
If @racket[#f], indicates that no logging should take place. Otherwise
specifies the file into which logging should be written. The default
is the file @filepath{INSTALL-LOG} in the root PLaneT directory.}
@defboolparam[USE-HTTP-DOWNLOADS? bool]{
PLaneT can use two different protocols to retrieve packages. If @racket[#t],
PLaneT will use the HTTP protocol; if @racket[#f] it will use the custom-built
PLaneT protocol. The default value for this parameter is @racket[#t] and setting
this parameter to @racket[#f] is not recommended.}
@defparam[HTTP-DOWNLOAD-SERVLET-URL url string?]{
The URL for the servlet that will provide PLaneT packages if
@racket[USE-HTTP-DOWNLOADS?] is @racket[#t], represented as a string.
This defaults to the value of the @indexed-envvar{PLTPLANETURL} environment
variable if it is set and otherwise is
@racket["http://planet.racket-lang.org/servlets/planet-servlet.rkt"].}
@defparam[PLANET-SERVER-NAME host string?]{
The name of the PLaneT server to which the client should connect if
@racket[USE-HTTP-DOWNLOADS?] is @racket[#f]. The default value for this parameter is
@racket["planet.racket-lang.org"].}
@defparam[PLANET-SERVER-PORT port natural-number?]{
The port on the server the client should connect to if
@racket[USE-HTTP-DOWNLOADS?] is @racket[#f]. The default value for this parameter is
@racket[270].}
@defparam[HARD-LINK-FILE file path?]{
The name of the file where hard links are saved. Defaults to
@racket[(build-path (PLANET-BASE-DIR) (version) "HARD-LINKS")].
}
@defparam[PLANET-ARCHIVE-FILTER regexp-filter (or/c #f string? regexp?)]{
A regular-expression based filter that is used to skip files when building a @|PLaneT| archive.
}
@defparam[PLANET-CODE-VERSION vers string?]{
Used to compute @racket[PLANET-BASE-VERSION].
}
@defparam[DEFAULT-PACKAGE-LANGUAGE vers string?]{
The package language used when communicating with the server to find
which package to download.
Defaults to @racket[(version)].
}
@section{Package Archives}
@defmodule[planet/planet-archives]
@defproc[(get-all-planet-packages)
(listof (list/c (and/c path? absolute-path?) string? string? (listof string?)
exact-nonnegative-integer?
exact-nonnegative-integer?))]{
Returns the installed planet package. Each element of the result list corresponds to
a single package. The first element in an inner list is the location of the installed files.
The second and third elements are the owner and package names. The last two elements
are the major and minor verisons
}
@defproc[(get-installed-planet-archives)
(listof (list/c (and/c path? absolute-path?) string? string? (listof string?)
exact-nonnegative-integer?
exact-nonnegative-integer?))]{
Like @racket[get-all-planet-archives], except that it does not return packages linked in
with ``raco planet link''.
}
@defproc[(get-hard-linked-packages)
(listof (list/c (and/c path? absolute-path?) string? string? (listof string?)
exact-nonnegative-integer?
exact-nonnegative-integer?))]{
Like @racket[get-all-planet-archives], except that it return only packages linked in
with ``raco planet link''.
}
@section[#:tag "util.rkt"]{Package Utils}
@defmodule[planet/util]
The @racketmodname[planet/util] library supports examination of the pieces of
PLaneT. It is meant primarily to support debugging and to allow easier
development of higher-level package-management tools. The
functionality exposed by @seclink["cmdline"]{the @exec{raco planet} command-line tool} is
also available programmatically through this library.
@defproc[(download/install-pkg [owner string?]
[pkg (and/c string? #rx"[.]plt$")]
[maj natural-number/c]
[min natural-number/c])
(or/c pkg? #f)]{
Downloads and installs the package specifed by the given owner name,
package name, major and minor version number. Returns false if no such
package is available; otherwise returns a package structure for the
installed package.
The @racket[pkg] argument must end with @racket[".plt"].
}
@defproc[(install-pkg [pkg-spec pkg-spec?]
[file path-string?]
[maj natural-number/c]
[min natural-number/c])
(or/c pkg-spec? #f)]{
Installs the package represented by the arguments, using
the @racket[pkg-spec] argument to find the path and name of
the package to install.
See @racket[get-package-spec] to build a @racket[pkg-spec] argument.
Returns a new @racket[pkg-spec?] corresponding to the package
that was actually installed.
}
@defproc[(get-package-spec [owner string?]
[pkg (and/c string? #rx"[.]plt$")]
[maj (or/c #f natural-number/c) #f]
[min (or/c #f natural-number/c) #f])
pkg-spec?]{
Builds a @racket[pkg-spec?] corresponding to the package specified by
@racket[owner], @racket[pkg], @racket[maj], and @racket[min].
The @racket[pkg] argument must end with the string @racket[".plt"].
}
@defproc[(pkg-spec? [v any/c]) boolean?]{
Recognizes the result of @racket[get-package-spec] (and @racket[install-pkg]).
}
@defparam[current-cache-contents contents
(listof
(list/c string?
(listof
(list/c string?
(cons/c natural-number/c
(listof natural-number/c))))))]{
Holds a listing of all package names and versions installed in the
local cache.}
@defproc[(current-linkage)
(listof (list/c path-string?
(list/c string?
(list/c string?)
natural-number/c
natural-number/c)))]{
Returns the current linkage table.
The linkage table is an association between file locations (encoded as path strings)
and concrete planet package versions. If a require line in the associated file requests a package,
this table is consulted to determine a particular concrete package to satisfy the request.}
@defproc[(make-planet-archive [directory path-string?]
[output-file (or/c path? path-string?)
(string-append (path->string name) ".plt")])
path-string?]{
Makes a .plt archive file suitable for PLaneT whose contents are all
files in the given directory and returns that file's name. If the
optional filename argument is provided, that filename will be used as
the output file's name.
See also @racket[build-scribble-docs?] and @racket[force-package-building?]
}
@defparam[build-scribble-docs? b boolean?]{
Determines if @racket[make-planet-archive] builds scribble docs (or not).
}
@defparam[force-package-building? b boolean?]{
Determines if @racket[make-planet-archive] is more strict and thus aborts more often.
}
@defproc[(download-package [pkg-spec pkg-spec?])
(or/c (list/c #true path? natural-number/c natural-number/c)
string?
(list/c #false string?))]{
Downloads the package given by @racket[pkg-spec]. If the result is
a list whose first element is @racket[#true], then the package was
downloaded successfully and the rest of the elements of the list
indicate where it was downloaded, and the precise version number.
The other two possible results indicate errors. If the result is
a list, then the server is saying that there is no matching package;
otherwise the error is some lower-level problem (perhaps no networking, etc.)
}
@defproc[(pkg->download-url [pkg pkg?]) url?]{
Returns the url for a given package.
}
@defproc[(get-package-from-cache [pkg-spec pkg-spec?]) (or/c #false path?)]{
Returns the location of the already downloaded package,
if it exists (and @racket[#false] otherwise).
}
@defproc[(lookup-package-by-keys [owner string?]
[name string?]
[major exact-nonnegative-integer?]
[minor-lo exact-nonnegative-integer?]
[minor-hi exact-nonnegative-integer?])
(or/c (list/c path?
string?
string?
(listof string?)
exact-nonnegative-integer?
exact-nonnegative-integer?)
#false)]{
Looks up and returns a list representation of the package named by the given owner,
package name, major and (range of) minor version(s).
}
@defproc[(unpack-planet-archive [plt-file (or/c path? path-string?)]
[output-dir (or/c path? path-string?)])
any]{
Unpacks the PLaneT archive with the given filename, placing its contents
into the given directory (creating that path if necessary).}
@defproc[(remove-pkg [owner string?]
[pkg (and/c string? #rx"[.]plt$")]
[maj natural-number/c]
[min natural-number/c])
any]{
Removes the specified package from the local planet cache.
}
@defproc[(erase-pkg [owner string?]
[pkg (and/c string? #rx"[.]plt$")]
[maj natural-number/c]
[min natural-number/c])
any]{
Removes the specified package from the local planet cache and deletes
all of the files corresponding to the package.
}
@defproc[(display-plt-file-structure [plt-file (or/c path-string? path?)])
any]{
Print a tree representing the file and directory structure of the
PLaneT archive .plt file named by @racket[plt-file] to @racket[(current-output-port)].}
@defproc[(display-plt-archived-file [plt-file (or/c path-string? path?)]
[file-to-print string?])
any]{
Print the contents of the file named @racket[file-to-print] within the
PLaneT archive .plt file named by @racket[plt-file] to @racket[(current-output-port)].}
@defproc[(unlink-all) any]{
Removes the entire linkage table from the system, which will force all
modules to relink themselves to PLaneT modules the next time they run.}
@defproc[(add-hard-link [owner string?]
[pkg (and/c string? #rx"[.]plt$")]
[maj natural-number/c]
[min natural-number/c]
[dir path?])
any]{
Adds a development link between the specified package and the given
directory; once a link is established, PLaneT will treat the cache as
having a package with the given owner, name, and version whose files
are located in the given path. This is intended for package
development; users only interested in using PLaneT packages
available online should not need to create any development links.
If the specified package already has a development link, this function
first removes the old link and then adds the new one.
The @racket[pkg] argument must end with the string @racket[".plt"].
}
@defproc[(remove-hard-link [owner string?]
[pkg (and/c string? #rx"[.]plt$")]
[maj natural-number/c]
[min natural-number/c]
[#:quiet? quiet? boolean? #false])
any]{
Removes any hard link that may be associated with the given package.
The @racket[pkg] argument must end with the string @racket[".plt"].
The @racket[maj] and @racket[min] arguments must be integers. This
procedure signals an error if no such link exists, unless
@racket[#:quiet?] is @racket[#true].
}
@defproc[(resolve-planet-path [spec quoted-planet-require-spec?])
path?]{
Returns the file system path to the file specified by the given quoted
planet require specification. This function downloads and installs the
specified package if necessary, but does not verify that the actual
file within it actually exists.}
@defproc[(path->package-version [p path?])
(or/c (list/c string? string? natural-number/c natural-number/c) #f)]{
Given a path that corresponds to a PLaneT package (or some part of one),
produces a list corresponding to its name and version, exactly like
@racket[(this-package-version)]. Given any other path, produces @racket[#f].
}
@defstruct[(exn:fail:planet exn:fail) ([message string?] [continuation-marks continuation-mark-set?])]{
This exception record is used to report planet-specific exceptions.
}
@defproc[(pkg? [v any/c]) boolean?]{
Determines if its argument is a pkg, the representation of an installed package.
}
@section[#:tag "version.rkt"]{Package Version}
Provides bindings for @|PLaneT| developers that automatically
produce references to the name and version of the containing @|PLaneT| package
so the same code may be reused across releases without accidentally referring to
a different version of the same package.
@defmodule[planet/version #:use-sources (planet/private/version)]
@deftogether[(
@defform[(this-package-version)]
@defform*[[(this-package-version-symbol)
(this-package-version-symbol suffix-id)]]
@defform[(this-package-version-name)]
@defform[(this-package-version-owner)]
@defform[(this-package-version-maj)]
@defform[(this-package-version-min)]
)]{
Macros that expand into expressions that evaluate to information about the name,
owner, and version number of the package in which they
appear. @racket[this-package-version] returns a list consisting of a string
naming the package's owner, a string naming the package, a number indicating the
package major version and a number indicating the package minor version, or
@racket[#f] if the expression appears outside the context of a package.
The macros @racket[this-package-version-name],
@racket[this-package-version-owner], @racket[this-package-version-maj], and
@racket[this-package-version-min] produce the relevant fields of the package
version list.
@racket[this-package-version-symbol] produces a symbol
suitable for use in @racket[planet] module paths. For instance, in version
@racketmodfont{1:0} of the package @racketmodfont{package.plt} owned by
@racketmodfont{author}, @racket[(this-package-version-symbol dir/file)] produces
@racket['author/package:1:0/dir/file]. In the same package,
@racket[(this-package-version-symbol)] produces @racket['author/package:1:0].
}
@defform[(this-package-in suffix-id ...)]{
A @racket[require] sub-form that requires modules from within the same @|PLaneT|
package version as the require, as referred to by each @racket[suffix-id]. For
instance, in version @racketmodfont{1:0} of the package
@racketmodfont{package.plt} owned by @racketmodfont{author},
@racket[(require (this-package-in dir/file))] is equivalent to
@racket[(require (planet author/package:1:0/dir/file))].
@italic{Note:} Use @racket[this-package-in] when documenting @|PLaneT| packages
with Scribble to associate each documented binding with the appropriate package.
}
@defproc[(make-planet-symbol [stx syntax?]
[suffix (or/c #false string?) #false])
(or/c #false symbol?)]{
Returns a symbol representing a require spec for the location of @racket[stx],
as a planet package.
}
@defproc[(package-version->symbol [ver (or/c (list/c string? string? exact-nonnegative-integer? exact-nonnegative-integer?)
#false)]
[suffix (or/c #false string?) #false])
(or/c #false symbol?)]{
Returns a symbol representing the require spec for @racket[ver],
as a planet package.
}
@section[#:tag "syntax.rkt"]{Macros and Syntax Objects}
@defmodule[planet/syntax]
Provides bindings useful for @|PLaneT|-based macros.
@deftogether[(
@defproc[(syntax-source-planet-package [stx syntax?]) (or/c list? #f)]
@defproc[(syntax-source-planet-package-owner [stx syntax?]) (or/c string? #f)]
@defproc[(syntax-source-planet-package-name [stx syntax?]) (or/c string? #f)]
@defproc[(syntax-source-planet-package-major [stx syntax?]) (or/c integer? #f)]
@defproc[(syntax-source-planet-package-minor [stx syntax?]) (or/c integer? #f)]
@defproc[(syntax-source-planet-package-symbol
[stx syntax?]
[suffix (or/c symbol? #f) #f])
(or/c symbol? #f)]
)]{
Produce output analogous to @racket[this-package-version],
@racket[this-package-version-owner], @racket[this-package-version-name],
@racket[this-package-version-maj], @racket[this-package-version-min], and
@racket[this-package-version-symbol] based on the source location of
@racket[stx].
}
@defproc[(make-planet-require-spec
[stx syntax?]
[suffix (or/c symbol? #f) #f])
syntax?]{
Produces a @racket[require] sub-form for the module referred to by
@racket[suffix] in the @|PLaneT| package containing the source location of
@racket[stx].
}
@section[#:tag "scribble.rkt"]{Scribble Documentation}
@defmodule[planet/scribble]
Provides bindings for documenting @|PLaneT| packages.
@defform[(this-package-in suffix-id ...)]{
This binding from @racketmodname[planet/version] is also exported from
@racketmodname[planet/scribble], as it is useful for @racket[for-label] imports
in Scribble documentation.
}
@deftogether[(
@defform[(racketmod/this-package maybe-file suffix-id datum ...)]
@defform*[((racketmodname/this-package suffix-id)
(racketmodname/this-package (#,(racket unsyntax) suffix-expr)))]
@defform[(racketmodlink/this-package suffix-id pre-content-expr ...)]
@defform[(defmodule/this-package maybe-req suffix-id maybe-sources pre-flow ...)]
@defform*[((defmodulelang/this-package suffix-id maybe-sources pre-flow ...)
(defmodulelang/this-package suffix-id
#:module-paths (mod-suffix-id ...) maybe-sources
pre-flow ...))]
@defform[(defmodulereader/this-package suffix-id maybe-sources pre-flow ...)]
@defform[(defmodule*/this-package maybe-req (suffix-id ...+)
maybe-sources pre-flow ...)]
@defform*[((defmodulelang*/this-package (suffix-id ...+)
maybe-sources pre-flow ...)
(defmodulelang*/this-package (suffix-id ...+)
#:module-paths (mod-suffix-id ...) maybe-sources
pre-flow ...))]
@defform[(defmodulereader*/this-package (suffix-id ...+)
maybe-sources pre-flow ...)]
@defform[(defmodule*/no-declare/this-package maybe-req (suffix-id ...+)
maybe-sources pre-flow ...)]
@defform*[((defmodulelang*/no-declare/this-package (suffix-id ...+)
maybe-sources pre-flow ...)
(defmodulelang*/no-declare/this-package (suffix-id ...+)
#:module-paths (mod-suffix-id ...) maybe-sources pre-flow ...))]
@defform[(defmodulereader*/no-declare/this-package (suffix-id ...+)
maybe-sources pre-flow ...)]
@defform[(declare-exporting/this-package suffix-id ... maybe-sources)]
)]{
Variants of @racket[racketmod], @racket[racketmodname],
@racket[racketmodlink], @racket[defmodule], @racket[defmodulereader],
@racket[defmodulelang], @racket[defmodule*], @racket[defmodulelang*],
@racket[defmodulereader*], @racket[defmodule*/no-declare],
@racket[defmodulelang*/no-declare],
@racket[defmodulereader*/no-declare], and @racket[declare-exporting],
respectively, that implicitly refer to the PLaneT package that
contains the enclosing module.
The full module name passed to @racket[defmodule], etc is formed by
appending the @racket[suffix-id] or @racket[mod-suffix-id] to the
symbol returned by @racket[(this-package-version-symbol)], separated
by a @litchar{/} character, and tagging the resulting symbol as a
@racket[planet] module path. As a special case, if @racket[suffix-id]
is @racketid[main], the suffix is omitted.
For example, within a package named @tt{package.plt} by @tt{author},
version @tt{1:0}, the following are equivalent:
@racketblock[
(defmodule/this-package dir/file)
@#,elem{=} (defmodule (planet author/package:1:0/dir/file))
]
and
@racketblock[
(defmodule/this-package main)
@#,elem{=} (defmodule (planet author/package:1:0))
]
}
@section{Terse Status Updates}
@defmodule[planet/terse-info]
This module provides access to some PLaneT status information. This
module is first loaded by PLaneT in the initial namespace (when
PLaneT's resolver is loaded), but PLaneT uses @racket[dynamic-require] to load
this module each time it wants to announce information. Similarly, the
state of which procedures are registered (via @racket[planet-terse-register])
is saved in the namespace, making the listening and information producing
namespace-specific.
@defproc[(planet-terse-register
[proc (-> (or/c 'download 'install 'docs-build 'finish)
string?
any/c)])
void?]{
Registers @racket[proc] as a function to be called when
@racket[planet-terse-log] is called.
Note that @racket[proc] is called
asynchronously (ie, on some thread other than the one calling @racket[planet-terse-register]).
}
@defproc[(planet-terse-log [id (or/c 'download 'install 'finish)]
[msg string?]) void?]{
This function is called by PLaneT to announce when things are happening. See also
@racket[planet-terse-set-key].
}
@defproc[(planet-terse-set-key [key any/c]) void?]{
This sets a @seclink["threadcells" #:doc '(lib "scribblings/reference/reference.scrbl")]{thread cell}
to the value of @racket[key].
The value of the thread cell is used as an index into a table to determine which
of the functions passed to @racket[planet-terse-register] to call when
@racket[planet-terse-log] is called.
The table holding the key uses ephemerons and a weak hash table to ensure that
when the @racket[key] is unreachable, then the procedures passed to @racket[planet-terse-log]
cannot be reached through the table.
}
@section{The Cache File's Path}
@defmodule[planet/cachepath]
@defproc[(get-planet-cache-path) (and/c path? absolute-path?)]{
Returns the path to the @filepath{cache.rktd} file for the planet installation.
}

103
collects/planet/private/version.rkt Normal file
View File

@ -0,0 +1,103 @@
#lang racket
(require (for-syntax syntax/parse)
unstable/syntax
racket/syntax
"../planet-archives.rkt")
(provide this-package-version
this-package-version-name
this-package-version-owner
this-package-version-maj
this-package-version-min
this-package-version-symbol
package-version->symbol
make-planet-symbol
(rename-out [this-package-version/proc path->package-version]))
(define-syntax (this-package-version stx)
(syntax-case stx ()
[(_)
#`(this-package-version/proc
(this-expression-source-directory #,stx))]))
(define-syntax define-getters
(syntax-rules ()
[(define-getters (name position) ...)
(begin
(define-syntax (name stx)
(syntax-case stx ()
[(name)
#`(let ([p #,(datum->syntax stx `(,#'this-package-version))])
(and p (position p)))]))
...)]))
(define-getters
(this-package-version-name pd->name)
(this-package-version-owner pd->owner)
(this-package-version-maj pd->maj)
(this-package-version-min pd->min))
(define-syntax (this-package-version-symbol stx)
(syntax-parse stx
[(_ (~optional suffix:id))
#`(package-version->symbol
(this-package-version/proc
(this-expression-source-directory #,stx))
#,@(if (attribute suffix) #'['suffix] #'[]))]))
;; ----------------------------------------
(define (make-planet-symbol stx [suffix #f])
(match (syntax-source-directory stx)
[#f #f]
[dir (match (this-package-version/proc dir)
[#f #f]
[ver (package-version->symbol ver suffix)])]))
(define (package-version->symbol ver [suffix #f])
(match ver
[(list owner name major minor)
(string->symbol
(format "~a/~a:~a:~a~a"
owner
(regexp-replace #rx"\\.plt$" name "")
major
minor
(if suffix (format-symbol "/~a" suffix) "")))]
[#f #f]))
(define (this-package-version/proc srcdir)
(define (archive-retval->simple-retval p)
(list-refs p '(1 2 4 5)))
;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X)
(define (predicate->projection pred) (λ (x) (if (pred x) x #f)))
(let* ([package-roots (get-all-planet-packages)]
[thepkg (ormap (predicate->projection (contains-dir? srcdir))
package-roots)])
(and thepkg (archive-retval->simple-retval thepkg))))
;; contains-dir? : path -> pkg -> boolean
(define ((contains-dir? srcdir) alleged-superdir-pkg)
(let* ([nsrcdir (simple-form-path srcdir)]
[nsuperdir (simple-form-path (car alleged-superdir-pkg))]
[nsrclist (explode-path nsrcdir)]
[nsuperlist (explode-path nsuperdir)])
(list-prefix? nsuperlist nsrclist)))
(define (list-prefix? sup sub)
(let loop ([sub sub]
[sup sup])
(cond
[(null? sup) #t]
[(equal? (car sup) (car sub))
(loop (cdr sub) (cdr sup))]
[else #f])))
(define-values (pd->owner pd->name pd->maj pd->min)
(apply values (map (λ (n) (λ (l) (list-ref l n))) '(0 1 2 3))))
(define (list-refs p ns)
(map (λ (n) (list-ref p n)) ns))

823
collects/planet/resolver.rkt
View File

@ -1,820 +1,7 @@
#lang mzscheme
#| resolver.rkt -- PLaneT client
1. Introduction
The PLaneT system is a method for automatically sharing code packages, both as
libraries and as full applications, that gives every user of a PLaneT client
the illusion of having a local copy of every code package on the server, but is
parsimonious in its transmission. It consists of a centralized server that
holds all packages and individual clients that hold some portion of the archive
locally. Maintenance of that archive should be transparent, and is the complete
responsibility of the PLaneT client.
2. Client behavior
The PLaneT client receives user requests (i.e., the "(require (planet ...))"
forms) and loads the appropriate modules in response. In the course of handling
these requests it may download new code packages from the PLaneT server.
2.1 User interface
The structure of user PLaneT invocations is listed below.
PLANET-REQUEST ::= (planet FILE-NAME PKG-SPEC [PATH ...]?)
FILE-NAME ::= string
PKG-SPEC ::= string | (FILE-PATH ... PKG-NAME)
| (FILE-PATH ... PKG-NAME VER-SPEC)
VER-SPEC ::= Nat | (Nat MINOR)
MINOR ::= Nat | (Nat Nat) | (= Nat) | (+ Nat) | (- Nat)
FILE-PATH ::= string
PKG-NAME ::= string
OWNER-NAME ::= string
PATH ::= string
All strings must be legal filename strings.
When encountered, a planet-request is interpreted as requiring the given file
name from the given logical package, specified by the package spec and the
collection specification, if given. If no VER-SPEC is provided, the most recent
version is assumed. If no owner-name/path ... clause is provided, the default
package is assumed.
2. PLaneT protocol
PLaneT clients support two protocols for communicating with the PLaneT server:
the standard HTTP GET/response system (currently the default) and a specialized
TCP-based protocol that may become more important if PLaneT becomes smarter
about downloading packages behind the scenes.
In the following sections we describe the specialized protocol only.
2.1 Overview
1. PLaneT client establishes TCP connection to PLaneT server.
2. Client transmits a version specifier.
3. Server either refuses that version and closes connection or accepts.
4. Client transmits a sequence of requests terminated by a special
end-of-request marker. Simultaneously, server transmits responses to those
requests.
5. Once the server has handled every request, it closes the connection.
I am concerned about the overhead of opening and closing TCP connections for a
large program with many requires, so I want to allow many requests and
responses over the same connection. Unfortunately there's a wrinkle: the
standard client, implemented the obvious way, would be unable to send more than
one request at a time because it gets invoked purely as a response to a require
form and must load an appropriate file before it returns. This means I can't
batch up multiple requires, at least not with an obvious implementation.
A possible solution would be to implement an install program that walks over
the syntax tree of a program and gathers all requires, then communicates with
the server and learns what additional packages would be necessary due to those
requires, and then downloads all of them at once. We would have to implement
both methods simultaneously, though, to allow for REPL-based PLaneT use and
dynamic-require (unless we want it to be a runtime exception to use PLaneT from
the REPL or via dynamic-require, something I'd rather not do), so I want a
protocol that will allow both forms of access easily. This protocol does that,
and doesn't require too much additional overhead in the case that the client
only takes one package at a time.
2.2 Communication Details
After a TCP connection is established, the client transmits a
VERSION-SPECIFIER:
VERSION-SPECIFIER ::= "PLaneT/1.0\n"
The server responds with a VERSION-RESPONSE:
VERSION-RESPONSE ::=
| 'ok "\n"
| ('invalid string) "\n"
where the string in the invalid case is descriptive text intended for display
to the user that may indicate some specific message about the nature of the
error.
If the server sends 'invalid, the server closes the connection. Otherwise, the
client may send any number of requests, followed by an end-of-request marker:
REQUESTS ::= { REQUEST "\n"}* 'end "\n"
REQUEST ::= (SEQ-NO 'get PKG-LANG PKG-NAME (Nat | #f) (Nat | #f) (Nat | #f)
[OWNER-NAME PATH ...]?)
PKG-LANG ::= String
SEQ-NO ::= Nat
The fields in a request are a uniquely identifying sequence number, the literal
symbol 'get, the name of the package to receive, the required major version and
the lowest and highest acceptable version (with #f meaning that there is no
constraint for that field, and a #f in major-version field implying that both
other fields must also be #f), and the package path.
As the client is transmitting a REQUESTS sequence, the server begins responding
to it with RESPONSE structures, each with a sequence number indicating to which
request it is responding (except in the case of input too garbled to extract a
sequence number):
RESPONSE ::=
| ('error 'malformed-input string) "\n"
| (SEQ-NO 'error 'malformed-request string) "\n"
| (SEQ-NO 'bad-language string) "\n"
| (SEQ-NO 'get 'ok Nat Nat Nat) "\n" BYTE-DATA
| (SEQ-NO 'get 'error ERROR-CODE string) "\n"
ERROR-CODE ::= 'not-found
If the server receives a malformed request, it may close connection after
sending a malformed-request response without processing any other
requests. Otherwise it must process all requests even in the event of an
error. On a successful get, the three numbers the server returns are the
matched package's major version, the matched package's minor version, and the
number of bytes in the package.
3 Client Download Policies
Racket invokes the PLaneT client once for each instance of a require-planet
form in a program being run (i.e., the transitive closure of the "requires"
relation starting from some specified root module; this closure is calculable
statically). At each of these invocations, the client examines its internal
cache to see if an appropriate module exists that matches the specification
given by the user (for details see the next section). If one does, the client
loads that module and returns. If none does, it initiates a transaction with
the server using the PLaneT protocol described in the previous subsection and
sends a single request consisting of the user's request. It installs the
resulting .plt file and then loads the appropriate file.
The client keeps a cache of downloaded packages locally. It does so in the
$PLTCOLLECTS/planet/cache/ directory and subdirectories, in an intuitive
manner: each item in the package's path in the PLaneT require line correspond
to a subdirectory in the cache directory, starting with the owner name. (They
should be unpacked relative to some user-specific rather than
installation-specific place, possibly, but that's difficult to do so we won't
do it yet).
To check whether a package is installed when attempting to satisfy a
requirement, the client checks its cache to see if an appropriate entry exists
in its link-table for that require line. If one exists, it uses the named
package directly. If none exists, it checks to see if there is an appropriate
subdirectory.
||#
;; This `resolver' no longer fits the normal protocol for a
;; module name resolver, because it accepts an extra argument in
;; the second and third cases. The extra argument is a parameterization
;; to use for installation actions.
(define resolver
(case-lambda
[(name) (void)]
[(spec module-path stx orig-paramz)
(resolver spec module-path stx #t orig-paramz)]
[(spec module-path stx load? orig-paramz)
;; ensure these directories exist
(make-directory* (PLANET-DIR))
(make-directory* (CACHE-DIR))
(establish-diamond-property-monitor)
(planet-resolve spec
(current-module-declare-name) ;; seems more reliable than module-path in v3.99
stx
load?
orig-paramz)]))
(require mzlib/match
mzlib/file
mzlib/port
mzlib/list
mzlib/date
net/url
net/head
mzlib/struct
"config.rkt"
"private/planet-shared.rkt"
"private/linkage.rkt"
"parsereq.rkt"
"terse-info.rkt"
compiler/cm)
(provide (rename resolver planet-module-name-resolver)
#lang racket/base
(require "private/resolver.rkt")
(provide planet-module-name-resolver
resolve-planet-path
pkg-spec->full-pkg-spec
get-package-from-cache
get-package-from-server
download-package
pkg->download-url
pkg-promise->pkg
install-pkg
get-planet-module-path/pkg
install?
download?
install?
exn:fail:planet?
make-exn:fail:planet)
;; if #f, will not install packages and instead raise a exn:fail:install? error
(define install? (make-parameter #t))
;; if #f, will not download packages and instead raise a exn:fail:install? error
(define download? (make-parameter #t))
(define-struct (exn:fail:planet exn:fail) ())
;; update doc index only once for a set of installs:
(define planet-nested-install (make-parameter #f))
;; =============================================================================
;; DIAMOND PROPERTY STUFF
;; make sure a module isn't loaded twice with two different versions
;; =============================================================================
(define VER-CACHE-NAME #f)
(define (establish-diamond-property-monitor)
(unless VER-CACHE-NAME (set! VER-CACHE-NAME (gensym)))
(unless (namespace-variable-value VER-CACHE-NAME #t (lambda () #f))
(namespace-set-variable-value! VER-CACHE-NAME (make-hash-table 'equal))))
(define (the-version-cache) (namespace-variable-value VER-CACHE-NAME))
(define (pkg->diamond-key pkg) (cons (pkg-name pkg) (pkg-route pkg)))
(define (pkg-matches-bounds? pkg bound-info)
(match-let ([(maj lo hi) bound-info])
(and (= maj (pkg-maj pkg))
(or (not lo) (>= (pkg-min pkg) lo))
(or (not hi) (<= (pkg-min pkg) hi)))))
;; COMPAT ::= 'none | 'all | `(all-except ,VER-SPEC ...) | `(only ,VER-SPEC ...)
;; build-compatibility-fn : COMPAT -> PKG -> bool
(define (build-compatibility-fn compat-data)
(define pre-fn
(match compat-data
[`none (lambda (_) #f)]
[`all (lambda (_) #t)]
[`(all-except ,vspec ...)
(let ([bounders (map (λ (x) (version->bounds x (λ (_) #f))) vspec)])
(if (andmap (lambda (x) x) bounders)
(lambda (v)
(not (ormap (lambda (bounder) (pkg-matches-bounds? v bounder))
bounders)))
#f))]
[`(only ,vspec ...)
(let ([bounders (map (λ (x) (version->bounds x (λ (_) #f))) vspec)])
(if (andmap (lambda (x) x) bounders)
(lambda (v)
(andmap (lambda (bounder) (pkg-matches-bounds? v bounder))
bounders)))
#f)]
[_ #f]))
(or pre-fn (lambda (x) #f)))
;; can-be-loaded-together? : pkg pkg -> boolean
;; side constraint: pkg1 and pkg2 are versions of the same package assumption:
;; pkg1 and pkg2 are versions of the same package determines if the two
;; versions are side-by-side compatible
(define (can-be-loaded-together? pkg1 pkg2)
(cond [(pkg> pkg1 pkg2) (can-be-loaded-together? pkg2 pkg1)]
[(pkg= pkg1 pkg2) #t]
[(pkg< pkg1 pkg2)
(let* ([info (pkg->info pkg2)]
[compat? (build-compatibility-fn
(info 'can-be-loaded-with (lambda () 'none)))])
(compat? pkg1))]))
;; stx->origin-string : stx option -> string
;; returns a description [e.g. file name, line#] of the given syntax
(define (stx->origin-string stx)
(if stx (format "~a" (syntax-source stx)) "[unknown]"))
(define (add-pkg-to-diamond-registry! pkg stx)
(let ([loaded-packages
(hash-table-get (the-version-cache) (pkg->diamond-key pkg) '())])
(unless (list? loaded-packages)
(error 'PLaneT "Inconsistent state: expected loaded-packages to be a list, received: ~s" loaded-packages))
(let ([all-violations '()])
(for-each
(lambda (already-loaded-pkg-record)
(let* ([already-loaded-pkg (car already-loaded-pkg-record)]
[prior-stx (cadr already-loaded-pkg-record)]
[prior-stx-origin-string (stx->origin-string prior-stx)])
(unless (can-be-loaded-together? pkg already-loaded-pkg)
(set!
all-violations
(cons
(list
stx
(make-exn:fail
(format
"Package ~a loaded twice with multiple incompatible versions:
~a attempted to load version ~a.~a while version ~a.~a was already loaded by ~a"
(pkg-name pkg)
(stx->origin-string stx)
(pkg-maj pkg)
(pkg-min pkg)
(pkg-maj already-loaded-pkg)
(pkg-min already-loaded-pkg)
prior-stx-origin-string)
(current-continuation-marks)))
all-violations)))))
loaded-packages)
(unless (null? all-violations)
(let ([worst (or (assq values all-violations) (car all-violations))])
(raise (cadr worst)))))
(hash-table-put! (the-version-cache)
(pkg->diamond-key pkg)
(cons (list pkg stx) loaded-packages))))
;; =============================================================================
;; MAIN LOGIC
;; Handles the overall functioning of the resolver
;; =============================================================================
;; planet-resolve : PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> symbol
;; resolves the given request. Returns a name corresponding to the module in
;; the correct environment
(define (planet-resolve spec rmp stx load? orig-paramz)
;; install various parameters that can affect the compilation of a planet package back to their original state
(parameterize ([current-compile (call-with-parameterization orig-paramz current-compile)]
[current-eval (call-with-parameterization orig-paramz current-eval)]
[use-compiled-file-paths (call-with-parameterization orig-paramz use-compiled-file-paths)]
[current-library-collection-paths (call-with-parameterization orig-paramz current-library-collection-paths)])
(let-values ([(path pkg) (get-planet-module-path/pkg spec rmp stx)])
(when load? (add-pkg-to-diamond-registry! pkg stx))
(do-require path (pkg-path pkg) rmp stx load?))))
;; resolve-planet-path : planet-require-spec -> path
;; retrieves the path to the given file in the planet package. downloads and
;; installs the package if necessary
(define (resolve-planet-path spec)
(let-values ([(path pkg) (get-planet-module-path/pkg spec #f #f)])
path))
;; get-planet-module-path/pkg :PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG)
;; returns the matching package and the file path to the specific request
(define (get-planet-module-path/pkg spec rmp stx)
(request->pkg (spec->req spec stx) rmp stx))
;; request->pkg : request (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG)
(define (request->pkg req rmp stx)
(let* ([result (get-package rmp (request-full-pkg-spec req))])
(cond [(string? result)
(raise-syntax-error 'require result stx)]
[(pkg? result)
(values (apply build-path (pkg-path result)
(append (request-path req) (list (request-file req))))
result)])))
;; PKG-GETTER ::= module-path pspec
;; (pkg -> A)
;; ((uninstalled-pkg -> void)
;; (pkg -> void)
;; ((string | #f) -> string | #f) -> A)
;; -> A
;;
;; a pkg-getter is a function that tries to fetch a package; it is written in a
;; quasi-cps style; the first argument is what it calls to succeed, and the
;; second argument is what it calls when it fails. In the second case, it must
;; provide two things: a function to take action if a match is found
;; eventually, and a function that gets to mess with the error message if the
;; entire message eventually fails.
;; get-package : (resolved-module-path | #f) FULL-PKG-SPEC -> (PKG | string)
;; gets the package specified by pspec requested by the module in the given
;; module path, or returns a descriptive error message string if that's not
;; possible
(define (get-package rmp pspec)
(let loop ([getters (*package-search-chain*)]
[pre-install-updaters '()]
[post-install-updaters '()]
[error-reporters '()])
(if (null? getters)
;; we have failed to fetch the package, generate an appropriate error
;; message and bail
(let ([msg (foldl (λ (f str) (f str)) #f error-reporters)])
(or msg (format "Could not find package matching ~s"
(list (pkg-spec-name pspec)
(pkg-spec-maj pspec)
(list (pkg-spec-minor-lo pspec)
(pkg-spec-minor-hi pspec))
(pkg-spec-path pspec)))))
;; try the next error reporter. recursive call is in the failure
;; continuation
((car getters)
rmp
pspec
(λ (pkg)
(when (uninstalled-pkg? pkg)
(for-each (λ (u) (u pkg)) pre-install-updaters))
(let ([installed-pkg (pkg-promise->pkg pkg)])
(for-each (λ (u) (u installed-pkg)) post-install-updaters)
installed-pkg))
(λ (pre-updater post-updater error-reporter)
(loop (cdr getters)
(cons pre-updater pre-install-updaters)
(cons post-updater post-install-updaters)
(cons error-reporter error-reporters)))))))
;; =============================================================================
;; PHASE 2: CACHE SEARCH
;; If there's no linkage, there might still be an appropriate cached module
;; (either installed or uninstalled)
;; =============================================================================
;; get/installed-cache : pkg-getter
(define (get/installed-cache _ pkg-spec success-k failure-k)
(let ([p (lookup-package pkg-spec)])
(if p (success-k p) (failure-k void void (λ (x) x)))))
;; get-package-from-cache : FULL-PKG-SPEC -> PKG | #f
(define (get-package-from-cache pkg-spec)
(lookup-package pkg-spec))
;; get/uninstalled-cache-dummy : pkg-getter
;; always fails, but records the package to the uninstalled package cache upon
;; the success of some other getter later in the chain.
(define (get/uninstalled-cache-dummy _ pkg-spec success-k failure-k)
(failure-k save-to-uninstalled-pkg-cache! void (λ (x) x)))
;; get/uninstalled-cache : pkg-getter
;; note: this does not yet work with minimum-required-version specifiers if you
;; install a package and then use an older mzscheme
(define (get/uninstalled-cache _ pkg-spec success-k failure-k)
(let ([p (lookup-package pkg-spec (UNINSTALLED-PACKAGE-CACHE))])
(if (and p (file-exists? (build-path (pkg-path p)
(pkg-spec-name pkg-spec))))
(begin
(planet-log "found local, uninstalled copy of package at ~a"
(build-path (pkg-path p)
(pkg-spec-name pkg-spec)))
(success-k
;; note: it's a little sloppy that lookup-pkg returns PKG structures,
;; since it doesn't actually know whether or not the package is
;; installed. hence I have to convert what appears to be an installed
;; package into an uninstalled package
(make-uninstalled-pkg (build-path (pkg-path p) (pkg-spec-name pkg-spec))
pkg-spec
(pkg-maj p)
(pkg-min p))))
(failure-k void void (λ (x) x)))))
;; save-to-uninstalled-pkg-cache! : uninstalled-pkg -> path[file]
;; copies the given uninstalled package into the uninstalled-package cache,
;; replacing any old file that might be there. Returns the path it copied the
;; file into.
(define (save-to-uninstalled-pkg-cache! uninst-p)
(let* ([pspec (uninstalled-pkg-spec uninst-p)]
[owner (car (pkg-spec-path pspec))]
[name (pkg-spec-name pspec)]
[maj (uninstalled-pkg-maj uninst-p)]
[min (uninstalled-pkg-min uninst-p)]
[dir (build-path (UNINSTALLED-PACKAGE-CACHE)
owner
name
(number->string maj)
(number->string min))]
[full-pkg-path (build-path dir name)])
(make-directory* dir)
(unless (equal? (normalize-path (uninstalled-pkg-path uninst-p))
(normalize-path full-pkg-path))
(when (file-exists? full-pkg-path) (delete-file full-pkg-path))
(copy-file (uninstalled-pkg-path uninst-p) full-pkg-path))
full-pkg-path))
;; =============================================================================
;; PHASE 3: SERVER RETRIEVAL
;; Ask the PLaneT server for an appropriate package if we don't have one
;; locally.
;; =============================================================================
(define (get/server _ pkg-spec success-k failure-k)
(let ([p (get-package-from-server pkg-spec)])
(cond
[(pkg-promise? p) (success-k p)]
[(string? p)
;; replace any existing error message with the server download error
;; message
(planet-log p)
(failure-k void void (λ (_) p))])))
;; get-package-from-server : FULL-PKG-SPEC -> PKG-PROMISE | #f | string[error message]
;; downloads the given package file from the PLaneT server and installs it in
;; the uninstalled-packages cache, then returns a promise for it
(define (get-package-from-server pkg)
(match (download-package pkg)
[(#t tmpfile-path maj min)
(let* ([upkg (make-uninstalled-pkg tmpfile-path pkg maj min)]
[cached-path (save-to-uninstalled-pkg-cache! upkg)]
[final (make-uninstalled-pkg cached-path pkg maj min)])
(unless (equal? (normalize-path tmpfile-path)
(normalize-path cached-path))
(delete-file tmpfile-path)) ;; remove the tmp file, we're done with it
final)]
[(#f str)
(string-append "PLaneT could not find the requested package: " str)]
[(? string? s)
(string-append "PLaneT could not download the requested package: " s)]))
(define (download-package pkg)
(unless (download?)
(raise (make-exn:fail:planet
(format
"PLaneT error: cannot download package ~s since the download? parameter is set to #f"
(list (car (pkg-spec-path pkg)) (pkg-spec-name pkg)))
(current-continuation-marks))))
((if (USE-HTTP-DOWNLOADS?) download-package/http download-package/planet)
pkg))
(define (current-time)
(let ([date (seconds->date (current-seconds))])
(parameterize ([date-display-format 'rfc2822])
(format "~a ~a:~a:~a"
(date->string date)
(date-hour date)
(date-minute date)
(date-second date)))))
;; pkg-promise->pkg : pkg-promise -> pkg
;; "forces" the given pkg-promise (i.e., installs the package if it isn't
;; installed yet)
(define (pkg-promise->pkg p)
(cond [(pkg? p) p]
[(uninstalled-pkg? p)
(install-pkg (uninstalled-pkg-spec p)
(uninstalled-pkg-path p)
(uninstalled-pkg-maj p)
(uninstalled-pkg-min p))]))
;; install-pkg : FULL-PKG-SPEC path[file] Nat Nat -> PKG
;; install the given pkg to the planet cache and return a PKG representing the
;; installed file
(define (install-pkg pkg path maj min)
(let ([pkg-path (pkg-spec-path pkg)]
[pkg-name (pkg-spec-name pkg)]
[pkg-string (pkg-spec->string pkg)])
(unless (install?)
(raise (make-exn:fail:planet
(format
"PLaneT error: cannot install package ~s since the install? parameter is set to #f"
(list (car pkg-path) pkg-name maj min))
(current-continuation-marks))))
(let* ([owner (car pkg-path)]
[extra-path (cdr pkg-path)]
[the-dir
(apply build-path (CACHE-DIR)
(append pkg-path (list pkg-name
(number->string maj)
(number->string min))))]
[was-nested? (planet-nested-install)])
(if (directory-exists? the-dir)
(raise (make-exn:fail
"PLaneT error: trying to install already-installed package"
(current-continuation-marks)))
(parameterize ([planet-nested-install #t])
(planet-terse-log 'install pkg-string)
(with-logging
(LOG-FILE)
(lambda ()
(printf "\n============= Installing ~a on ~a =============\n"
pkg-name
(current-time))
;; oh man is this a bad hack!
(parameterize ([current-namespace (make-namespace)])
(let ([ipp (dynamic-require 'setup/plt-single-installer
'install-planet-package)]
[rud (dynamic-require 'setup/plt-single-installer
'reindex-user-documentation)]
[msfh (dynamic-require 'compiler/cm 'manager-skip-file-handler)])
(parameterize ([msfh (manager-skip-file-handler)]
[use-compiled-file-paths (list (string->path "compiled"))])
(ipp path the-dir (list owner pkg-name
extra-path maj min))
(unless was-nested?
(planet-terse-log 'docs-build pkg-string)
(printf "------------- Rebuilding documentation index -------------\n")
(rud)))))))
(planet-terse-log 'finish pkg-string)
(make-pkg pkg-name pkg-path
maj min the-dir 'normal))))))
;; download-package : FULL-PKG-SPEC -> RESPONSE
;; RESPONSE ::= (list #f string) | (list #t path[file] Nat Nat)
;; downloads the given package and returns (list bool string): if bool is #t,
;; the path is to a file that contains the package. If bool is #f, the package
;; didn't exist and the string is the server's informative message.
;; raises an exception if some protocol failure occurs in the download process
(define (download-package/planet pkg)
(define stupid-internal-define-syntax
(let ([msg (format "downloading ~a from ~a via planet protocol"
(pkg-spec->string pkg)
(PLANET-SERVER-NAME))])
(planet-terse-log 'download (pkg-spec->string pkg))
(planet-log msg)))
(define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT)))
(define (close-ports) (close-input-port ip) (close-output-port op))
(define (request-pkg-list pkgs)
(for-each/n (lambda (pkg seqno)
(write-line (list* seqno 'get
(DEFAULT-PACKAGE-LANGUAGE)
(pkg-spec-name pkg)
(pkg-spec-maj pkg)
(pkg-spec-minor-lo pkg)
(pkg-spec-minor-hi pkg)
(pkg-spec-path pkg))
op))
pkgs)
(write-line 'end op)
(flush-output op))
(define (state:initialize)
(fprintf op "PLaneT/1.0\n")
(flush-output op)
(match (read ip)
['ok (state:send-pkg-request)]
[('invalid (? string? msg)) (state:abort (string-append "protocol version error: " msg))]
[bad-msg (state:abort (format "server protocol error (received invalid response): ~a" bad-msg))]))
(define (state:send-pkg-request)
(request-pkg-list (list pkg))
(state:receive-package))
(define (state:receive-package)
(match (read ip)
[(_ 'get 'ok (? nat? maj) (? nat? min) (? nat? bytes))
(let ([filename (make-temporary-file "planettmp~a.plt")])
(read-char ip) ; throw away newline that must be present
(read-n-chars-to-file bytes ip filename)
(list #t filename maj min))]
[(_ 'error 'malformed-request (? string? msg))
(state:abort (format "Internal error (malformed request): ~a" msg))]
[(_ 'get 'error 'not-found (? string? msg))
(state:failure (format "Server had no matching package: ~a" msg))]
[(_ 'get 'error (? symbol? code) (? string? msg))
(state:abort (format "Unknown error ~a receiving package: ~a" code msg))]
[bad-response (state:abort (format "Server returned malformed message: ~e" bad-response))]))
(define (state:abort msg)
(raise (make-exn:i/o:protocol msg (current-continuation-marks))))
(define (state:failure msg) (list #f msg))
(with-handlers ([void (lambda (e) (close-ports) (raise e))])
(begin0
(state:initialize)
(close-ports))))
;; ------------------------------------------------------------
;; HTTP VERSION OF THE PROTOCOL
;; pkg->servlet-args : FULL-PKG-SPEC -> environment[from net/url]
;; gets the appropriate query arguments to request the given package from the
;; PLaneT HTTP download servlet
(define (pkg->servlet-args pkg)
(let ([get (lambda (access) (format "~s" (access pkg)))])
`((lang . ,(format "~s" (DEFAULT-PACKAGE-LANGUAGE)))
(name . ,(get pkg-spec-name))
(maj . ,(get pkg-spec-maj))
(min-lo . ,(get pkg-spec-minor-lo))
(min-hi . ,(get pkg-spec-minor-hi))
(path . ,(get pkg-spec-path)))))
;; get-http-response-code : header[from net/head] -> string or #f
;; gets the HTTP response code in the given header
(define (get-http-response-code header)
(let ([parsed (regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header)])
(and parsed (cadr parsed))))
;; pkg->download-url : FULL-PKG-SPEC -> url
;; gets the download url for the given package
(define (pkg->download-url pkg)
(copy-struct url (string->url (HTTP-DOWNLOAD-SERVLET-URL))
(url-query (pkg->servlet-args pkg))))
;; download-package/http : FULL-PKG-SPEC -> RESPONSE
;; a drop-in replacement for download-package that uses HTTP rather than the
;; planet protocol. The HTTP protocol does not allow any kind of complicated
;; negotiation, but it appears that many more users can make HTTP requests than
;; requests from nonstandard protocols.
(define (download-package/http pkg)
(let/ec return
(let loop ([attempts 1])
(when (> attempts 5)
(return "Download failed too many times (possibly due to an unreliable network connection)"))
(let ([msg (format "downloading ~a from ~a via HTTP~a"
(pkg-spec->string pkg)
(PLANET-SERVER-NAME)
(if (= attempts 1)
""
(format ", attempt #~a" attempts)))])
(planet-terse-log 'download (pkg-spec->string pkg))
(planet-log "~a" msg))
(with-handlers ([exn:fail:network? (λ (e) (return (exn-message e)))])
(let* ([target (pkg->download-url pkg)]
[ip (get-impure-port target)]
[head (purify-port ip)]
[response-code/str (get-http-response-code head)]
[response-code (and response-code/str
(string->number response-code/str))])
(define (abort msg)
(close-input-port ip)
(return msg))
(case response-code
[(#f)
(abort (format "Server returned invalid HTTP response code ~s"
response-code/str))]
[(200)
(let ([maj/str (extract-field "Package-Major-Version" head)]
[min/str (extract-field "Package-Minor-Version" head)]
[content-length/str (extract-field "Content-Length" head)])
(unless (and maj/str min/str content-length/str
(nat? (string->number maj/str))
(nat? (string->number min/str))
(nat? (string->number content-length/str)))
(abort "Server did not include valid major and minor version information"))
(let* ([filename (make-temporary-file "planettmp~a.plt")]
[maj (string->number maj/str)]
[min (string->number min/str)]
[content-length (string->number content-length/str)]
[op (open-output-file filename 'truncate/replace)])
(copy-port ip op)
(close-input-port ip)
(close-output-port op)
(if (= (file-size filename) content-length)
(list #t filename maj min)
(loop (add1 attempts)))))]
[(404)
(begin0 (list #f (format "Server had no matching package: ~a"
(read-line ip)))
(close-input-port ip))]
[(400)
(abort (format "Internal error (malformed request): ~a"
(read-line ip)))]
[(500)
(abort (format "Server internal error: ~a"
(apply string-append
(let loop ()
(let ([line (read-line ip)])
(if (eof-object? line)
'()
(list* line "\n" (loop))))))))]
[else
(abort (format "Internal error (unknown HTTP response code ~a)"
response-code))]))))))
;; formats the pkg-spec back into a string the way the user typed it in,
;; except it never shows the minor version number (since some later one may actually be being used)
;; assumes that the pkg-spec comes from the command-line
(define (pkg-spec->string pkg)
(format "~a/~a~a"
(if (pair? (pkg-spec-path pkg))
(car (pkg-spec-path pkg))
"<<unknown>>") ;; this shouldn't happen
(regexp-replace #rx"\\.plt$" (pkg-spec-name pkg) "")
(if (pkg-spec-maj pkg)
(format ":~a" (pkg-spec-maj pkg))
"")))
;; =============================================================================
;; MODULE MANAGEMENT
;; Handles interaction with the module system
;; =============================================================================
;; do-require : path path symbol syntax -> symbol
;; requires the given filename, which must be a module, in the given path.
(define (do-require file-path package-path module-path stx load?)
(parameterize ([current-load-relative-directory package-path])
((current-module-name-resolver) file-path module-path stx load?)))
(define *package-search-chain*
(make-parameter
(list get/linkage
get/installed-cache
get/uninstalled-cache-dummy
get/server
get/uninstalled-cache)))
;; ============================================================
;; UTILITY
;; A few small utility functions
(define (last l) (car (last-pair l)))
;; make-directory*/paths : path -> (listof path)
;; like make-directory*, but returns what directories it actually created
(define (make-directory*/paths dir)
(let ([dir (if (string? dir) (string->path dir) dir)])
(let-values ([(base name dir?) (split-path dir)])
(cond [(directory-exists? dir) '()]
[(directory-exists? base) (make-directory dir) (list dir)]
[else (let ([dirs (make-directory*/paths base)])
(make-directory dir)
(cons dir dirs))]))))
get-planet-module-path/pkg)

1
collects/planet/syntax.rkt
View File

@ -10,7 +10,6 @@
(require racket/match
planet/util
syntax/parse
racket/syntax
unstable/syntax
(for-template racket/base)

13
collects/planet/tests/test-docs-complete.rkt
View File

@ -1,13 +0,0 @@
#lang racket/base
(require rackunit/docs-complete)
(check-docs (quote planet/version))
(check-docs (quote planet/util))
(check-docs (quote planet/syntax))
(check-docs (quote planet/scribble))
(check-docs (quote planet/resolver))
(check-docs (quote planet/raco))
(check-docs (quote planet/planet))
(check-docs (quote planet/planet-archives))
(check-docs (quote planet/parsereq))
(check-docs (quote planet/config))
(check-docs (quote planet/cachepath))

137
collects/planet/util.rkt
View File

@ -6,7 +6,9 @@
"private/planet-shared.rkt"
"private/linkage.rkt"
"resolver.rkt"
"private/resolver.rkt"
"private/version.rkt"
net/url
xml/xml
@ -50,9 +52,9 @@
display-plt-archived-file
get-package-from-cache
pkg->download-url
exn:fail:planet?
make-exn:fail:planet
pkg-spec?)
(struct-out exn:fail:planet)
pkg-spec?
pkg?)
(provide/contract
[get-package-spec
@ -63,19 +65,19 @@
(list/c #t path? natural-number/c natural-number/c)
(list/c #f string?)))]
[download/install-pkg
(-> string? (and/c string? #rx"[.]plt") natural-number/c any/c (or/c pkg? #f))]
(-> string? (and/c string? #rx"[.]plt$") natural-number/c any/c (or/c pkg? #f))]
[install-pkg
(-> pkg-spec? path-string? natural-number/c any/c (or/c pkg? #f))]
[add-hard-link
(-> string? (and/c string? #rx"[.]plt") natural-number/c natural-number/c path? void?)]
(-> string? (and/c string? #rx"[.]plt$") natural-number/c natural-number/c path? void?)]
[remove-hard-link
(->* (string? (and/c string? #rx"[.]plt") natural-number/c natural-number/c)
(->* (string? (and/c string? #rx"[.]plt$") natural-number/c natural-number/c)
(#:quiet? boolean?)
void?)]
[remove-pkg
(-> string? (and/c string? #rx"[.]plt") natural-number/c natural-number/c void?)]
(-> string? (and/c string? #rx"[.]plt$") natural-number/c natural-number/c void?)]
[erase-pkg
(-> string? (and/c string? #rx"[.]plt") natural-number/c natural-number/c void?)])
(-> string? (and/c string? #rx"[.]plt$") natural-number/c natural-number/c void?)])
;; get-package-spec : string string [nat | #f] [min-ver-spec | #f] -> pkg?
@ -415,22 +417,25 @@
(build-path SCRIBBLE-DOCUMENT-DIR name)
(memq 'multi-page flags))))))))
(unless
(or (null? critical-errors)
(force-package-building?))
(raise-user-error '|PLaneT packager| "~a\nRefusing to continue packaging." (car critical-errors)))
(unless (or (null? critical-errors)
(force-package-building?))
(raise-user-error '|PLaneT packager| "~a\nRefusing to continue packaging."
(if (pair? critical-errors)
(car critical-errors)
"")))
(pack archive-name
"archive"
(list ".") ;; if this changes, the filter (just below) must also change
null
(if (PLANET-ARCHIVE-FILTER)
(regexp->filter (PLANET-ARCHIVE-FILTER))
(λ (p)
(or (for/and ([always-in (list 'same (string->path "planet-docs"))]
[this-one (explode-path p)])
(equal? always-in this-one))
(std-filter p))))
(let ([p-a-f (PLANET-ARCHIVE-FILTER)])
(if p-a-f
(regexp->filter p-a-f)
(λ (p)
(or (for/and ([always-in (list 'same (string->path "planet-docs"))]
[this-one (explode-path p)])
(equal? always-in this-one))
(std-filter p)))))
#t
'file
#f
@ -790,7 +795,8 @@
;; ============================================================
;; VERSION INFO
;; re-provided here for backwards compatibility (no idea
;; why it was here in the first place, actually)
(provide this-package-version
this-package-version-name
this-package-version-owner
@ -799,91 +805,4 @@
this-package-version-symbol
package-version->symbol
make-planet-symbol
(rename-out [this-package-version/proc path->package-version]))
(define-syntax (this-package-version stx)
(syntax-case stx ()
[(_)
#`(this-package-version/proc
(this-expression-source-directory #,stx))]))
(define-syntax define-getters
(syntax-rules ()
[(define-getters (name position) ...)
(begin
(define-syntax (name stx)
(syntax-case stx ()
[(name)
#`(let ([p #,(datum->syntax stx `(,#'this-package-version))])
(and p (position p)))]))
...)]))
(define-getters
(this-package-version-name pd->name)
(this-package-version-owner pd->owner)
(this-package-version-maj pd->maj)
(this-package-version-min pd->min))
(define-syntax (this-package-version-symbol stx)
(syntax-parse stx
[(_ (~optional suffix:id))
#`(package-version->symbol
(this-package-version/proc
(this-expression-source-directory #,stx))
#,@(if (attribute suffix) #'['suffix] #'[]))]))
;; ----------------------------------------
(define (make-planet-symbol stx [suffix #f])
(match (syntax-source-directory stx)
[#f #f]
[dir (match (this-package-version/proc dir)
[#f #f]
[ver (package-version->symbol ver suffix)])]))
(define (package-version->symbol ver [suffix #f])
(match ver
[(list owner name major minor)
(string->symbol
(format "~a/~a:~a:~a~a"
owner
(regexp-replace #rx"\\.plt$" name "")
major
minor
(if suffix (format-symbol "/~a" suffix) "")))]
[#f #f]))
(define (this-package-version/proc srcdir)
(let* ([package-roots (get-all-planet-packages)]
[thepkg (ormap (predicate->projection (contains-dir? srcdir))
package-roots)])
(and thepkg (archive-retval->simple-retval thepkg))))
;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X)
(define (predicate->projection pred) (λ (x) (if (pred x) x #f)))
;; contains-dir? : path -> pkg -> boolean
(define ((contains-dir? srcdir) alleged-superdir-pkg)
(let* ([nsrcdir (simple-form-path srcdir)]
[nsuperdir (simple-form-path (car alleged-superdir-pkg))]
[nsrclist (explode-path nsrcdir)]
[nsuperlist (explode-path nsuperdir)])
(list-prefix? nsuperlist nsrclist)))
(define (list-prefix? sup sub)
(let loop ([sub sub]
[sup sup])
(cond
[(null? sup) #t]
[(equal? (car sup) (car sub))
(loop (cdr sub) (cdr sup))]
[else #f])))
(define (archive-retval->simple-retval p)
(list-refs p '(1 2 4 5)))
(define-values (pd->owner pd->name pd->maj pd->min)
(apply values (map (λ (n) (λ (l) (list-ref l n))) '(0 1 2 3))))
(define (list-refs p ns)
(map (λ (n) (list-ref p n)) ns))
path->package-version)

16
collects/planet/version.rkt
View File

@ -6,15 +6,17 @@
this-package-version-maj
this-package-version-min
this-package-version-symbol
this-package-in)
this-package-in
make-planet-symbol
package-version->symbol)
(require
planet/util
(for-syntax
racket/base
racket/require-transform
syntax/parse
planet/syntax))
"private/version.rkt"
(for-syntax
racket/base
racket/require-transform
syntax/parse
planet/syntax))
(define-syntax this-package-in
(make-require-transformer

7
collects/tests/planet/cmdline-tool.rkt
View File

@ -12,7 +12,10 @@ using 'system' to call out to the tool and then reading its results, etc.
net/url)
(define planet-bin-path
(simplify-path (build-path (collection-path "racket") 'up 'up "bin" "planet")))
(simplify-path (build-path (collection-path "racket") 'up 'up
(if (eq? (system-type) 'windows)
"planet.exe"
(build-path "bin" "planet")))))
(define test-connection-spec '("planet" "test-connection.plt" "1" "0"))
(define test-connection.plt-cache
@ -179,7 +182,7 @@ using 'system' to call out to the tool and then reading its results, etc.
(copy-port port sp)))
(get-output-string sp)))
(system (format "rm -rf ~a" tmp-dir))
(delete-directory/files tmp-dir)
(printf "done\n")
(unless (equal? open-files structure-files)
(error 'cmdline-tool.rkt "expected planet structure to produce the same files as planet open, got ~s and ~s"

12
collects/tests/planet/test-docs-complete.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang racket/base
(require rackunit/docs-complete)
(check-docs 'planet/version)
(check-docs 'planet/util)
(check-docs 'planet/syntax)
(check-docs 'planet/scribble)
(check-docs 'planet/resolver)
(check-docs 'planet/raco)
(check-docs 'planet/planet)
(check-docs 'planet/planet-archives)
(check-docs 'planet/config)
(check-docs 'planet/cachepath)

1
collects/tests/unstable/planet-syntax.rkt
View File

@ -1,7 +1,6 @@
#lang racket
(require mzlib/etc
planet/util
rackunit
rackunit/text-ui
planet/syntax