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

restore unmodified version

Browse Source 
svn: r10769
This commit is contained in:
Eli Barzilay 2008-07-14 15:36:51 +00:00
parent e78acf374f
commit 824fba5b26
18 changed files with 4179 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/planet/cachepath.ss Normal file
View File

@ -0,0 +1,14 @@
(module cachepath mzscheme
(require "config.ss")
(provide get-planet-cache-path)
;; get-planet-cache-path : -> path[absolute, file]
;; the path to the cache.ss 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.ss")))
path)))

24
collects/planet/config.ss Normal file
View File

@ -0,0 +1,24 @@
(module config mzscheme
(require "private/define-config.ss")
(define-parameters
(PLANET-SERVER-NAME "planet.plt-scheme.org")
(PLANET-SERVER-PORT 270)
(PLANET-CODE-VERSION "300")
(PLANET-BASE-DIR (if (getenv "PLTPLANETDIR")
(string->path (getenv "PLTPLANETDIR"))
(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) "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 "http://planet.plt-scheme.org/servlets/planet-servlet.ss")
(PLANET-ARCHIVE-FILTER #f)))

6
collects/planet/info.ss Normal file
View File

@ -0,0 +1,6 @@
#lang setup/infotab
(define name "PLaneT")
(define mzscheme-launcher-names '("planet"))
(define mzscheme-launcher-libraries '("planet.ss"))
(define scribblings '(("planet.scrbl" (multi-page) (tool))))

39
collects/planet/lang/reader.ss Normal file
View File

@ -0,0 +1,39 @@
#lang scheme/base
(require "../parsereq.ss")
(provide (rename-out [planet-read read]
[planet-read-syntax read-syntax]))
(define (planet-read-fn in spec->read-data)
(let* ([spec (read-line in)]
[parsed-spec
(with-handlers ([exn:parse-failure? (λ (e) (raise-syntax-error 'read "bad syntax"))])
(parse-package-string spec))])
(values
`(planet "lang/main.ss" ,parsed-spec)
(spec->read-data `(planet "lang/reader.ss" ,parsed-spec)))))
(define (wrap port spec read)
(let* ([body
(let loop ([a null])
(let ([v (read port)])
(if (eof-object? v)
(reverse a)
(loop (cons v a)))))]
[p-name (object-name port)]
[name (if (path? p-name)
(let-values ([(base name dir?) (split-path p-name)])
(string->symbol (path->string (path-replace-suffix name #""))))
'page)])
`(module ,name ,spec
. ,body)))
(define (planet-read [inp (current-input-port)])
(define-values (spec r) (planet-read-fn inp (λ (spec) (dynamic-require spec 'read))))
(wrap inp spec r))
(define (planet-read-syntax [src #f] [inp (current-input-port)])
(define-values (spec r) (planet-read-fn inp (λ (spec) (dynamic-require spec 'read-syntax))))
(wrap inp spec (lambda (p) (r src p))))

154
collects/planet/parsereq.ss Normal file
View File

@ -0,0 +1,154 @@
#lang scheme/base
(require mzlib/match
"private/short-syntax-helpers.ss"
"private/data.ss")
(provide (struct-out request)
parse-package-string
(struct-out exn:parse-failure)
spec->req
pkg-spec->full-pkg-spec
version->bounds
string->longpkg
string->shortpkg
short-pkg-string->spec)
(define-struct request (full-pkg-spec file path))
(define (tospec owner pkg maj min)
`(,owner ,pkg ,@(if maj (list maj) '()) ,@(if min (list min) '())))
(define-struct (exn:parse-failure exn:fail) ())
(define (string->longpkg s)
(let ([mtch (regexp-match #rx"^[ ]*([^ :/]+)[ ]+([^ :/]+)[ ]*([0-9]*)[ ]*([0-9]*)[ ]*$" s)])
(if mtch
(let-values ([(owner pkg majstr minstr) (apply values (cdr mtch))])
(tospec owner pkg
(if (string=? majstr "") #f (string->number majstr))
(if (string=? minstr "") #f (string->number minstr))))
#f)))
(define (string->shortpkg s)
(define ((yell fmt) x) (raise (make-exn:parse-failure (format fmt x) (current-continuation-marks))))
(with-handlers ([exn:parse-failure? (λ (e) #f)])
(let* ([pkg-spec/tail (short-pkg-string->spec s yell)]
[pkg-spec (car pkg-spec/tail)]
[tail (cadr pkg-spec/tail)])
(if (regexp-match #rx"^[ ]*$" tail) pkg-spec #f))))
(define all-parsers (list string->longpkg string->shortpkg))
;; parse-package-string : string -> pkg-spec
;; parses a "package name string", the kind of string that shows up in places where we're only interested
;; in naming a particular package, not a full path
(define (parse-package-string str)
(define (yell str) (raise (make-exn:parse-failure str (current-continuation-marks))))
(ormap (λ (p) (p str)) all-parsers))
;; spec->req : sexp[require sexp] stx -> request
;; maps the given require spec to a planet package request structure
(define (spec->req spec stx)
(match (cdr spec)
[(file-name pkg-spec path ...)
(unless (string? file-name)
(raise-syntax-error #f (format "File name: expected a string, received: ~s" file-name) stx))
(unless (andmap string? path)
;; special-case to catch a possibly common error:
(if (ormap number? path)
(raise-syntax-error #f (format "Module path must consist of strings only, received a number (maybe you intended to specify a package version number?): ~s" path) stx)
(raise-syntax-error #f (format "Module path must consist of strings only, received: ~s" path) stx)))
(make-request (pkg-spec->full-pkg-spec pkg-spec stx)
file-name
path)]
[((? (lambda (x) (or (symbol? x) (string? x))) s))
(let ([str (if (symbol? s) (symbol->string s) s)])
(define (yell msg) (λ (str) (raise-syntax-error #f (format msg str) stx)))
(let* ([pkg-spec/tail (short-pkg-string->spec str yell)]
[pkg-spec (car pkg-spec/tail)]
[tail (cadr pkg-spec/tail)]
[fullspec (pkg-spec->full-pkg-spec pkg-spec stx)]
[final-path (if (string=? tail "")
"main.ss"
(string-append tail ".ss"))])
(make-request fullspec final-path '())))]
[_ (raise-syntax-error 'require (format "Illegal PLaneT invocation: ~e" (cdr spec)) stx)]))
;; short-pkg-string->spec : string (string -> string -> 'a) -> (list pkg-spec string)
;; extracts the named package from the given short-style string, returning
;; both that package spec and the leftover string
(define (short-pkg-string->spec str yell)
(try-parsing str
([(consume-whitespace)]
[owner (get-next-slash #:on-error (yell "expected an owner, received ~e"))]
[package (get-next-slash-or-end #:on-error (yell "expected a package, received ~e"))])
(λ (tail)
(let*-values ([(yell!) (yell "~a")]
[(pkg maj min) (parse-package package yell!)])
(list (tospec owner pkg maj min) tail)))))
; pkg-spec->full-pkg-spec : PKG-SPEC syntax -> FULL-PKG-SPEC
(define (pkg-spec->full-pkg-spec spec stx)
(define (pkg name maj lo hi path) (make-pkg-spec name maj lo hi path stx (version)))
(define (fail* msg)
(raise-syntax-error 'require (string->immutable-string msg) stx))
(define (fail)
(fail* (format "Invalid PLaneT package specifier: ~e" spec)))
(match spec
[((? string? owner) (? string? package) ver-spec ...)
(match-let ([(maj min-lo min-hi) (version->bounds ver-spec fail*)])
(pkg package maj min-lo min-hi (list owner)))]
[((? (o not string?) owner) _ ...)
(fail* (format "Expected string [package owner] in first position, received: ~e" owner))]
[(_ (? (o not string?) pkg) _ ...)
(fail* (format "Expected string [package name] in second position, received: ~e" pkg))]
[_ (fail)]))
;; version->bounds : VER-SPEC -> (list (number | #f) number (number | #f)) | #f
;; determines the bounds for a given version-specifier
;; [technically this handles a slightly extended version of VER-SPEC where MAJ may
;; be in a list by itself, because that's slightly more convenient for the above fn]
(define (version->bounds spec-list fail)
(match spec-list
[() (list #f 0 #f)]
[(? number? maj) (version->bounds (list maj))]
[((? number? maj)) (list maj 0 #f)]
[((? number? maj) min-spec)
(let ((pkg (lambda (min max) (list maj min max))))
(match min-spec
[(? number? min) (pkg min #f)]
[((? number? lo) (? number? hi)) (pkg lo hi)]
[('= (? number? min)) (pkg min min)]
[('+ (? number? min)) (pkg min #f)]
[('- (? number? min)) (pkg 0 min)]
;; failure cases
[(? (o/and (o not number?)
(o/or (o not list?)
(λ (x) (not (= (length x) 2))))))
(fail (format "Expected number or version range specifier for minor version specification, received: ~e" min-spec))]
[((? (λ (x)
(and (not (number? x))
(not (memq x '(= + -)))))
range)
_)
(fail (format "Illegal range specifier in minor version specification. Legal range specifiers are numbers, =, +, -; given: ~e" range))]
[(_ (? (o not number?) bnd))
(fail (format "Expected number as range bound in minor version specification, given: ~e" bnd))]
[_ (fail (format "Illegal minor version specification: ~e" min-spec))]))]
;; failure cases
[(? (o/and (o not number?) (o not list?)) v)
(fail (format "Version specification expected number or sequence, received: ~e" v))]
[((? (o not number?) maj) _ ...)
(fail (format "Version specification expected number for major version, received: ~e" maj))]
[_ (fail "Invalid version specification")]))
(define (o f g) (λ (x) (f (g x))))
(define (o/and . es) (λ (x) (andmap (λ (f) (f x)) es)))
(define (o/or . es) (λ (x) (ormap (λ (f) (f x)) es)))

60
collects/planet/planet-archives.ss Normal file
View File

@ -0,0 +1,60 @@
(module planet-archives mzscheme
(require "private/planet-shared.ss"
mzlib/file
"config.ss"
"cachepath.ss")
(provide repository-tree
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"/(CVS|[.]svn)$"
(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)
;; 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
(build-path (CACHE-DIR) owner package (number->string maj) (number->string min))
owner
package
'()
maj
min)))
x))
(repository-tree)
3)))
;; get-hard-linked-packages : -> listof (list path[absolute, dir] string string (listof string) nat nat)
;; directories of all hard-linked packages
(define (get-hard-linked-packages)
(map
(lambda (row)
(map (lambda (f) (f row))
(list assoc-table-row->dir
(lambda (r) (car (assoc-table-row->path r)))
assoc-table-row->name
(lambda (r) (cdr (assoc-table-row->path r)))
assoc-table-row->maj
assoc-table-row->min)))
(get-hard-link-table)))
;; get-all-planet-packages : -> listof (list path[absolute, dir] string string (listof string) nat nat)
;; get every planet package, regardless of origin
(define (get-all-planet-packages)
(append (get-installed-planet-archives)
(get-hard-linked-packages)))
)

879
collects/planet/planet.scrbl Normal file
View File

@ -0,0 +1,879 @@
#lang scribble/doc
@(require scribble/manual
scribble/bnf
scribble/eval
(for-label scheme)
(for-label planet/config)
(for-label planet/util))
@(define-syntax-rule (eg (code resl) ...)
(interaction
(eval:alts code resl)
...))
@title{@bold{PLaneT}: Automatic Package Distribution}
@PLaneT is PLT Scheme's centralized package repository. It consists of
two parts: , which contains packages contributed by users, and
the @PLaneT client, which is built in to PLT Scheme.
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. It
consists of @link["http://planet.plt-scheme.org/"]{the central @PLaneT
package repository}, a server that holds all PLaneT packages, and
the PLaneT client, built into PLT Scheme, which transparently
interacts with the server on your behalf when necessary.
@table-of-contents[]
@section{Using PLaneT}
To use a @PLaneT package in a program, require it using the
@scheme[planet] @scheme[require] form (see @(secref "require" #:doc
'(lib "scribblings/reference/reference.scrbl")) for a full reference
on the features of the @scheme[require] statement in general and the
exact allowed grammar of PLaneT require statements). Here we explain
how to use PLaneT by example.
@subsection[#:tag "finding-a-package"]{Finding a Package}
If you are new to PLaneT, the first thing to to is visit
@link["http://planet.plt-scheme.org/"]{the PLaneT repository web site}
and see what packages are available. People contribute new PLaneT
packages all the time --- if you want to be notified whenever a new or
updated package is released, you can subscribe to the
(announcement-only)
@link["http://mailman.cs.uchicago.edu/mailman/listinfo/planet-announce"]{PLaneT-announce mailing list}
or use an RSS reader to subscribe to
@link["http://planet.plt-scheme.org/300/planet.rss"]{PLaneT's RSS feed}.
To use a package from PLaneT in your program, the easiest thing to do
is copy the @scheme[require] code snippet off of that package's page
and paste it ino your program. For instance, to use Schematics'
@link["http://planet.plt-scheme.org/users/schematics/spgsql.plt"]{spgsql.plt}
package (a library for interacting with the
@link["http://www.postgresql.org/"]{PostgresQL} database), as of this
writing you would copy and paste the line:
@scheme[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 3)))]
into your program. This line requires the file @filepath{spgsql.ss} in package
version 2.3 of the @filepath{spgsql.plt} package written by
@filepath{schematics}. That does two things: first, it downloads and
installs a version of @filepath{spgsql.plt} that is compatible with
package version 2.3 from @link["http://planet.plt-scheme.org/"]{the
central PLaneT repository} if a compatible version hasn't already been
installed. Second, it requires the module in file @filepath{spgsql.ss}
from that package, making all of its exported bindings available for use.
Unlike with most package-distribution systems, package downloading and
installation in PLaneT is @italic{transparent} --- there's no need for
you to do anything special the first time you want to use a package,
and there's no need for you to even know whether or not a particular
package is installed on your computer or the computers where your code
will be deployed.
@subsection{Shorthand Syntax}
As of PLT Scheme version 4.0, the code snippet in section
@secref{finding-a-package} can also be written using a new shorter syntax:
@scheme[(require (planet schematics/spgsql:2:3/spgsql))]
The two forms behave identically. In the abbreviated syntax, however,
it is illegal to write the trailing @scheme{.ss} suffix on the file
name to be required or the trailing @scheme{.plt} on the package file
name. (They are mandatory for the long-form syntax.) It is also legal
in the abbreviated syntax to omit a filename to be required entirely;
in that case, PLaneT requires the file @scheme{main.ss} in the given
package.
@subsection{Fine-Grained Control Over Package Imports}
The PLaneT client is designed to balance two competing goals:
transparent upgradability and control over the effect of a package
requirement. To that end, the most basic PLaneT require form offers
maximum upgradability, but several more specialized forms allow
finer-grained control over what versions of the named package may be
downloaded.
@margin-note{Package versions should not be confused with program or library
versions; a @italic{package version} is a PLaneT-specific version
number that encodes backwards-compatibility information.}
The most basic planet require line, which is what is used in the form
@scheme[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 3)))]
in longhand notation, or
@scheme[(require (planet schematics/spgsql:2:3/spgsql))]
in shorthand notation, should be read ``Require from PLaneT
@italic{any} release of Schematics' @filepath{spgsql.plt} package that
is backwards-compatible with package version 2.3.'' (The actual
package version used is determined by @seclink["search-order"]{the
PLaneT search order}.) To signal this explicitly, it is possible to
write
@scheme[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 (+ 3))))]
or
@scheme[(require (planet schematics/spgsql:2:>=3/spgsql))]
both of which mean the same thing as the first pair of require lines.
@margin-note{See @secref{backwards-compatibility} for a more detailed discussion of
backwards-compatibility obligations for PLaneT packages.}
The notion of ``backwards-compatibility'' has a specific meaning in
PLaneT: by definition, for the purposes of automation, a package is
considered to be backwards-compatible with any other package of the
same owner, name, and major version, and any @italic{lower} minor
version. Package maintainers are responsible for marking new releases
that break backwards-compatibility by incrementing their major-version
number. This means that all of the above require specifications will
match any release of @filepath{unlib.plt} with major package version 3
(and any minor version), but will @italic{never} match releases of
@filepath{unlib.plt} with higher (or lower) major version numbers.
Of course a package author may make a mistake and introduced a
backwards-incompatibility unintentionally, or may fix a bug that code
in third-party libraries was already working around. In those cases,
it may help to make use of the ``upper bound'' form of the planet
require, in longhand form:
@scheme[(require (planet "reduction-semantics.ss" ("robby" "redex.plt" 4 (- 3))))]
and using shorthand notation:
@scheme[(require (planet robby/redex:4:<=3/reduction-semantics))]
In this require line, any version of the package @filepath{redex.plt}
from package version 4.0 to package version 4.3 will match the require
spec (though as with any PLaneT require specification,
@seclink["search-order"]{the PLaneT package search order} determines
which package is actually loaded).
It is also possible to specify both an upper and a lower bound, using
the planet require's ``range'' form:
@scheme[(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 (9 10))))]
or
@scheme[(require (planet schematics/schemeunit:2:9-10/test))]
This form matches any package in the specified range (inclusive on
both ends), in this example the specifications match either package
version 2.9 or 2.10 of the @filepath{schemeunit.plt} package, but do
not match version with higher or lower minor version numbers (or any
other major version number).
Using the range form, it is possible to require a specific version of
a package as a special case (choosing the upper and lower bounds to be
equal), but this is a common enough case that it has special support
with the ``exact-match'' form:
@scheme[(require (planet "unzip.ss" ("dherman" "zip.plt" 2 (= 1))))]
or
@scheme[(require (planet dherman/zip:2:=1/unzip))]
match only the exact package version 2.1 of the @filepath{zip.plt} package.
@;@subsection{Linkage}
@;@subsection{The Diamond Property}
@section[#:tag "search-order"]{The PLaneT Search Order}
PLaneT has four strategies it uses in order to match a request with an
appropriate package that.
@subsection{Previous Linkage}
Whenever a file requires a package via PLaneT and that requirement is
satisfied, the system makes a note of exactly which package satisfied
that requirement and from then on always uses that exact same package,
even if a newer version is available. This is done to prevent "magic
upgrades" in which a program stops working after installation because
an unrelated package was installed. Such connections are called links
and are stored in a user-specific table called the linkage table.
@subsection{Acceptable Local Package}
If the PLaneT client doesn't have any previous linkage information, it
checks its list of already-installed PLaneT packages for one that
meets the requirement, and uses it if available. Both PLaneT-installed
packages and packages established through a development link
(see @secref{devlinks})
are checked simultaneously at this stage.
@subsection{Acceptable Remote Package}
If there is no acceptable local package, the PLaneT client sends
a request to the PLaneT server for a new package that would satisfy
the requirement. The server then finds the newest matching package
and sends it back to the client, which then installs it and uses
it to satisfy the original requirement.
@subsection{Cached Installation Archive}
If the remote server cannot be contacted (or fails in any way to
deliver an acceptable package), the PLaneT client consults the
uninstalled-packages cache, a cache of all previously-downloaded
packages, even those that are not currently installed. PLT Scheme
users who frequently upgrade their installations may have many
packages downloaded but not installed at any given time; this step
is intended to ensure that these users can still run programs even
if they temporarily lose network connection.
@section[#:tag "cmdline"]{The @exec{planet} Command-Line Tool}
The @exec{planet} command-line tool allows a command-line interface to
the most commonly-performed PLaneT tasks. It is invoked from the
command line as
@commandline{planet @italic{subcommand} arg ...}
where @italic{command} is a subcommand from the following list, and
@exec{arg} is a sequence of arguments determined by that subcommand:
@(define (cmd name desc)
@item{@(seclink name (exec name)): @desc})
@itemize{
@cmd["create"]{create a PLaneT archive from a directory}
@cmd["install"]{download and install a given package}
@cmd["remove"]{remove the specified package from the local cache}
@cmd["show"]{list the packages installed in the local cache}
@cmd["clearlinks"]{clear the linkage table, allowing upgrades}
@cmd["fileinject"]{install a local file to the planet cache}
@cmd["link"]{create a development link}
@cmd["unlink"]{remove development link associated with the given package}
@cmd["fetch"]{download a package file without installing it}
@cmd["url"]{get a URL for the given package}
@cmd["open"]{unpack the contents of the given package}
@cmd["structure"]{display the structure of a given .plt archive}
@cmd["print"]{display a file within of the given .plt archive}}
Each of these commands is described in more detail below. All the
functionality of the command-line tool is also provided with a programmatic interface by
@seclink["util.ss"]{the @filepath{util.ss} library}.
@subsection[#:tag "create"]{@exec{create}}
Usage:
@commandline{planet create [ <option> ... ] <path>}
Create a PLaneT archive in the current directory whose contents are the
directory @exec{<path>}.
@exec{<option>} is one of:
@itemize{
@item{@exec{-f, --force}: force a package to be created even if its info.ss file contains
errors.}}
@subsection[#:tag "install"]{@exec{install}}
Usage:
@commandline{planet install <owner> <pkg> <maj> <min>}
Download and install the package that @scheme[(require (planet "file.ss" (<owner> <pkg> <maj> <min>)))]
would install.
@subsection[#:tag "remove"]{@exec{remove}}
Usage:
@commandline{planet remove [ <option> ... ] <owner> <pkg> <maj> <min>}
Remove the specified package from the local cache, optionally also removing its
distribution file.
@exec{<option>} is one of:
@itemize{
@item{@exec{-e, --erase}: also remove the package's distribution file from the
uninstalled-package cache}}
@subsection[#:tag "show"]{@exec{show}}
Usage:
@commandline{planet show [ <option> ... ]}
List the packages installed in the local cache.
@exec{<option>} is one of:
@itemize{
@item{@exec{-p, --packages}: show packages only (default)}
@item{@exec{-l, --linkage}: show linkage table only}
@item{@exec{-a, --all}: show packages and linkage}}
@subsection[#:tag "clearlinks"]{@exec{clearlinks}}
Usage:
@commandline{planet clearlinks}
Clear the linkage table, allowing upgrades.
@subsection[#:tag "fileinject"]{@exec{fileinject}}
Usage:
@commandline{planet fileinject <owner> <plt-file> <maj> <min>}
Install local file <plt-file> into the planet cache as though it had been
downloaded from the planet server. It is treated as though it had the given owner name as its owner name,
the given file's filename as the its package name, and the given major and minor version numbers.
@subsection[#:tag "link"]{@exec{link}}
Usage:
@commandline{planet link <owner> <pkg> <maj> <min> <path>}
Create a development link (see @secref{devlinks}) between the given
package specifier and the specified directory name.
@subsection[#:tag "unlink"]{@exec{unlink}}
Usage:
@commandline{planet unlink <owner> <pkg> <maj> <min>}
Remove any development link (see @secref{devlinks}) associated with
the given package.
@subsection[#:tag "fetch"]{@exec{fetch}}
Usage:
@commandline{planet fetch <owner> <pkg> <maj> <min>}
Download the given package file from the central PLaneT repository without installing it.
@subsection[#:tag "url"]{@exec{url}}
Usage:
@commandline{planet url <owner> <pkg> <maj> <min>}
Get a URL for the given package.
This is never necessary for normal use of planet, but may be helpful in some
circumstances for retrieving packages.
@subsection[#:tag "open"]{@exec{open}}
Usage:
@commandline{planet open <plt-file> <target>}
Unpack the contents of the given package into the given directory without
installing.
This command is not necessary for normal use of planet. It is intended to allow
you to inspect package contents offline without needing to install the package.
@subsection[#:tag "structure"]{@exec{structure}}
Usage:
@commandline{planet structure <plt-file>}
Print the structure of the PLaneT archive named by <plt-file> to the standard
output port.
This command does not unpack or install the named .plt file.
@subsection[#:tag "print"]{@exec{print}}
Usage:
@commandline{planet print <plt-file> <path>}
Print the contents of the file named by <path>, which must be a relative path
within the PLaneT archive named by <plt-file>, to the standard output port.
This command does not unpack or install the named .plt file.
@section{Utility Libraries}
The planet collection provides configuration and utilities for using PLaneT.
@subsection{config.ss: Client Configuration}
The config.ss 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 and 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.ss file.
@defmodule[planet/config]
@defparam[PLANET-DIR dir path-string?]{
The root PLaneT directory. If the environment variable PLTPLANETDIR is
set, default is its value; otherwise the default is the directory in
which @filepath{config.ss} 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 PLT Scheme, the uninstalled package cache is
shared by all versions of PLT Scheme 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 PLT Scheme
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 @scheme[#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 @scheme[#t],
PLaneT will use the HTTP protocol; if @scheme[#f] it will use the custom-built
PLaneT protocol. The default value for this parameter is @scheme[#t] and setting
this parameter to @scheme[#f] is not recommended.}
@defparam[HTTP-DOWNLOAD-SERVLET-URL url string?]{
The URL for the servlet that will provide PLaneT packages if
@scheme[USE-HTTP-DOWNLOADS?] is @scheme[#t], represented as a string. The default
value is @scheme["http://planet.plt-scheme.org/servlets/planet-servlet.ss"].}
@defparam[PLANET-SERVER-NAME host string?]{
The name of the PLaneT server to which the client should connect if
@scheme[USE-HTTP-DOWNLOADS?] is @scheme[#f]. The default value for this parameter is
@scheme["planet.plt-scheme.org"].}
@defparam[PLANET-SERVER-PORT port natural-number?]{
The port on the server the client should connect to if
@scheme[USE-HTTP-DOWNLOADS?] is @scheme[#f]. The default value for this parameter is
@scheme[270].}
@subsection[#:tag "util.ss"]{util.ss: Utilities}
The @filepath{util.ss} 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{planet} command-line tool} is
also available programmatically through this library.
@defmodule[planet/util]
@defproc[(download/install-pkg [owner string?]
[pkg string?]
[maj natural-number/c]
[min natural-number/c])
(or/c pkg? false/c)]{
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.}
@defparam[current-cache-contents contents
((string? ((string? ((natural-number/c (natural-number/c ...)) ...)) ...)) ...)]{
Holds a listing of all package names and versions installed in the
local cache.}
@defproc[(current-linkage)
((path-string? (string? (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 string?]
[maj natural-number/c]
[min natural-number/c])
any]{
Removes the specified package from the local planet cache.}
@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 @scheme[plt-file] to @scheme[(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 @scheme[file-to-print] within the
PLaneT archive .plt file named by @scheme[plt-file] to @scheme[(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 string?]
[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.}
@defproc[(remove-hard-link [owner string?]
[pkg string?]
[maj natural-number/c]
[min natural-number/c])
any]{
Removes any hard link that may be associated with the given package.}
@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)]
)]{
Macros that expand into expressions that evaluate to information about
the name, owner, and version number of the package in which they
appear. @scheme[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 @scheme[#f] if the expression appears outside the
context of a package. The others are convenience macros that
select out the relevant field, or return @scheme[#f] if the expression
appears outside the context of a PLaneT package.}
@section{Developing Packages for PLaneT}
To put a package on PLaneT, or release an upgrade to an
already-existing package:
@subsection{Write Your Package}
PLaneT can distribute whatever programs you write, but keep
these guidelines in mind as you write:
@itemize{
@item{Organize your code into modules. Since the PLaneT client is
integrated into the @scheme[require] form, it works best if your code
is arranged into modules.}
@item{When one module in your program depends on another, it is best
to require it using the relative-file-name form rather than the
planet require form. For instance, if your program contains files
primary.ss and helper.ss where primary.ss requires helper, use the form
@scheme[(require "helper.ss")]
instead of
@scheme[(require (planet "helper.ss" ("username" "packagename.plt" 1 0)))]
in files that will also be a part of the package.}}
@subsubsection[#:tag "devlinks"]{Development Links}
To aid development, PLaneT allows users to establish direct
associations between a particular planet package
with an arbitrary directory on the filesystem, for instance connecting the package named by the require line
@scheme[(require (planet "file.ss" ("my" "mypackage.plt" 1 0)))]
to the directory @filepath{/home/myname/svn/mypackages/devel/}.
These associations are intended to allow developers to use their own
directory structures, version control systems, and so on while still
being able to use the packages they create as though they were
distributed directly by PLaneT. Development links are local to a
particular user and repository (but not to a particular MzScheme minor
revision).
To establish a development link, use the @exec{planet} command-line tool:
@commandline{planet link myname mypackage.plt 1 0 ~/svn/mypackages/devel}
Once you are finished developing a package, you should remove any
development links you have established for it, again using the planet
command-line tool:
@commandline{planet unlink myname mypackage.plt 1 0}
You may alternately use the functions @scheme[add-hard-link] and @scheme[remove-hard-link].
@subsection{Prepare Your Distribution}
@subsubsection{Arrange Files Into a Directory}
Make sure that all source files, documentation, etc. that you want to
be a part of the package are in a single directory and its
subdirectories. Furthermore make sure that nothing else, @italic{e.g.}
unneeded backup files, is in that directory (with the exception that
the subdirectories and files CVS or Subversion creates are
automatically skipped by the packaging tool).
@subsubsection{Create Documentation [Optional]}
Use Scribble to write documentation for your package. See
@other-manual['(lib "scribblings/scribble/scribble.scrbl")]
for instructions on how to write Scribble documentation.
@subsubsection{Create an @filepath{info.ss} File [Optional]}
If you put a file named @filepath{info.ss} in your package's root directory, the
PLaneT system (as well as the rest of the PLT Scheme tool suite) will
look in it for descriptive metadata about your package. The PLaneT
system looks for certain names in that file:
@itemize{
@item{The @scheme['blurb] field: If present, the blurb field should contain a list of XHTML fragments
encoded as x-expressions (see the xml collection for details) that
PLaneT will use as a short description of your project.}
@item{The @scheme['release-notes] field: If present, the release-notes field should contain a list of XHTML
fragments encoded as x-expressions (see the xml collection for
details) that PLaneT will use as a short description of what's new
in this release of your package.}
@item{The @scheme['categories] field:
If present, the categories field should be a list of symbols
corresponding to the categories under which this package should be listed.
The valid categories are:
@itemize{
@item{@scheme['devtools]: Development Tools}
@item{@scheme['net]: Networking and Protocols}
@item{@scheme['media]: Graphics and Audio}
@item{@scheme['xml]: XML-Related}
@item{@scheme['datastructures]: Data Structures and Algorithms}
@item{@scheme['io]: Input/Output and Filesystem}
@item{@scheme['scientific]: Mathematical and Scientific}
@item{@scheme['system]: Hardware/Operating System-Specific Tools}
@item{@scheme['ui]: Textual and Graphical User Interface}
@item{@scheme['metaprogramming]: Metaprogramming Tools}
@item{@scheme['planet]: PLaneT-Related}
@item{@scheme['misc]: Miscellaneous}}
If you put symbols other than these the categories field, they will be
ignored. If you put no legal symbols in the categories field or do not
include this field in your info.ss file, your package will be
categorized as "Miscellaneous."}
@item{The @scheme['can-be-loaded-with] field:
If present, the can-be-loaded-with field should be a quoted datum of
one of the following forms:
@schemegrammar[
can-be-loaded-with 'all
'none
(list 'all-except VER-SPEC ...)
(list 'only VER-SPEC ...)]
where VER-SPEC is a PLaneT package version specification.
Depending on your package's behavior, it may or may not be okay for
multiple versions of the same package to be loaded at one time on the
entire system --- for instance, if your package relies on writing to a
particular file and assumes that nothing else writes to that same
file, then multiple versions of the same package being loaded
simultaneously may be a problem. This field allows you to specify
whether your package can be loaded simultaneously with older versions
of itself. If its value is @scheme['all], then the package may be loaded with
any older version. If it is @scheme['none], then it may not be loaded with
older versions at all. If it is @scheme[(list 'all-except VER-SPEC ...)] then
any package except those that match one of the given VER-SPEC forms
may be loaded with this package; if it is @scheme[(list 'only VER-SPEC ...)]
then only packages that match one of the given VER-SPEC forms may be
loaded with this package.
When checking to see if a package may be loaded, PLaneT compares it to
all other currently-loaded instances of the same package with any
version: for each comparison, it checks to see if the newer package's
can-be-loaded-with field allows the older package to be loaded. If all
such comparisons succeed then the new package may be loaded; otherwise
PLaneT signals an error.
The default for this field is @scheme['none] as a conservative protection
measure. For many packages it is safe to set this field to
@scheme['any].}
@item{The @scheme['homepage] field:
If present, the URL field should be a string corresponding to a URL
for the package. PLaneT provides this link with the description of your
package on the main PLaneT web page.}
@item{The @scheme['primary-file] field:
If present, the primary-file field should be a either a string
corresponding to the name (without path) of the main Scheme source
file of your package, or a list of such strings. The PLaneT web page
corresponding to this package will present all files listed here as
interface files for your package; it will give direct links to each
package and a listing of all names provided by the package along with
their contracts (if present).
If you include only a single string, it will be used as the require
line printed on your package's page. If you include a list of strings,
then the first legal file string in the list will be used.}
@item{The @scheme['required-core-version] field: If present, the
required-core-version field should be a string with the same syntax as
the output of the @scheme[version] function. Defining this field
indicates that PLaneT should only allow users of a version of mzscheme
equal to or more recent than the version specified by this field. This
allows you finer-grained control of your package's core-language
requirements than its inclusion in a particular repository; for
instance, setting this field to @scheme["300.2"] would cause the PLaneT server
not to serve it to MzScheme v300.1 or older clients.}
@item{The @scheme['version] field:
If present, the version field should be a string that describes the
version number of this code that should be presented to users (e.g.,
@scheme["0.15 alpha"]). This field does not override or in any way interact
with your package's package version number, which is assigned by
PLaneT, but may be useful to users.}
@item{The @scheme['repositories] field: If present, the repositories
field should be a list consisting of some subset of the strings
@scheme["4.x"] and @scheme["3xx"]. The string @scheme["4.x"] indicates
that this package should be included in the v4.x repository (which
contains packages that are intended to run in PLT Scheme versions at
or above version 4.0), and the string @scheme["3xx"] indicates that
the package should be included in the v3xx repository (containing
packages intended to run in PLT Scheme versions in the 3xx series). A
single package (and a single version of a package) may be included in
multiple repositories with the same PLaneT version number.}}
In addition, PLaneT uses the setup-plt installer to install packages
on client machines, so most fields it looks for can be included with
their usual effects. In particular, adding a @scheme['name] field indicates that
the Scheme files in the package should be compiled during
installation; it is a good idea to add it.
An example info.ss file looks like this:
@schememod[
setup/infotab
(define name "My Application")
(define blurb
'("My application runs 60% faster on 20% less peanut "
"butter. It even shows a fancy graphic!"))
(define primary-file "my-app.ss")
(define categories '(system xml))
]
See the PLT mzc: MzScheme Compiler Manual, chapter 7 for more
information on info.ss files.
@subsection{Build a Distribution Archive}
Use the planet command-line tool in its archive-creation mode to
create a planet archive:
@commandline{planet create /home/jacob/my-app/}
This will create a planet archive named @filepath{my-app.plt} in the current
directory whose contents are the contents of @filepath{/home/jacobm/my-app} and
all its subdirectories.
Alternately, you can run @scheme[make-planet-archive] with the name of the directory
you've prepared as its argument:
@scheme[(make-planet-archive "/home/jacob/my-app/")]
This function will build a packaged version of your directory and
return the path to that package. The path will always be a file named
@filepath{X.plt}, where @filepath{X} is the name of the directory you
gave to @scheme[make-planet-archive], located in that same directory.
You can now test that your archive file works as intended using the
planet command-line tool in its install mode:
@commandline{planet fileinject <owner> <path to your .plt file> <maj> <min>}
installs the specified file into your local PLaneT cache as
though it had been downloaded from the PLaneT server with the given
owner name and major and minor versions. After you run this command,
you can require your package on your local machine using
@scheme[(require (planet <file> (<owner> <.plt file name without path> <maj> <min>)))]
to verify everything works. After you do so, you can use
@commandline{planet remove <owner> <.plt file name without path> <maj> <min>}
to remove the test package from your local cache. (Not removing it is
safe as long as you use the same name and version numbers the package
will have on the PLaneT server; otherwise you may experience
problems.)
@subsection[#:tag "backwards-compatibility"]{Determine Your Package's Backwards-Compatibility}
If you are updating a previously-released package, you must decide
whether your package is a backwards-compatible change or not. A rule
of thumb is to remember that modules written to work with the
previously-released version of your package should unmodified with the
new package. This means that at a minimum, a backwards compatible
update should:
@itemize{
@item{Contain all the same Scheme source files in that the previous
version contained in directories intended for public access}
@item{In each public file, provide at least all the bindings that the
previous version provided}
@item{For each name provided with a contract (see @(secref #:doc '(lib
"scribblings/guide/guide.scrbl") "contracts" )), provide it
with a contract that is at least as permissive as the previous
contract}}
A backwards-compatible upgrade may, however:
@itemize{
@item{Change any behavior that
reasonable consumers of your package would not consider guaranteed
(@italic{e.g.}, by fixing bugs or improving the efficiency of
operations).}
@item{Remove files in clearly-marked private
sections. By convention, the contents of any directory called
@filepath{private} are considered private and should not be relied
upon by external users of your package.}
@item{Extend the set of names exported by a module.}}
Currently these rules are guidelines only, but in the future some or
all of them may be enforced programmatically. Ultimately, though, no
technical device can precisely capture what it means for a package to
be backwards-compatible with a previous version, so you should use your
best judgment.
@subsection{Submit Your Package}
Go to @link["http://planet.plt-scheme.org/"]{the central PLaneT
package repository web page} and click on the link marked "contribute
a package / log in" in the upper-right-hand corner. If you have not
yet created an account, then do so on that page by providing your
name, a user name, an email address, and a password and then
responding to the confirmation message delivered to the email address
you provide.
Once you have an account, then if this is a new package then upload it
using the "Contribute a package" section in your user account page. If
this is a package update then click "update this package" next to its
name in the "Manage your packages" section of your user account page,
then upload the .plt file and indicate on the form whether your update
is backwards-compatible with the prior version or not.

290
collects/planet/planet.ss Normal file
View File

@ -0,0 +1,290 @@
(module planet mzscheme
#|
This module contains code that implements the `planet' command-line tool.
PLANNED FEATURES:
* Disable a package without removing it (disabling meaning
that if it's a tool it won't start w/ DrScheme, etc)
|#
(require mzlib/string
mzlib/file
(only mzlib/list sort)
net/url
mzlib/match
"config.ss"
"private/planet-shared.ss"
"private/command.ss"
"util.ss")
(define erase? (make-parameter #f))
(define displayer (make-parameter (λ () (show-installed-packages))))
(define (start)
(make-directory* (PLANET-DIR))
(make-directory* (CACHE-DIR))
(svn-style-command-line
#:program "planet"
#:argv (current-command-line-arguments)
"PLT Scheme PLaneT command-line tool. Provides commands to help you manipulate your local planet cache."
["create" "create a PLaneT archive from a directory"
"\nCreate a PLaneT archive in the current directory whose contents are the directory <path>."
#:once-each
[("-f" "--force") ("force a package to be created even if its info.ss file contains"
"errors.")
(force-package-building? #t)]
#:args (path)
(do-archive path)]
["install" "download and install a given package"
"
Download and install the package that
(require (planet \"file.ss\" (<owner> <pkg> <maj> <min>)))
would install"
#:args (owner pkg maj min)
(download/install owner pkg maj min)]
["remove" "remove the specified package from the local cache"
"
Remove the specified package from the local cache, optionally also removing its distribution file"
#:once-each
[("-e" "--erase")
("also remove the package's distribution file from the"
"uninstalled-package cache")
(erase? #t)]
#:args (owner pkg maj min)
((if (erase?) erase remove) owner pkg maj min)]
["show" "list the packages installed in the local cache"
"\nList the packages installed in the local cache"
#:once-any
[("-p" "--packages") "show packages only (default)" (displayer show-installed-packages)]
[("-l" "--linkage") "show linkage table only" (displayer show-linkage)]
[("-a" "--all") "show packages and linkage" (displayer (λ () (show-installed-packages) (newline) (show-linkage)))]
#:args ()
((displayer))]
["clearlinks" "clear the linkage table, allowing upgrades"
"\nClear the linkage table, allowing upgrades"
#:args ()
(unlink-all)]
["fileinject" "install a local file to the planet cache"
"
Install local file <plt-file> into the planet cache as though it had been downloaded from the planet server. The installed package has path
(planet (<owner> <plt-file's filename> <maj> <min>))"
#:args (owner plt-file maj min)
(install-plt-file plt-file owner maj min)]
["link" "create a development link"
"\nCreate a development link between the specified package specifier and the specified directory name"
#:args (owner pkg maj min path)
(add-hard-link-cmd owner pkg maj min path)]
["unlink" "remove development link associated with the given package"
"\nRemove development link associated with the given package"
#:args (owner pkg maj min)
(remove-hard-link-cmd owner pkg maj min)]
["fetch" "download a package file without installing it"
"\nDownload the given package file without installing it"
#:args (owner pkg maj min)
(download/no-install owner pkg maj min)]
["url" "get a URL for the given package"
"
Get a URL for the given package.
This is not necessary for normal use of planet, but may be helpful in some circumstances for retrieving packages."
#:args (owner pkg maj min)
(get-download-url owner pkg maj min)]
["open" "unpack the contents of the given package"
"
Unpack the contents of the given package into the given directory without installing.
This command is not necessary for normal use of planet. It is intended to allow you to inspect package contents offline without needing to install the package."
#:args (plt-file target)
(do-unpack plt-file target)]
["structure" "display the structure of a given .plt archive"
"\nPrint the structure of the PLaneT archive named by <plt-file> to the standard output port.
This command does not unpack or install the named .plt file."
#:args (plt-file)
(do-structure plt-file)]
["print" "display a file within of the given .plt archive"
"\nPrint the contents of the file named by <path>, which must be a relative path within the PLaneT archive named by <plt-file>, to the standard output port.
This command does not unpack or install the named .plt file."
#:args (plt-file path)
(do-display plt-file path)]
;; unimplemented so far:
#;(("-u" "--unlink")
module
"Remove all linkage the given module has, forcing it to upgrade"
...)))
;; ============================================================
;; FEATURE IMPLEMENTATIONS
(define (fail s . args)
(raise (make-exn:fail (apply format s args) (current-continuation-marks))))
(define (download/install owner name majstr minstr)
(let* ([maj (read-from-string majstr)]
[min (read-from-string minstr)]
[full-pkg-spec (get-package-spec owner name maj min)])
(when (get-package-from-cache full-pkg-spec)
(fail "No package installed (cache already contains a matching package)"))
(unless (download/install-pkg owner name maj min)
(fail "Could not find matching package"))))
(define (download/no-install owner pkg majstr minstr)
(let* ([maj (read-from-string majstr)]
[min (read-from-string minstr)]
[full-pkg-spec (get-package-spec owner pkg maj min)])
(when (file-exists? pkg)
(fail "Cannot download, there is a file named ~a in the way" pkg))
(match (download-package full-pkg-spec)
[(#t path maj min)
(copy-file path pkg)
(printf "Downloaded ~a package version ~a.~a\n" pkg maj min)]
[_
(fail "Could not find matching package")])))
;; params->full-pkg-spec : string string string string -> pkg
;; gets a full package specifier for the given specification
(define (params->full-pkg-spec ownerstr pkgstr majstr minstr)
(let ((maj (string->number majstr))
(min (string->number minstr)))
(unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0))
(fail "Invalid major/minor version"))
(let* ([fullspec (get-package-spec ownerstr pkgstr maj min)])
(unless fullspec (fail "invalid spec: ~a" fullspec))
fullspec)))
(define (install-plt-file filestr owner majstr minstr)
(unless (file-exists? filestr) (fail "File does not exist: ~a" filestr))
(let* ([file (normalize-path filestr)]
[name (let-values ([(base name dir?) (split-path file)]) (path->string name))]
[fullspec (params->full-pkg-spec owner name majstr minstr)])
(install-pkg fullspec file (pkg-spec-maj fullspec) (pkg-spec-minor-lo fullspec))))
(define (do-archive p)
(unless (directory-exists? p)
(fail "No such directory: ~a" p))
(make-planet-archive (normalize-path p)))
(define (remove owner pkg majstr minstr)
(let ((maj (string->number majstr))
(min (string->number minstr)))
(unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0))
(fail "Invalid major/minor version"))
(with-handlers ([exn:fail:planet? (λ (e) (fail (exn-message e)))])
(remove-pkg owner pkg maj min))))
(define (erase owner pkg majstr minstr)
(let ((maj (string->number majstr))
(min (string->number minstr)))
(unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0))
(fail "Invalid major/minor version"))
(with-handlers ([exn:fail:planet? (λ (e) (fail (exn-message e)))])
(erase-pkg owner pkg maj min))))
(define (show-installed-packages)
(let ([normal-packages (get-installed-planet-archives)]
[devel-link-packages (get-hard-linked-packages)])
(define (show-normals)
(printf "Normally-installed packages:\n")
(for-each
(lambda (l) (apply printf " ~a\t~a\t~a ~a\n" l))
(sort-by-criteria
(map (lambda (x) (match x [(_ owner pkg _ maj min) (list owner pkg maj min)])) normal-packages)
(list string<? string=?)
(list string<? string=?)
(list < =)
(list < =))))
(define (show-devel-links)
(printf "Development links:\n")
(for-each
(lambda (l) (apply printf " ~a\t~a\t~a ~a\n --> ~a\n" l))
(sort-by-criteria
(map
(lambda (x) (match x [(dir owner pkg _ maj min) (list owner pkg maj min (path->string dir))]))
devel-link-packages)
(list string<? string=?)
(list string<? string=?)
(list < =)
(list < =)
(list string<? string=?))))
(cond
[(and (pair? normal-packages) (pair? devel-link-packages))
(begin
(show-normals)
(newline)
(show-devel-links))]
[(pair? normal-packages) (show-normals)]
[(pair? devel-link-packages) (show-devel-links)]
[else (printf "No packages installed.\n")])))
(define (show-linkage)
(for-each
(lambda (module)
(printf " ~a:\n" (car module))
(for-each
(lambda (link) (apply printf " ~a\t~a\t~a ~a\n" link))
(cdr module)))
(sort (current-linkage) (lambda (a b) (string<? (car a) (car b))))))
(define (add-hard-link-cmd ownerstr pkgstr majstr minstr pathstr)
(let* ([maj (read-from-string majstr)]
[min (read-from-string minstr)]
[path (string->path pathstr)])
(unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0))
(fail "Invalid major/minor version"))
(add-hard-link ownerstr pkgstr maj min path)))
(define (remove-hard-link-cmd ownerstr pkgstr majstr minstr)
(let* ([maj (read-from-string majstr)]
[min (read-from-string minstr)])
(remove-hard-link ownerstr pkgstr maj min)))
(define (get-download-url ownerstr pkgstr majstr minstr)
(let ([fps (params->full-pkg-spec ownerstr pkgstr majstr minstr)])
(printf "~a\n" (url->string (pkg->download-url fps)))))
(define (do-unpack plt-file target)
(unless (file-exists? plt-file)
(fail (format "The specified file (~a) does not exist" plt-file)))
(let ([file (normalize-path plt-file)])
(unpack-planet-archive file target)))
(define (do-structure plt-file)
(unless (file-exists? plt-file)
(fail (format "The specified file (~a) does not exist" plt-file)))
(let ([file (normalize-path plt-file)])
(display-plt-file-structure file)))
(define (do-display plt-file file-to-print)
(unless (file-exists? plt-file)
(fail (format "The specified file (~a) does not exist" plt-file)))
(let ([file (normalize-path plt-file)])
(display-plt-archived-file file file-to-print)))
;; ------------------------------------------------------------
;; Utility
(define (sort-by-criteria l . criteria)
(sort l
(lambda (a b)
(let loop ((a a) (b b) (c criteria))
(cond
[(null? a) #f]
[((caar c) (car a) (car b)) #t]
[(not ((cadar c) (car a) (car b))) #f]
[else (loop (cdr a) (cdr b) (cdr c))])))))
;; ============================================================
;; start the program
(with-handlers ([exn:fail?
(lambda (e)
(fprintf (current-error-port) "~a\n" (exn-message e))
(exit 1))])
(start)))

129
collects/planet/private/command.ss Normal file
View File

@ -0,0 +1,129 @@
#lang scheme/base
(require "prefix-dispatcher.ss"
scheme/cmdline
(for-syntax scheme/base))
(provide svn-style-command-line)
;; implements an "svn-style" command-line interface as a wrapper around scheme/cmdline. At the moment,
;; it is light on error-checking and makes choices that are somewhat specific to the PLaneT commandline
;; tool, thus its inclusion in planet/private rather than somewhere more visible. The idea is that you
;; write
#|
(svn-style-command-line
#:program <name-of-the-program-string>
#:argv <argument vector, generally (current-command-line-arguments)>
<program-general-description string>
[<command1> <brief-help-string> <long-help-description-string>
... arguments just like the command-line macro takes, until ...
#:args formals
body-expr] ...)
|#
;; This macro turns that into a command-line type of thing that implements
;; program command1 ... args ...
;; program command2 ... args ...
;; etc.
;; It provides two nonobvious features:
;; 1. It automatically includes a help feature that prints out all available subcommands
;; 2. It automatically lets users use any unambiguous prefix of any command.
;; This means that no command name may be a prefix of any other command name, because it
;; would mean there was no way to unambiguously name the shorter one.
(define-syntax (svn-style-command-line stx)
(syntax-case stx ()
[(_ #:program prog
#:argv args
general-description
[name description long-description body ... #:args formals final-expr] ...)
(with-syntax ([(n ...) (generate-temporaries #'(name ...))])
#'(let* ([p prog]
[a args]
[n name] ...
[argslist (cond
[(list? a) a]
[(vector? a) (vector->list a)]
[else (error 'command "expected a vector or list for arguments, received ~e" a)])]
[help (λ () (display-help-message p general-description `((name description) ...)))])
(let-values ([(the-command remainder)
(if (null? argslist)
(values "help" '())
(values (car argslist) (cdr argslist)))])
(prefix-case the-command
[n
(command-line
#:program (format "~a ~a" p n)
#:argv remainder
body ...
#:handlers
(λ (_ . formals) final-expr)
(pimap symbol->string 'formals)
(λ (help-string)
(for-each (λ (l) (display l) (newline)) (wrap-to-count long-description 80))
(newline)
(display "Usage:\n")
(display help-string)
(exit)))] ...
["help" (help)]
[else (help)]))))]))
;; display-help-message : string (listof (list string string)) -> void
;; prints out the help message
(define (display-help-message prog general-description commands)
(let* ([maxlen (apply max (map (λ (p) (string-length (car p))) commands))]
[message-lines
`(,(format "Usage: ~a <subcommand> [option ...] <arg ...>" prog)
"[note: you can name a subcommand by typing any unambiguous prefix of it.]"
""
,@(wrap-to-count general-description 80)
""
"For help on a particular subcommand, type 'planet <subcommand> --help'"
"Available subcommands:"
,@(map (λ (command)
(let* ([padded-name (pad (car command) maxlen)]
[desc (cadr command)]
[msg (format " ~a ~a" padded-name desc)])
msg))
commands))])
(for-each (λ (line) (display line) (newline)) message-lines)))
;; ----------------------------------------
;; utility
;; pad : string nat[>= string-length str] -> string
;; pads the given string up to the given length.
(define (pad str n)
(let* ([l (string-length str)]
[extra (build-string (- n l) (λ (n) #\space))])
(string-append str extra)))
;; pimap : (A -> B) improper-listof A -> improper-listof B
(define (pimap f pil)
(cond
[(null? pil) '()]
[(pair? pil) (cons (pimap f (car pil))
(pimap f (cdr pil)))]
[else (f pil)]))
;; wrap-to-count : string nat -> (listof string)
;; breaks str into substrings such that no substring
;; is longer than n characters long. Only breaks on spaces, which
;; are eaten in the process.
(define (wrap-to-count str n)
(cond
[(< (string-length str) n) (list str)]
[(regexp-match-positions #rx"\n" str 0 n)
=>
(λ (posn)
(let-values ([(x y) (values (car (car posn)) (cdr (car posn)))])
(cons (substring str 0 x) (wrap-to-count (substring str y) n))))]
[else
;; iterate backwards from char n looking for a good break
(let loop ([k n])
(cond
[(= k 0) (error wrap-to-count "could not break string")]
[(char=? (string-ref str k) #\space)
(cons (substring str 0 k) (wrap-to-count (substring str (add1 k)) n))]
[else (loop (sub1 k))]))]))

37
collects/planet/private/data.ss Normal file
View File

@ -0,0 +1,37 @@
#lang scheme/base
(provide (all-defined-out))
; ==========================================================================================
; DATA
; defines common data used by the PLaneT system
; ==========================================================================================
; exn:i/o:protocol: exception indicating that a protocol error occured
(define-struct (exn:i/o:protocol exn:fail:network) ())
; FULL-PKG-SPEC : struct pkg-spec
(define-struct pkg-spec
(name ; string
maj ; (Nat | #f)
minor-lo ; (Nat | #f)
minor-hi ; (Nat | #f)
path ; (listof string)
stx ; (syntax | #f)
core-version ; string
)
#:transparent)
; PKG : string (listof string) Nat Nat path ORIGIN
(define-struct pkg (name route maj min path origin))
; UNINSTALLED-PKG : path FULL-PKG-SPEC Nat Nat
(define-struct uninstalled-pkg (path spec maj min))
; PKG-PROMISE : PKG | UNINSTALLED-PKG
; ORIGIN : 'normal | 'development-link
(define (pkg-promise? p) (or (pkg? p) (uninstalled-pkg? p)))
(define (normally-installed-pkg? p)
(eq? (pkg-origin p) 'normal))
(define (development-link-pkg? p)
(eq? (pkg-origin p) 'development-link))

11
collects/planet/private/define-config.ss Normal file
View File

@ -0,0 +1,11 @@
(module define-config mzscheme
(provide define-parameters)
(define-syntax (define-parameters stx)
(syntax-case stx ()
[(_ (name val) ...)
(andmap identifier? (syntax-e #'(name ...)))
#'(begin
(provide name ...)
(define name (make-parameter val)) ...)])))

141
collects/planet/private/linkage.ss Normal file
View File

@ -0,0 +1,141 @@
(module linkage mzscheme
(require "planet-shared.ss"
"../config.ss"
mzlib/match)
(provide get/linkage
get-linkage
add-linkage!
remove-linkage-to!
remove-all-linkage!)
; ==========================================================================================
; PHASE 1: LINKAGE
; The first check is to see if there is a valid linkage for the module.
; ==========================================================================================
;; get/linkage : pkg-getter [see ../resolver.ss]
;; getter for the linkage table
(define (get/linkage rmp pkg-specifier success-k failure-k)
(let ([linked-pkg (get-linkage rmp pkg-specifier)])
(if linked-pkg
(success-k linked-pkg)
(failure-k
void
(λ (pkg) (add-linkage! rmp pkg-specifier pkg))
(λ (x) x)))))
;; NOTE :: right now we have a nasty situation with the linkage-table: it doesn't associate
;; keys to packages, which it seems it should. Instead it associates keys to the arguments
;; to the pkg-spec constructor; this is done to facilitate reading the data from disk but
;; causes ugliness in add-linkage! where we have the actual package but have to break it down
;; so the arguments needed to reconstitute it can be stored.
; LINKAGE-TABLE ::= hash-table[LINKAGE-KEY -> PKG-LOCATION]
(define LT #f)
; get-linkage-table : -> hash-table[LINKAGE-KEY -> PKG-LOCATION]
(define (get-linkage-table)
(unless (file-exists? (LINKAGE-FILE)) (with-output-to-file (LINKAGE-FILE) newline))
(unless LT (set! LT (build-hash-table (with-input-from-file (LINKAGE-FILE) read-all))))
LT)
; add-linkage! : (resolved-module-path | #f) FULL-PKG-SPEC PKG -> PKG
; unless the first argument is #f, associates the pair of the first two arguments
; with the last in the linkage table. Returns the given package-location
(define (add-linkage! rmp pkg-spec pkg)
(when rmp
(let ((key (get-key rmp pkg-spec)))
(hash-table-get
(get-linkage-table)
key
(lambda ()
(let ((plist (pkg-as-list pkg)))
(begin
(hash-table-put! (get-linkage-table) key plist)
(with-output-to-file (LINKAGE-FILE)
(lambda () (write (list key plist)))
'append)))))))
pkg)
;; remove-linkage! pkg-spec -> void
;; eliminates linkage to the given package
(define (remove-linkage-to! pkg)
(let ((l (get-linkage-table)))
;; first remove bad entries from the in-memory hash table
(hash-table-for-each
l
(lambda (k v)
(match v
[(name route maj min _)
(when (and (equal? name (pkg-name pkg))
(equal? route (pkg-route pkg))
(= maj (pkg-maj pkg))
(= min (pkg-min pkg)))
(hash-table-remove! l k))]
[_ (void)])))
;; now write the new table out to disk to keep it in sync
(with-output-to-file (LINKAGE-FILE)
(lambda ()
(printf "\n")
(hash-table-for-each
l
(lambda (k v) (write (list k v)))))
'truncate/replace)))
;; kill the whole linkage-table
(define (remove-all-linkage!)
(with-output-to-file (LINKAGE-FILE)
(lambda () (printf "\n"))
'truncate/replace)
(set! LT #f))
;; pkg-as-list : PKG -> (list string string nat nat bytes[path])
(define (pkg-as-list pkg)
(list (pkg-name pkg)
(pkg-route pkg)
(pkg-maj pkg)
(pkg-min pkg)
(path->bytes (pkg-path pkg))))
; get-linkage : (resolved-module-path | #f) FULL-PKG-SPEC -> PKG | #f
; returns the already-linked module location, or #f if there is none
(define (get-linkage rmp pkg-specifier)
(cond
[rmp
(let ((pkg-fields (hash-table-get
(get-linkage-table)
(get-key rmp pkg-specifier)
(lambda () #f))))
(if pkg-fields
(with-handlers ([exn:fail? (lambda (e) #f)])
(match-let ([(name route maj min pathbytes) pkg-fields])
(make-pkg name route maj min (bytes->path pathbytes))))
#f))]
[else #f]))
; get-key : resolved-module-path? FULL-PKG-SPEC -> LINKAGE-KEY
; produces a linkage key for the given pair.
(define (get-key rmp pkg-spec)
(list* (get-module-id rmp)
(pkg-spec-name pkg-spec)
(pkg-spec-maj pkg-spec)
(pkg-spec-minor-lo pkg-spec)
(pkg-spec-minor-hi pkg-spec)
(pkg-spec-path pkg-spec)))
; get-module-id : resolved-module-path? -> LINKAGE-MODULE-KEY
; key suitable for marshalling that represents the given resolved-module-path
(define (get-module-id rmp)
(path->string (resolved-module-path-name rmp)))
)

582
collects/planet/private/planet-shared.ss Normal file
View File

@ -0,0 +1,582 @@
#| planet-shared.ss -- shared client/server utility functions
Various common pieces of code that both the client and server need to access
==========================================================================================
|#
#lang scheme/base
(require (only-in mzlib/file path-only)
mzlib/port
setup/getinfo
(prefix-in srfi1: srfi/1)
"../config.ss"
"data.ss")
(provide (all-defined-out)
(all-from-out "data.ss"))
; ==========================================================================================
; CACHE LOGIC
; Handles checking the cache for an appropriate module
; ==========================================================================================
; language-version->repository : string -> string | #f
; finds the appropriate language version for the given repository
(define (language-version->repository ver)
(cond
[(regexp-match #rx"^20.+" ver) "207.1"]
[(regexp-match #rx"(^3..+)|(^29.+)" ver) "300"]
[else #f]))
(define (version->description ver)
(cond
[(string=? ver "207.1") "20x"]
[(string=? ver "300") "299.x-3xx"]
[else (error 'version->description "Expected one of 207.1 and 300, got ~a" ver)]))
(define (legal-language? l)
(and (language-version->repository l) #t))
; lookup-package : FULL-PKG-SPEC [path (optional)] -> PKG | #f
; returns the directory pointing to the appropriate package in the cache, the user's hardlink table,
; or #f if the given package isn't in the cache or the hardlink table
(define lookup-package
(case-lambda
[(pkg) (lookup-package pkg (CACHE-DIR))]
[(pkg dir)
(let* ((at (build-assoc-table pkg dir)))
(get-best-match at pkg))]))
;; lookup-package-by-keys : string string nat nat nat -> (list path string string (listof string) nat nat) | #f
;; looks up and returns a list representation of the package named by the given owner,
;; package name, major and (exact) minor version.
;; this function is intended to be useful for setup-plt and other applications that need to know where planet
;; packages live
(define (lookup-package-by-keys owner name maj min-lo min-hi)
(let ([result
(lookup-package
(make-pkg-spec
name
maj
min-lo
min-hi
(list owner)
#f
(version)))])
(if result
(list (pkg-path result)
(car (pkg-route result))
(pkg-name result)
(cdr (pkg-route result))
(pkg-maj result)
(pkg-min result))
#f)))
; build-assoc-table : FULL-PKG-SPEC path -> assoc-table
; returns a version-number -> directory association table for the given package
(define (build-assoc-table pkg dir)
(add-to-table
(pkg->assoc-table pkg dir)
(hard-links pkg)))
;; assoc-table ::= (listof (list n n path))
(define empty-table '())
;; get-min-core-version : path -> string | #f
(define (get-min-core-version p)
(let ((info (with-handlers ([exn:fail? (lambda (e) #f)])
(get-info/full p))))
(if info
(let ((core (info 'required-core-version (lambda () #f))))
(if (and core (string? core))
core
#f))
#f)))
; pkg->assoc-table : FULL-PKG-SPEC path -> assoc-table
; returns the on-disk packages for the given planet package in the
; on-disk table rooted at the given directory
(define (pkg->assoc-table pkg dir)
(define path (build-path (apply build-path dir (pkg-spec-path pkg)) (pkg-spec-name pkg)))
(define (tree-stuff->row-or-false p majs mins)
(let ((maj (string->number majs))
(min (string->number mins)))
(if (and (path? p) maj min)
(let* ((the-path (build-path path majs mins))
(min-core-version (get-min-core-version the-path)))
(make-assoc-table-row
(pkg-spec-name pkg)
(pkg-spec-path pkg)
maj min
the-path
min-core-version
'normal))
#f)))
(if (directory-exists? path)
(filter
(λ (x) x)
(tree-apply
tree-stuff->row-or-false
(directory->tree path (λ (x) #t) 2 (λ (x) x))))
empty-table))
; the link table format:
; (listof (list string[name] (listof string[path]) num num bytes[directory] (union string[mzscheme version] #f))
; hard-links : FULL-PKG-SPEC -> (listof assoc-table-row)
(define (hard-links pkg)
(filter
(λ (row)
(and (equal? (assoc-table-row->name row) (pkg-spec-name pkg))
(equal? (assoc-table-row->path row) (pkg-spec-path pkg))))
(get-hard-link-table)))
;; verify-well-formed-hard-link-parameter! : -> void
;; pitches a fit if the hard link table parameter isn't set right
(define (verify-well-formed-hard-link-parameter!)
(unless (and (absolute-path? (HARD-LINK-FILE)) (path-only (HARD-LINK-FILE)))
(raise (make-exn:fail:contract
(format
"The HARD-LINK-FILE setting must be an absolute path name specifying a file; given ~s"
(HARD-LINK-FILE))
(current-continuation-marks)))))
;; get-hard-link-table : -> assoc-table
(define (get-hard-link-table)
(verify-well-formed-hard-link-parameter!)
(if (file-exists? (HARD-LINK-FILE))
(map (lambda (item) (update/create-element 6 (λ (_) 'development-link) (update-element 4 bytes->path item)))
(with-input-from-file (HARD-LINK-FILE) read-all))
'()))
;; row-for-package? : row string (listof string) num num -> boolean
;; determines if the row associates the given package with a dir
(define (points-to? row name path maj min)
(and (equal? name (assoc-table-row->name row))
(equal? path (assoc-table-row->path row))
(equal? maj (assoc-table-row->maj row))
(equal? min (assoc-table-row->min row))))
;; row->package : assoc-table-row -> PKG | #f
(define (row->package row)
(get-installed-package
(car (assoc-table-row->path row)) ;; owner
(assoc-table-row->name row)
(assoc-table-row->maj row)
(assoc-table-row->min row)))
;; save-hard-link-table : assoc-table -> void
;; saves the given table, overwriting any file that might be there
(define (save-hard-link-table table)
(verify-well-formed-hard-link-parameter!)
(with-output-to-file (HARD-LINK-FILE) #:exists 'truncate
(lambda ()
(display "")
(for-each
(lambda (row)
(write (update-element 4 path->bytes row))
(newline))
table))))
;; add-hard-link! string (listof string) num num path -> void
;; adds the given hard link, clearing any previous ones already in place
;; for the same package
(define (add-hard-link! name path maj min dir)
(let ([complete-dir (path->complete-path dir)])
(let* ([original-table (get-hard-link-table)]
[new-table (cons
(make-assoc-table-row name path maj min complete-dir #f 'development-link)
(filter
(lambda (row) (not (points-to? row name path maj min)))
original-table))])
(save-hard-link-table new-table))))
;; filter-link-table! : (row -> boolean) -> void
;; removes all rows from the hard link table that don't match the given predicate.
;; also updates auxiliary datastructures that might have dangling pointers to
;; the removed links
(define (filter-link-table! f on-delete)
(let-values ([(in-links out-links) (srfi1:partition f (get-hard-link-table))])
(for-each on-delete out-links)
(save-hard-link-table in-links)))
;; update-element : number (x -> y) (listof any [x in position number]) -> (listof any [y in position number])
(define (update-element n f l)
(cond
[(null? l) (error 'update-element "Index too large")]
[(zero? n) (cons (f (car l)) (cdr l))]
[else (cons (car l) (update-element (sub1 n) f (cdr l)))]))
(define (update/create-element n f l)
(cond
[(and (null? l) (zero? n))
(list (f #f))]
[(and (null? l) (not (zero? n)))
(error 'update/create-element "Index too large")]
[(and (not (null? l)) (zero? n))
(cons (f (car l)) (cdr l))]
[else (cons (car l) (update/create-element (sub1 n) f (cdr l)))]))
; add-to-table assoc-table (listof assoc-table-row) -> assoc-table
(define add-to-table append)
;; first-n-list-selectors : number -> (values (listof x -> x) ...)
;; returns n list selectors for the first n elements of a list
;; (useful for defining meaningful names to list-structured data)
(define (first-n-list-selectors n)
(apply values (build-list n (lambda (m) (lambda (row) (list-ref row m))))))
;; assoc-table-row->{name,path,maj,min,dir,required-version}
;; : assoc-table-row ->
;; {string,(listof string),num,num,path,string|#f}
;; retrieve the {package name, "package path", major version, minor version, directory, required core version}
;; of the given row
(define-values (assoc-table-row->name
assoc-table-row->path
assoc-table-row->maj
assoc-table-row->min
assoc-table-row->dir
assoc-table-row->required-version
assoc-table-row->type)
(first-n-list-selectors 7))
(define (make-assoc-table-row name path maj min dir required-version type)
(list name path maj min dir required-version type))
(define-struct mz-version (major minor) #:inspector #f)
;; string->mz-version : string -> mz-version | #f
;; Converts a string into mz-version. We need to account
;; for the change in numbering style from the 372 era to the 4.0 era.
(define (string->mz-version str)
(define (minor+maint-chunks->minor chunks)
(+ (* (string->number (car chunks)) 1000)
(if (> (length chunks) 1)
(string->number (cadr chunks))
0)))
(cond
;; Old style numbering with three digits in front. The first digit
;; goes up to three.
[(regexp-match #rx"^([0-3][0-9][0-9])\\.?([.0-9]*)$" str)
=>
(lambda (ver)
(let ([major (string->number (list-ref ver 1))])
(cond
[(= (string-length (list-ref ver 2)) 0)
(make-mz-version major 0)]
[else
(let* ([minor+maint (regexp-split #rx"\\." (list-ref ver 2))]
[minor (minor+maint-chunks->minor minor+maint)])
(make-mz-version major minor))])))]
;; New style numbering
[(regexp-match #rx"^([0-9]+)(\\.([.0-9]+))?$" str)
=>
(lambda (ver)
(cond [(list-ref ver 3)
(let* ([chunks (regexp-split #rx"\\." (list-ref ver 3))])
(and (andmap (λ (x) (not (equal? x ""))) chunks)
(make-mz-version (+ (* (string->number (list-ref ver 1))
100)
(if (> (length chunks) 0)
(begin
(string->number (car chunks)))
0))
(if (> (length (cdr chunks)) 0)
(minor+maint-chunks->minor (cdr chunks))
0))))]
[else
(make-mz-version (* (string->number (list-ref ver 1))
100)
0)]))]
[else #f]))
;; version<= : mz-version mz-version -> boolean
;; determines if a is the version string of an earlier mzscheme release than b
;; [n.b. this relies on a guarantee from Matthew that mzscheme version
;; x1.y1 is older than version x2.y2 iff x1<x2 or x1=x2 and y1<y2]
(define (version<= a b)
(or (<= (mz-version-major a) (mz-version-major b))
(and (= (mz-version-major a) (mz-version-major b))
(<= (mz-version-minor a) (mz-version-minor b)))))
;; pkg< : pkg pkg -> boolean
;; determines if a is an earlier version than b
;; [only sensical if a and b are versions of the same package]
(define (pkg< a b)
(or (< (pkg-maj a) (pkg-maj b))
(and (= (pkg-maj a) (pkg-maj b))
(< (pkg-min a) (pkg-min b)))))
(define (pkg> a b)
(pkg< b a))
(define (pkg= a b)
(not (or (pkg< a b) (pkg> a b))))
;; compatible-version? : assoc-table-row FULL-PKG-SPEC -> boolean
;; determines if the given package constrint verstr can support the given package
(define (compatible-version? row spec)
(let ((required-version (assoc-table-row->required-version row)))
(or (not required-version)
(let ((required (string->mz-version required-version))
(provided (string->mz-version (pkg-spec-core-version spec))))
(or (not required)
(not provided)
(version<= required provided))))))
; get-best-match : assoc-table FULL-PKG-SPEC -> PKG | #f
; return the best on-disk match for the given package spec
(define (get-best-match table spec)
(if (null? table)
#f
(let* ((target-maj
(or (pkg-spec-maj spec)
(apply max (map assoc-table-row->maj table))))
(lo (pkg-spec-minor-lo spec))
(hi (pkg-spec-minor-hi spec))
(matches
(filter
(λ (x)
(let ((n (assoc-table-row->min x)))
(and
(equal? target-maj (assoc-table-row->maj x))
(or (not lo) (>= n lo))
(or (not hi) (<= n hi))
(compatible-version? x spec))))
table)))
(if (null? matches)
#f
(let ((best-row
(car
(sort
matches
(λ (a b) (> (assoc-table-row->min a) (assoc-table-row->min b)))))))
(make-pkg
(pkg-spec-name spec)
(pkg-spec-path spec)
(assoc-table-row->maj best-row)
(assoc-table-row->min best-row)
(assoc-table-row->dir best-row)
(assoc-table-row->type best-row)))))))
;; get-installed-package : string string nat nat -> PKG | #f
;; gets the package associated with this package specification, if any
(define (get-installed-package owner name maj min)
(lookup-package (make-pkg-spec name maj min min (list owner) #f (version))))
; ==========================================================================================
; UTILITY
; Miscellaneous utility functions
; ==========================================================================================
; make-cutoff-port : input-port nat [nat -> tst] -> input-port
; makes a new input port that reads the first n characters from the given port, then
; returns eof. If n characters are not available from the given input port, calls
; the given function and then returns eof
(define make-cutoff-port
(lambda (ip n [underflow-fn void])
(let ((to-read n))
(make-input-port
'cutoff-port
(lambda (bytestr)
(cond
[(= to-read 0) eof]
[else
(let ((bytes-read (read-bytes-avail! bytestr ip 0 (min n (bytes-length bytestr)))))
(if (eof-object? bytes-read)
(begin
(underflow-fn (- to-read bytes-read))
(set! to-read 0)
eof)
(begin
(set! to-read (- to-read bytes-read))
bytes-read)))]))
#f
void))))
; write-line : X output-port -> void
; writes the given value followed by a newline to the given port
(define (write-line obj p)
(write obj p)
(newline p))
; for-each/n (X Nat -> Y) (listof X) -> void
; calls the input function on each element of the input list in order,
; also providing the element's zero-based index in the list
(define (for-each/n f l)
(let loop ((l l) (n 0))
(cond
[(null? l) (void)]
[else
(f (car l) n)
(loop (cdr l) (add1 n))])))
; nat? : TST -> bool
; determines if the given scheme value is a natural number
(define (nat? obj) (and (integer? obj) (>= obj 0)))
; read-n-chars-to-file : Nat input-port string[filename] -> void
; copies exactly n chars to the given file from the given port. Raises an exception
; if the given number of characters are not available.
(define (read-n-chars-to-file n ip file)
(let ((op (open-output-file file #:exists 'truncate)))
(copy-n-chars n ip op)
(close-output-port op)))
; copy-n-chars : Nat input-port output-port -> void
; copies exactly n characters from the input to the output. Raises an exception
; if this is not possible.
(define (copy-n-chars n ip op)
(let ((cport (make-cutoff-port ip
n
(lambda ()
(raise
(make-exn:fail:read:eof
(format "Not enough chars on input (expected ~a, got ~a)"
n
(- n 0))
(current-continuation-marks)
ip))))))
(copy-port cport op)))
; repeat-forever : (-> void) -> [diverges]
; repeatedly invokes the given thunk forever
(define (repeat-forever thunk) (let loop () (thunk) (loop)))
; build-hash-table : listof (list X Y) -> equal-hash-table[X -> Y]
; builds a new hash-table mapping all given X's to their appropriate Y values
(define (build-hash-table asl)
(let ((ht (make-hash)))
(for-each (lambda (item) (hash-set! ht (car item) (cadr item))) asl)
ht))
; categorize : (X -> Y) (listof X) -> (listof (cons Y (listof X)))
; sorts the l into categories given by f
(define (categorize f l)
(let ((ht (make-hash)))
(for-each
(lambda (i)
(let ((key (f i)))
(hash-set! ht key (cons i (hash-ref ht key (lambda () '()))))))
l)
(hash-map ht cons)))
(define (drop-last l) (reverse (cdr (reverse l))))
;; note: this can be done faster by reading a copy-port'ed port with
;; ( and ) tacked around it
(define read-all
(case-lambda
[() (read-all (current-input-port))]
[(ip)
(let ((sexpr (read ip)))
(cond
[(eof-object? sexpr) '()]
[else (cons sexpr (read-all ip))]))]))
(define (wrap x) (begin (write x) (newline) x))
(define (with-logging logfile f)
(let* ((null-out (open-output-nowhere))
(outport
(if logfile
(with-handlers ((exn:fail:filesystem? (lambda (e) null-out)))
(open-output-file logfile #:exists 'append))
null-out)))
(parameterize ([current-output-port outport])
(f))))
;; pkg->info : PKG -> (symbol (-> TST) -> TST)
;; get an info.ss thunk for the given package
(define (pkg->info p)
(or
(with-handlers ([exn:fail? (lambda (e) #f)])
(get-info/full (pkg-path p)))
(lambda (s thunk) (thunk))))
;; ============================================================
;; TREE STUFF
;; ============================================================
;; tree[X] ::= (make-branch X (listof tree[X])
(define-struct branch (node children) #:transparent)
(define-struct (exn:fail:filesystem:no-directory exn:fail:filesystem) (dir))
;; directory->tree : directory (string -> bool) [nat | bool] [path->X] -> tree[X] | #f
(define directory->tree
(lambda (directory valid-dir? [max-depth #f] [path->x path->string])
(unless (directory-exists? directory)
(raise (make-exn:fail:filesystem:no-directory
"Directory ~s does not exist"
(current-continuation-marks)
directory)))
(let-values ([(path name _) (split-path directory)])
(let* ((files (directory-list directory))
(files (map (lambda (d) (build-path directory d)) files))
(files (filter (lambda (d) (and (directory-exists? d) (valid-dir? d))) files)))
(make-branch
(path->x name)
;; NOTE: the above line should not use path->string. I don't have time to track this down though
(if (equal? max-depth 0)
'()
(let ((next-depth (if max-depth (sub1 max-depth) #f)))
(map (lambda (d) (directory->tree d valid-dir? next-depth)) files))))))))
;; filter-pattern : (listof pattern-term)
;; pattern-term : (x -> y) | (make-star (tst -> bool) (x -> y))
(define-struct star (pred fun))
;; filter-tree-by-pattern : tree[x] filter-pattern -> tree[y]
;; constraint: depth of the tree <= length of the list
;; converts the tree by applying to each depth the function at that position in the list
(define (filter-tree-by-pattern tree pattern)
(cond
[(null? pattern) (error 'filter-tree-by-pattern "Tree too deep: ~e" tree)]
[(star? (car pattern))
(if (star-pred (car pattern))
(make-branch
(star-fun (branch-node tree))
(map (lambda (x) (filter-tree-by-pattern x pattern))
(branch-children tree)))
(filter-tree-by-pattern tree (cdr pattern)))]
[else
(make-branch ((car pattern) (branch-node tree))
(map
(lambda (x) (filter-tree-by-pattern x (cdr pattern)))
(branch-children tree)))]))
;; sexp-tree[x] ::= (cons x (listof sexp-tree[x]))
;; tree-apply : (... -> tst) tree -> listof tst
;; applies f to every path from root to leaf and
;; accumulates all results in a list
(define tree-apply
(lambda (f t [depth 0])
(let loop ((t t)
(priors '())
(curr-depth 0))
(cond
[(null? (branch-children t))
(if (> curr-depth depth)
(list (apply f (reverse (cons (branch-node t) priors))))
'())]
[else
(let ((args (cons (branch-node t) priors)))
(apply append
(map (lambda (x) (loop x args (add1 curr-depth))) (branch-children t))))]))))
;; tree->list : tree[x] -> sexp-tree[x]
(define (tree->list tree)
(cons (branch-node tree) (map tree->list (branch-children tree))))

128
collects/planet/private/prefix-dispatcher.ss Normal file
View File

@ -0,0 +1,128 @@
#lang scheme/base
(require (for-syntax scheme/base))
(provide (all-defined-out))
;; ============================================================
;; PREFIX DISPATCHER
;; Code to determine the entry specified by an arbitrary
;; (unambiguous) prefix of a set of possible entries
(define-struct (exn:prefix-dispatcher exn:fail) ())
(define-struct (exn:unknown-command exn:prefix-dispatcher) (entry))
(define-struct (exn:ambiguous-command exn:prefix-dispatcher) (possibilities))
;; get-prefix-dispatcher : (listof (list string A)) -> string -> A
;; gets the
(define (get-prefix-dispatcher options)
;; implementation strategy is dumb regexp-filter. It is possible to do a trie or something fancy like that,
;; but it would cost more to build than it would be worth, and we're only expecting lists of a few items anyway
(let ([pre/full (get-prefix-and-suffix (map car options))])
(when pre/full
(error 'get-prefix-dispatcher "No element may be a strict prefix of any other element; given ~a and ~a"
(car pre/full)
(cadr pre/full))))
(λ (target)
(let* ([re (format "^~a" (regexp-quote target))]
[matches (filter (λ (x) (regexp-match re (car x))) options)])
(cond
[(length=? matches 1) (cadr (car matches))]
[(null? matches)
(raise (make-exn:unknown-command (format "Unknown command: ~a" target)
(current-continuation-marks)
target))]
[else
(raise (make-exn:ambiguous-command (format "Ambiguous command: ~a" target)
(current-continuation-marks)
(map car matches)))]))))
;; length=? : list nat -> boolean
;; determines if the given list has the given length. Running time is proportional
;; to the shorter of the magnitude of the number or the actual length of the list
(define (length=? lst len)
(cond
[(and (null? lst) (zero? len)) #t]
[(null? lst) #f]
[(zero? len) #f]
[else (length=? (cdr lst) (sub1 len))]))
;; get-prefix-and-suffix : (listof string) -> (list string string) | #f
;; returns a pair of strings in the given list such that the first string is a prefix of the second,
;; or #f if no such pair exists
(define (get-prefix-and-suffix strs)
(cond
[(null? strs) #f]
[else
(sorted-nelist-contains-prefix? (sort strs string<?))]))
;; sorted-nelist-contains-prefix? : (nonempty-listof string) -> (list string string) | #f
;; given a lexicographically-sorted, nonempty list of strings, returns either
;; two strings from the list such that the first is a prefix of the second, or #f if
;; no such pair exists
(define (sorted-nelist-contains-prefix? nel)
(cond
[(null? (cdr nel)) #f]
[(prefix? (car nel) (cadr nel))
(list (car nel) (cadr nel))]
[else (sorted-nelist-contains-prefix? (cdr nel))]))
;; prefix? : string string -> boolean
;; determins if s1 is a prefix of s2
(define (prefix? s1 s2)
(and (<= (string-length s1) (string-length s2))
(string=? s1 (substring s2 0 (string-length s1)))))
(define-syntax (prefix-case stx)
(define (else? stx)
(syntax-case stx (else)
[(else clause) #t]
[_ #f]))
(define (amb? stx)
(syntax-case stx (ambiguous)
[(ambiguous (name) body) #t]
[_ #f]))
(define (extract-clause name options transformer default)
(case (length options)
[(0) default]
[(1) (transformer (car options))]
[else
(raise-syntax-error #f (format "only 1 ~a clause is allowed" name) stx (list-ref options 1))]))
(define (else-clause->body c)
(syntax-case c (else)
[(else body) #'body]
[_ (raise-syntax-error #f "malformed else clause" stx c)]))
(define (amb-clause->body c)
(syntax-case c (ambiguous)
[(ambiguous (name) body) #'(λ (name) body)]
[_ (raise-syntax-error #f "malformed ambiguous clause" stx c)]))
(syntax-case stx ()
[(_ elt
clause ...)
(let* ([clauses (syntax-e #'(clause ...))]
[else-clauses (filter else? clauses)]
[amb-clauses (filter amb? clauses)]
[rest (filter (λ (x) (not (or (else? x) (amb? x)))) clauses)]
[else (extract-clause "else" else-clauses else-clause->body
#'(error 'prefix-case "element ~e was not a prefix" e))]
[amb (extract-clause "ambiguous" amb-clauses amb-clause->body
#'(λ (opts) (error 'prefix-case "element matches more than one option: ~s" opts)))])
(with-syntax ([else-clause else]
[amb-clause amb]
[((option result) ...) rest])
#'(with-handlers ([exn:ambiguous-command?
(λ (e) (amb-clause (exn:ambiguous-command-possibilities e)))]
[exn:unknown-command?
(λ (e) else-clause)])
(((get-prefix-dispatcher (list (list option (λ () result)) ...))
elt)))))]))

112
collects/planet/private/short-syntax-helpers.ss Normal file
View File

@ -0,0 +1,112 @@
#lang scheme/base
(provide (all-defined-out))
;; specialized version of haskell do notation for the particular parsing monad i'm using
(define-syntax try-parsing
(syntax-rules ()
[(_ v () body) (body v)]
[(_ v ([expr] clause ...) body)
(let-values ([(dummy rest) (expr v)])
(try-parsing rest (clause ...) body))]
[(_ v ([id expr] clause ...) body)
(let-values ([(id rest) (expr v)])
(try-parsing rest (clause ...) body))]))
;; get-next-fragment : regexp -> [#:on-error (string -> a)] -> string -> (union (values string string) a)
;; helper for the below two functions
(define (((get-next-fragment rx) #:on-error [error-action (λ (s) (values #f s))]) str)
(let ([thematch (regexp-match rx str)])
(cond
[(not thematch) (error-action str)]
[else
(let ([this (list-ref thematch 1)]
[rest (list-ref thematch 2)])
(values this rest))])))
;; get-next-slash : [#:on-error (string -> a)] -> string -> (union (values string string) a)
;; splits the given string into the nonempty substring before the first slash and the substring after it
;; on failure returns whatever the given #:on-error function returns when given the entire string
(define consume-whitespace (get-next-fragment #rx"^([ ]*)(.*)$"))
(define get-next-slash (get-next-fragment #rx"^([^/]+)/(.*)$"))
(define get-next-slash-or-end (get-next-fragment #rx"^([^/ ]+)/? ?(.*)$"))
;; get-to-next-colon-or-end : [#:on-error (string -> a)] -> string -> (union (values string string) a)
;; splits the given string into the nonempty substring before the initial : and the substring after it, or
;; (values [initial-string] "") if the given string has no : in it.
(define get-to-next-colon-or-end (get-next-fragment #rx"^([^:]+):?(.*)$"))
;; parse-package : string (string -> 'a) -> (values string nat min-spec)
;; given a package specifier, returns the package name, the package major version, and a descriptor
;; for the acceptible minor versions
(define (parse-package package yell)
(try-parsing package
([pkgname (get-to-next-colon-or-end)]
[maj (get-to-next-colon-or-end)])
(λ (min)
(values (parse-pkgname pkgname yell)
(parse-majspec maj yell)
(parse-minspec min yell)))))
;; parse-pkgname : string (string -> 'a) -> string
;; given a literal package name string as it would appear in shorthand syntax, returns
;; a fully-embellished name for the package being specified. yell is provided as a function
;; to call to generate an error message if something goes wrong
(define (parse-pkgname pn yell)
(let ([m (regexp-match #rx"\\.plt$" pn)])
(if m pn (string-append pn ".plt"))))
;; parse-majspec : (#f (string -> 'a) -> #f) intersect (string (string -> 'a) -> number)
;; given the literal major version string (or #f) returns the major version corresponding
;; to that string. yell is the function to call with an error message if something goes wrong
(define (parse-majspec majstr yell)
(cond
[(not majstr) #f]
[else
(cond
[(and (regexp-match #rx"^[0-9]+$" majstr))
(let ([n (string->number majstr)])
(if (> n 0)
n
(yell (format "Illegal major version specifier; expected version number greater than 0, received ~e"
majstr))))]
[else
(yell (format "Illegal major version specifier; expected positive integer, received ~e" majstr))])]))
;; regexp-case : SYNTAX
;; provides a case operation for trying different regular expressions in sequence on a test string,
;; stoppingas soon as one of those expressions matches the string. If one does, then all the
;; parenthesized subparts are bound to names in the right-hand side of the corresponding clause
(define-syntax regexp-case
(syntax-rules ()
[(_ str clause ...)
(let ([s str])
(regexp-case* s clause ...))]))
(define-syntax regexp-case*
(syntax-rules (else)
[(_ str [else body] c ...)
body]
[(_ str [re ([id ...] body)] c ...)
(let ([args (regexp-match re str)])
(if args
(let-values ([(id ...) (apply values (cdr args))]) body)
(regexp-case* str c ...)))]))
;; parse-minspec : string (string -> 'a) -> min-spec
;; returns the minor-version specification corresponding to the given string as an s-expression.
;; yell is the function to call if the string doesn't correspond to minor-version spec.
(define (parse-minspec minstr yell)
(cond
[(not minstr) #f]
[else
(regexp-case minstr
[#rx"^>=([0-9]+)$" ((n) `(+ ,(string->number n)))]
[#rx"^<=([0-9]+)$" ((n) `(- ,(string->number n)))]
[#rx"^=([0-9]+)$" ((n) `(= ,(string->number n)))]
[#rx"^([0-9]+)-([0-9]+)$" ((m n) `(,(string->number m) ,(string->number n)))]
[#rx"^([0-9]+)$" ((n) (string->number n))]
[#rx"^$" (() #f)] ;; here for convenience reasons. a bit gross, i know
[else
(yell (format "Illegal minor version specifier; expected <=n, >=n, =n, n-m, or n, where n, m are positive integers; received ~e"
minstr))])]))

38
collects/planet/private/test.ss Normal file
View File

@ -0,0 +1,38 @@
#lang scheme
(require "planet-shared.ss")
(define-syntax (test stx)
(syntax-case stx ()
[(_ a b)
(with-syntax ([line (syntax-line stx)]
[file (let ([s (syntax-source stx)])
(if (string? s)
s
"<<unknown file>>"))])
#`(test/proc file line a b))]))
(define (test/proc file line got expected)
(unless (equal? got expected)
(error 'test.ss "FAILED ~a: ~s\n got ~s\nexpected ~s" file line got expected)))
(test (string->mz-version "372")
(make-mz-version 372 0))
(test (string->mz-version "372.2")
(make-mz-version 372 2000))
(test (string->mz-version "4.0")
(make-mz-version 400 0))
(test (string->mz-version "4.1")
(make-mz-version 401 0))
(test (string->mz-version "4.0.1")
(make-mz-version 400 1000))
(test (string->mz-version "4..1")
#f)
(printf "tests passed\n")

742
collects/planet/resolver.ss Normal file
View File

@ -0,0 +1,742 @@
#| resolver.ss -- 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
MzScheme 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.
||#
#lang mzscheme
(define resolver
(case-lambda
[(name) (void)]
[(spec module-path stx)
(resolver spec module-path stx #t)]
[(spec module-path stx load?)
;; 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?)]))
(require mzlib/match
mzlib/file
mzlib/port
mzlib/list
mzlib/date
net/url
net/head
mzlib/struct
"config.ss"
"private/planet-shared.ss"
"private/linkage.ss"
"parsereq.ss")
(provide (rename 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
install?)
;; if #f, will not install packages and instead give an error
(define install? (make-parameter #t))
;; =============================================================================
;; 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?)
(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))))
(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
(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)
((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)
(unless (install?)
(raise (make-exn:fail
(format
"PLaneT error: cannot install package ~s since the install? parameter is set to #f"
(list (car (pkg-spec-path pkg)) (pkg-spec-name pkg) maj min))
(current-continuation-marks))))
(let* ([owner (car (pkg-spec-path pkg))]
[extra-path (cdr (pkg-spec-path pkg))]
[the-dir
(apply build-path (CACHE-DIR)
(append (pkg-spec-path pkg) (list (pkg-spec-name pkg)
(number->string maj)
(number->string min))))])
(if (directory-exists? the-dir)
(raise (make-exn:fail
"Internal PLaneT error: trying to install already-installed package"
(current-continuation-marks)))
(begin
(with-logging
(LOG-FILE)
(lambda ()
(printf "\n============= Installing ~a on ~a =============\n"
(pkg-spec-name pkg)
(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)])
(ipp path the-dir (list owner (pkg-spec-name pkg)
extra-path maj min))))))
(make-pkg (pkg-spec-name pkg) (pkg-spec-path pkg)
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-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
;; 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)"))
(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 (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))]))))))
;; =============================================================================
;; 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))]))))

793
collects/planet/util.ss Normal file
View File

@ -0,0 +1,793 @@
#lang scheme
(require "config.ss"
"planet-archives.ss"
"private/planet-shared.ss"
"private/linkage.ss"
"resolver.ss"
net/url
xml/xml
mzlib/file
mzlib/list
mzlib/etc
scheme/contract
scheme/port
scheme/path
setup/pack
setup/plt-single-installer
setup/getinfo
setup/unpack
(prefix-in srfi1: srfi/1)
)
#| The util collection provides a number of useful functions for interacting with the PLaneT system. |#
(provide
current-cache-contents
current-linkage
make-planet-archive
unpack-planet-archive
force-package-building?
build-scribble-docs?
get-installed-planet-archives
get-hard-linked-packages
unlink-all
lookup-package-by-keys
resolve-planet-path
(struct-out exn:fail:planet)
display-plt-file-structure
display-plt-archived-file
get-package-from-cache
install-pkg
pkg->download-url)
(provide/contract
[get-package-spec
(->* (string? string?) (natural-number/c any/c) pkg-spec?)]
[download-package
(-> pkg-spec?
(or/c string?
(list/c (λ (x) (eq? x #t)) path? natural-number/c natural-number/c)
(list/c false/c string?)))]
[download/install-pkg
(-> string? string? natural-number/c any/c (or/c pkg? false/c))]
[add-hard-link
(-> string? string? natural-number/c natural-number/c path? void?)]
[remove-hard-link
(-> string? string? natural-number/c natural-number/c void?)]
[remove-pkg
(-> string? string? natural-number/c natural-number/c void?)]
[erase-pkg
(-> string? string? natural-number/c natural-number/c void?)])
;; get-package-spec : string string [nat | #f] [min-ver-spec | #f] -> pkg?
;; gets the package that corresponds to the given arguments, which are
;; values corresponding to the four parts of a package specifier in require syntax
(define (get-package-spec owner pkg [maj #f] [min #f])
(define arg
(cond
[(not maj) (list owner pkg)]
[(not min) (list owner pkg maj)]
[else (list owner pkg maj min)]))
(pkg-spec->full-pkg-spec arg #f))
;; download/install-pkg : string string nat nat -> pkg | #f
(define (download/install-pkg owner name maj min)
(let* ([pspec (pkg-spec->full-pkg-spec (list owner name maj min) #f)]
[upkg (get-package-from-server pspec)])
(cond
[(uninstalled-pkg? upkg)
(pkg-promise->pkg upkg)]
[else #f])))
;; current-cache-contents : -> ((string ((string ((nat (nat ...)) ...)) ...)) ...)
;; returns the packages installed in the local PLaneT cache
(define (current-cache-contents)
(cdr (tree->list (repository-tree))))
;; just so it will be provided
(define unlink-all remove-all-linkage!)
;; to remove:
;; -- setup-plt -c the package
;; -- remove relevant infodomain cache entries
;; -- delete files from cache directory
;; -- remove any existing linkage for package
;; returns void if the removal worked; raises an exception if no package existed.
(define-struct (exn:fail:planet exn:fail) ())
(define (remove-pkg owner name maj min)
(let ((p (get-installed-package owner name maj min)))
(unless p
(raise (make-exn:fail:planet "Could not find package" (current-continuation-marks))))
(unless (normally-installed-pkg? p)
(raise (make-exn:fail:planet "Not a normally-installed package, can't remove" (current-continuation-marks))))
(let ((path (pkg-path p)))
(with-logging
(LOG-FILE)
(lambda ()
(printf "\n============= Removing ~a =============\n" (list owner name maj min))
(clean-planet-package path (list owner name '() maj min))))
(erase-metadata p)
(delete-directory/files path)
(trim-directory (CACHE-DIR) path)
(void))))
;; erase-metadata : pkg -> void
;; clears out any references to the given package in planet's metadata files
;; (i.e., linkage and info.ss cache; not hard links which are not considered metadata)
(define (erase-metadata p)
(remove-infodomain-entries (pkg-path p))
(remove-linkage-to! p))
;; this really should go somewhere else. But what should setup's behavior be
;; when a package is cleaned? should it clear info-domain entries out? I think
;; no; an uncompiled package isn't necessarily not to be indexed and so on.
;; remove-infodomain-entries : path -> void
(define (remove-infodomain-entries path)
(let* ([pathbytes (path->bytes path)]
[cache-file (build-path (PLANET-DIR) "cache.ss")])
(when (file-exists? cache-file)
(let ([cache-lines (with-input-from-file cache-file read)])
(call-with-output-file cache-file
(λ (op)
(if (pair? cache-lines)
(write (filter
(λ (line)
(not
(and
(pair? line)
(or (not (directory-exists? (bytes->path (car line))))
(subpath? path (bytes->path (car line)))))))
cache-lines)
op)
(fprintf op "\n")))
#:exists 'truncate/replace)))))
;; subpath? : path path -> boolean
;; determines if p1 is a subpath of p2. Both paths must actually exist on the filesystem
(define (subpath? p1 p2)
(let ([full-p1 (explode-path (normalize-path p1))]
[full-p2 (explode-path (normalize-path p2))])
(sublist? full-p1 full-p2 (o2 bytes=? path->bytes))))
;; o2 : (X X -> Y) (Z -> X) -> (Z Z -> Y)
;; "compose-two"
(define (o2 a b) (λ (x y) (a (b x) (b y))))
;; sublist? : (listof X) (listof X) (X X -> boolean) -> boolean
;; determine if l1 is a sublist of l2, using = as the comparison operator for elements
(define (sublist? l1 l2 =)
(cond
[(null? l1) #t]
[(null? l2) #f]
[(= (car l1) (car l2)) (sublist? (cdr l1) (cdr l2) =)]
[else #f]))
(define (erase-pkg owner name maj min)
(let* ([uninstalled-pkg-dir
(build-path (UNINSTALLED-PACKAGE-CACHE) owner name (number->string maj) (number->string min))]
[uninstalled-pkg-file (build-path uninstalled-pkg-dir name)]
[uninstalled-file-exists? (file-exists? uninstalled-pkg-file)])
(when uninstalled-file-exists?
(delete-file uninstalled-pkg-file)
(trim-directory (UNINSTALLED-PACKAGE-CACHE) uninstalled-pkg-dir))
(with-handlers ([exn:fail:planet?
(λ (e) (if uninstalled-file-exists?
;; not really a failure, just return
(void)
(raise e)))])
(remove-pkg owner name maj min))))
;; listof X * listof X -> nonempty listof X
;; returns de-prefixed version of l2 if l1 is a proper prefix of l2;
;; signals an error otherwise.
(define (drop-common-base list1 list2)
(let loop ((l1 list1) (l2 list2))
(cond
[(null? l2)
(error 'drop-common-base "root ~s is not a prefix of stem ~s" list1 list2)]
[(null? l1) l2]
[(not (equal? (car l1) (car l2)))
(error 'drop-common-base "root ~s is not a prefix of stem ~s" list1 list2)]
[else (loop (cdr l1) (cdr l2))])))
;; pathify-list : path (listof path) -> listof path
;; given a base and a list of names, interprets each name as a subdirectory
;; of the previous, starting with base, and returns a list. (This list
;; is in reverse order, so the deepest subdirectory is returned first)
(define (pathify-list root dirs)
(let loop ((base root) (dirs dirs) (acc '()))
(cond
[(null? dirs) acc]
[else
(let ((new (build-path base (car dirs))))
(loop new (cdr dirs) (cons new acc)))])))
;; directory-empty? path -> bool
;; #t iff the given directory contains no subdirectories of files
(define (directory-empty? dir)
(null? (directory-list dir)))
;; trim-directory path path -> void
;; deletes nonempty directories starting with stem and working down to root
(define (trim-directory root stem)
(let* ([rootl (explode-path root)]
[steml (explode-path stem)]
[extras (cdr (pathify-list root (drop-common-base rootl steml)))])
(let loop ((dirs extras))
(cond
[(null? dirs) (void)]
[(directory-empty? (car dirs))
(delete-directory (car dirs))
(loop (cdr dirs))]
[else (void)]))))
;; current-linkage : -> ((symbol (package-name nat nat) ...) ...)
;; gives the current "linkage table"; a table that links modules to particular versions
;; of planet requires that satisfy those linkages
(define (current-linkage)
(let* ((links
(if (file-exists? (LINKAGE-FILE))
(with-input-from-file (LINKAGE-FILE) read-all)
'()))
(buckets (categorize caar links)))
(map
(lambda (x) (cons (car x) (map (lambda (y) (drop-last (cadr y))) (cdr x))))
buckets)))
;; regexp->filter : (string | regexp) -> (path -> bool)
;; computes a filter that accepts paths that match the given regexps and rejects other paths
(define (regexp->filter re-s)
(let ([re (cond
[(string? re-s) (regexp re-s)]
[(regexp? re-s) re-s]
[else (error 'regexp->filter "not a regular expression")])])
(lambda (p) (regexp-match re (path->bytes p)))))
(define force-package-building? (make-parameter #f))
(define build-scribble-docs? (make-parameter #t))
;; ---
;; documentation stuff --- loaded on demand so that setup/scribble can be
;; omitted in the MzScheme distribution
(define-namespace-anchor anchor)
;; render : path[fully-expanded scribble file path] path[fully expanded directory] boolean? -> xref?
;; renders the given scribble doc file (in src dir) into the directory
;; dir as a real scribble document
(define (render src-file dest-dir multi-page?)
(parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)])
(make-directory* dest-dir)
(let* ([index-dir (if multi-page?
(let-values ([(base name dir?) (split-path dest-dir)]) base)
dest-dir)]
[renderer (new ((if multi-page?
(dynamic-require 'scribble/html-render 'render-multi-mixin)
values)
((dynamic-require 'scribble/html-render 'render-mixin)
(dynamic-require 'scribble/base-render 'render%)))
[dest-dir index-dir]
[root-path dest-dir])]
[doc (dynamic-require `(file ,(path->string src-file)) 'doc)]
[ci (send renderer collect (list doc) (list dest-dir))]
[xref ((dynamic-require 'setup/xref 'load-collections-xref))]
[_ ((dynamic-require 'scribble/xref 'xref-transfer-info) renderer ci xref)]
[ri (send renderer resolve (list doc) (list dest-dir) ci)])
(send renderer set-external-tag-path
"/servlets/doc-search.ss")
(send renderer render
(list doc)
(list (if multi-page?
dest-dir
(build-path dest-dir "index.html")))
ri)
;; return cross-reference info:
(send renderer serialize-info ri))))
;; this MUST BE a syntactic directory (with the trailing slash)
;; or the scribble renderer gets very confused
(define SCRIBBLE-DOCUMENT-DIR "planet-docs/")
;; make-planet-archive: path<directory> [path<file>] -> path<file>
;; 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.
(define make-planet-archive
(case-lambda
[(dir)
(let-values ([(path name must-be-dir?) (split-path dir)])
(make-planet-archive
dir
(build-path (normalize-path (current-directory))
(string-append (path->string name) ".plt"))))]
[(dir archive-name)
(let ([abs-dir (normalize-path dir)])
(parameterize ((current-directory (normalize-path dir)))
(let ([announcements '()]
[warnings '()]
[critical-errors '()])
(define info.ss
(let ([real-info
(check-info.ss-sanity
dir
(λ (msg . args) (set! announcements (cons (apply format msg args) announcements)))
(λ (bad) (set! warnings (cons bad warnings)))
(λ (err) (set! critical-errors (cons err critical-errors))))])
(or real-info (λ (x [y (λ () (error 'info.ss (format "undefined field: ~a" x)))]) (y)))))
(let ([scribble-files (info.ss 'scribblings (λ () '()))])
(define (outdir file-str)
(let* ([filename (file-name-from-path file-str)]
[pathname (regexp-match #rx"(.*)\\.scrbl$" (path->bytes filename))])
(build-path SCRIBBLE-DOCUMENT-DIR (bytes->path (cadr pathname)))))
(when (and (build-scribble-docs?)
(file-exists? (build-path (collection-path "setup") "scribble.ss")))
(with-handlers ([exn:fail?
(lambda (e)
(set! critical-errors
(cons (format "Error generating scribble documentation: ~a" (exn-message e)) critical-errors)))])
(unless (list? scribble-files)
(error (format "malformed scribblings field; expected (listof (list string (listof symbol))), received ~e"
scribble-files)))
(for ([entry scribble-files])
(match entry
[`(,(? string? filename) (,(? symbol? flags) ...))
(unless (and (relative-path? filename)
(subpath? abs-dir filename)
(bytes=? (filename-extension filename) #"scrbl"))
(error "illegal scribblings file ~a (must be a file with extension .scrbl in the package directory or a subdirectory"))
(unless (file-exists? (build-path abs-dir filename))
(error (format "scribblings file ~a not found" filename)))
(printf "Building: ~a\n" filename)
(let* ([name.scrbl (file-name-from-path filename)]
[name (path-replace-suffix name.scrbl #"")])
(render (build-path filename)
(build-path SCRIBBLE-DOCUMENT-DIR name)
(memq 'multi-page flags)))]
[_ (error "malformed scribblings entry")])))))
(unless
(or (null? critical-errors)
(force-package-building?))
(error '|PLaneT packager| "~a\nRefusing to continue packaging." (car critical-errors)))
(pack archive-name
"archive"
(list ".")
null
(if (PLANET-ARCHIVE-FILTER)
(regexp->filter (PLANET-ARCHIVE-FILTER))
std-filter)
#t
'file
#f
#f)
(for-each display (reverse announcements))
(newline)
(for-each
(λ (s) (fprintf (current-error-port) "WARNING:\n\t~a\n" s))
(reverse warnings))))
(normalize-path archive-name))]))
(define (unpack-planet-archive plt-file target)
(parameterize ([current-directory target])
(unpack plt-file)))
(define (location->path loc)
(match loc
['same (build-path 'same)]
[(list 'same path) path]
[(list other _) (error (format "bad location ~a (illegal in PLaneT packages)" other))]
[other (error (format "bad location ~a" other))]))
(define (foreach-planet-archive plt-file on-dir on-file)
(fold-plt-archive plt-file
void
void
(λ (l _) (on-dir (location->path l)))
(λ (l fip _) (on-file (location->path l) fip))
(void)))
;; hash-tree ::= (hash-table [string -o> (union string hash-tree)])
;; chop-path : path -> (listof (union path symbol))
;; fully chops up the given path into directory list, without
;; accessing the filesystem
(define (chop-path path)
(let loop ([p path] [acc '()])
(cond
[(not (path? p)) acc]
[else
(let-values ([(base name _) (split-path p)])
(loop base (cons name acc)))])))
;; ============================================================
;; hash trees
(define (new-hash-tree)
(make-hash))
(define (hash-tree-get htree pth)
(let loop ([pth pth]
[htree htree]
[route '()])
(cond
[(null? pth) htree]
[(not (hash? htree))
(error (format "subpath ~s maps to a value" (reverse route)))]
[else
(let* ([head (car pth)]
[next (hash-ref htree
head
(λ ()
(let ([extension (new-hash-tree)])
(hash-set! htree head extension)
extension)))])
(loop (cdr pth) next (cons (car pth) route)))])))
(define (hash-tree-put-value htree pth val)
(let-values ([(where key) (split-last pth)])
(let ([ht (hash-tree-get htree where)])
(unless (hash? ht)
(error "subpath ~s maps to a value" where))
(hash-set! ht key val))))
(define (split-last l)
(let loop ([l l]
[front '()])
(cond
[(null? (cdr l)) (values (reverse front) (car l))]
[else
(loop (cdr l)
(cons (car l) front))])))
(define (hash-tree->list ht)
(let ([lst (hash-map ht
(λ (k v)
(cons k
(if (hash? v)
(hash-tree->list v)
(list v)))))])
(sort lst (λ (a b) (string<? (car a) (car b))))))
;; a 'a treelist is ::= (list string 'a) | (list string ('a treelist) ...)
;; ============================================================
;; print out file treelists (treelists where 'file is the only non-structure
;; element)
(define (print-tree t depth)
(cond
[(and (not (null? (cdr t)))
(not (pair? (cadr t))))
(printf "~a~a\n" (padding depth) (car t))]
[else
(printf "~a~a:\n" (padding depth) (car t))
(print-tree-list (cdr t) (add1 depth))]))
(define (print-tree-list ts depth)
(for-each (λ (t) (print-tree t depth)) ts))
(define (padding n)
(apply string-append (build-list n (λ (_) " "))))
;; list-plt-file-contents : path-string[.plt-file] -> void
;; prints out a manifest of the given plt file
(define (display-plt-file-structure plt-file)
(define root (new-hash-tree))
(define (gen-put f)
(λ (path) (f (chop-path (simplify-path path #f)))))
(define put-directory
(gen-put
(λ (ps)
(cond
[(equal? ps '(same)) (void)]
[else (hash-tree-get root (map path->string ps))]))))
(define put-file
(gen-put
(λ (ps)
(hash-tree-put-value root (map path->string ps) 'file))))
(foreach-planet-archive
plt-file
put-directory
(λ (p _) (put-file p)))
(print-tree-list (hash-tree->list root) 0))
;; display-plt-archived-file : path-string[.plt-file] string -> void
(define (display-plt-archived-file plt-file file-to-print)
(let/ec finished
(let ([target (simplify-path file-to-print #f)])
(foreach-planet-archive
plt-file
void
(λ (path fip)
(when (equal? (simplify-path path #f) target)
(copy-port fip (current-output-port))
(finished (void))))))
(error 'display-archived-plt-file "The given file was not found in the given package")))
;; check-info.ss-sanity : path (string -> void) (string -> void) (string -> void) -> info.ss-fn | #f
;; gets all the info.ss fields that planet will use (using the info.ss file
;; from the current directory) and calls the announce, warn, and fail functions with strings
;; that describe how PLaneT sees the info.ss file. NOTA BENE: if this function calls fail, it may
;; also warn on the same field, and the warning may not make sense. This is based on the
;; assumption that errors will be turned into some kind of critical failure that obliterates
;; all the other information produced.
(define (check-info.ss-sanity dir announce warn fail)
(with-handlers ([exn:fail:read?
(λ (e)
(fail (format "Package has an unreadable info.ss file. ~a" (exn-message e)))
#f)]
[exn:fail:syntax?
(λ (e)
(fail (format "Package's info.ss has an syntactically ill-formed info.ss file: ~a" (exn-message e)))
#f)])
(let ([i* (get-info/full dir)])
(cond
[(not i*)
(warn "Package has no info.ss file. This means it will not have a description or documentation on the PLaneT web site.")]
[else
(let ([i (λ (field) (i* field (λ () #f)))])
(checkinfo i fail
[name ; field name
string? ; check
(announce "Name: ~a\n" name) ; success action
(warn "Package's info.ss file has no name field. Without a name, PLT Scheme will not compile your package.") ;failure action
]
[blurb
(λ (b) (and (list? b) (andmap xexpr? b)))
(announce "Package blurb: ~s\n" blurb)
(unless blurb
(warn "Package's info.ss does not contain a blurb field. Without a blurb field, the package will have no description on planet.plt-scheme.org."))]
[release-notes
(λ (b) (and (list? b) (andmap xexpr? b)))
(announce "Release notes: ~s\n" release-notes)
(unless release-notes
(warn "Package's info.ss does not contain a release-notes field. Without a release-notes field, the package will not have any listed release information on planet.plt-scheme.org beyond the contents of the blurb field."))]
[categories
(λ (s) (and (list? s) (andmap symbol? s)))
(cond
[(ormap illegal-category categories)
=>
(λ (bad-cat)
(fail (format "Package's info.ss file contains illegal category \"~a\". The legal categories are: ~a\n"
bad-cat
legal-categories)))]
[else (announce "Categories: ~a\n" categories)])
(unless categories
(warn "Package's info.ss file does not contain a category listing. It will be placed in the Miscellaneous category."))]
[doc.txt
string?
(announce "doc.txt file: ~a\n" doc.txt)
(when doc.txt
(warn "Package's info.ss contains a doc.txt entry, which is now considered deprecated. The preferred method of documentation for PLaneT packages is now Scribble (see the Scribble documentation included in the PLT Scheme distribution for more information)."))]
[html-docs
(lambda (s) (and (list? s) (andmap string? s)))
(warn "Package specifies an html-docs entry. The preferred method of documentation for PLaneT packages is now Scribble (see the Scribble documentation included in the PLT Scheme distribution for more information).")]
[scribblings
(lambda (s)
(and (list? s)
(andmap
(lambda (item)
(match item
[`(,(? string?) (,(? symbol?) ...)) #t]
[_ #f]))
s)))
(void)
(unless scribblings
(warn "Package does not specify a scribblings field. Without a scribblings field, the package will not have browsable online documentation."))]
[homepage
string?
(cond
[(url-string? homepage)
(announce "Home page: ~a\n" homepage)]
[else
(fail (format "The value of the package's info.ss homepage field, ~s, does not appear to be a legal URL." homepage))])]
[primary-file
(λ (x) (or (string? x) (and (list? x) (andmap string? x))))
(begin
(cond
[(string? primary-file)
(unless (file-in-current-directory? primary-file)
(warn (format "Package's info.ss primary-file field is ~s, a file that does not exist in the package."
primary-file)))]
[(pair? primary-file)
(let ([bad-files (filter (λ (f) (not (file-in-current-directory? f))) primary-file)])
(unless (null? bad-files)
(warn (format "Package's info.ss primary-file field is ~s, which contains non-existant files ~s."
primary-file bad-files))))])
(announce "Primary file: ~a\n" primary-file))
(unless primary-file
(warn "Package's info.ss does not contain a primary-file field. The package's listing on planet.plt-scheme.org will not have a valid require line for your package."))]
[required-core-version
core-version?
(announce "Required mzscheme version: ~a\n" required-core-version)]
[repositories
(λ (x) (and (list? x)
(srfi1:lset<= equal? x '("3xx" "4.x"))))
(announce "Repositories: ~s\n" repositories)
(warn "Package's info.ss does not contain a repositories field. The package will be listed in all repositories by default.")]
[version
string?
(announce "Version description: ~a\n" version)]))])
i*)))
;; legal-categories : (listof symbol)
(define legal-categories
'(devtools net media xml datastructures io scientific
system ui metaprogramming planet misc))
;; legal-category : symbol -> boolean
;; determine if the given symbol is a legal category
(define (legal-category? x) (memq x legal-categories))
;; illegal-category : symbol -> (union symbol false)
;; returns #f if the symbol is a legal category, or the symbol itself if it isn't
(define (illegal-category s) (if (legal-category? s) #f s))
;; url-string? : string -> boolean
;; determines if the given string is a reasonable homepage url
(define (url-string? s)
(and (string? s)
(let ([u (string->url s)])
(and (url-scheme u)
(url-host u)))))
;; file-in-current-directory? : string -> boolean
;; determines if the given string represents a file in the current directory
(define (file-in-current-directory? f)
(and (string? f) (file-exists? f)))
;; core-version : string -> boolean
;; determines if the given string is something that (version) could've produced
(define (core-version? s)
(and (string? s)
(string->mz-version s)))
;; checkinfo: syntax
;; given an info.ss function, a failure function, and a bunch of fields to check,
;; goes through the checklist calling either the success or the failure branch
;; of each check as appropriate
(define-syntax checkinfo
(syntax-rules ()
[(checkinfo fn fail clauses ...)
(let ([fn* fn] [fail* fail])
(checkinfo* () fn* fail* clauses ...))]))
(define-syntax checkinfo*
(syntax-rules ()
[(checkinfo* () fn fail) (void)]
[(checkinfo* (handler1 handler ...) fn fail) (begin handler1 handler ...)]
[(checkinfo* (handler ...) fn fail [id check on-success] clauses ...)
(checkinfo* (handler ...) fn fail [id check on-success void] clauses ...)]
[(checkinfo* (handler ...) fn fail [id check on-success on-fail] clauses ...)
(checkinfo*
(handler ...
(let ([id (fn 'id)])
(cond
[id
(let ([checked (check id)])
(unless checked
on-fail
(fail (format "Package's info.ss contained a malformed ~a field." 'id)))
on-success)]
[else on-fail])))
fn fail clauses ...)]))
;; ============================================================
;; HARD LINKS (aka development links)
;; add-hard-link : string string num num path -> void
;; adds an entry in the hard-links table associating the given
;; require spec to the given path
(define (add-hard-link owner pkg-name maj min path)
(unless (directory-exists? path)
(if (file-exists? path)
(error 'add-hard-link "Hard links must point to directories, not files")
(fprintf (current-error-port)
"Warning: directory ~a does not exist\n"
(path->string path))))
(add-hard-link! pkg-name (list owner) maj min path))
;; remove-hard-link : string string num num -> void
;; removes any development association from the given package spec
(define (remove-hard-link owner pkg-name maj min)
(filter-link-table!
(lambda (row)
(not (points-to? row pkg-name (list owner) maj min)))
(lambda (row)
(let ([p (row->package row)])
(when p
(erase-metadata p))))))
;; ============================================================
;; VERSION INFO
(provide this-package-version
this-package-version-name
this-package-version-owner
this-package-version-maj
this-package-version-min)
(define-syntax (this-package-version stx)
(syntax-case stx ()
[(_)
#`(this-package-version/proc
#,(datum->syntax stx `(,#'this-expression-source-directory)))]))
(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 (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 (normalize-path srcdir)]
[nsuperdir (normalize-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))