From fbccf38d50e5f622c0c96a8c09b423decbd01269 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 6 Jul 2011 18:18:22 +0800 Subject: [PATCH] completed the planet library documentation and, in the process, cleaned up various dependencies and exports from some of the libraries --- collects/planet/cachepath.rkt | 3 +- collects/planet/config.rkt | 52 +- collects/planet/planet-archives.rkt | 17 +- collects/planet/planet.scrbl | 483 +---------- collects/planet/{ => private}/parsereq.rkt | 4 +- collects/planet/private/planet-shared.rkt | 12 + collects/planet/private/resolver.rkt | 815 ++++++++++++++++++ collects/planet/private/util.scrbl | 651 +++++++++++++++ collects/planet/private/version.rkt | 103 +++ collects/planet/resolver.rkt | 823 +------------------ collects/planet/syntax.rkt | 1 - collects/planet/tests/test-docs-complete.rkt | 13 - collects/planet/util.rkt | 137 +-- collects/planet/version.rkt | 16 +- collects/tests/planet/cmdline-tool.rkt | 7 +- collects/tests/planet/test-docs-complete.rkt | 12 + collects/tests/unstable/planet-syntax.rkt | 1 - 17 files changed, 1672 insertions(+), 1478 deletions(-) rename collects/planet/{ => private}/parsereq.rkt (98%) create mode 100644 collects/planet/private/resolver.rkt create mode 100644 collects/planet/private/util.scrbl create mode 100644 collects/planet/private/version.rkt delete mode 100644 collects/planet/tests/test-docs-complete.rkt create mode 100644 collects/tests/planet/test-docs-complete.rkt diff --git a/collects/planet/cachepath.rkt b/collects/planet/cachepath.rkt index e7f748c8a1..572b5711bd 100644 --- a/collects/planet/cachepath.rkt +++ b/collects/planet/cachepath.rkt @@ -2,12 +2,11 @@ (require "config.rkt") (provide get-planet-cache-path) -;; get-planet-cache-path : -> path[absolute, file] -;; the path to the cache.rktd file for the planet installation ;; (n.b. this used to have the side effect of creating the path ;; if it didn't exist, but since this function may be run at ;; setup time and setup-time programs must not create this sort ;; of directory, it doesn't do that anymore) + (define (get-planet-cache-path) (let ((path (build-path (PLANET-DIR) "cache.rktd"))) path)) diff --git a/collects/planet/config.rkt b/collects/planet/config.rkt index ec1e2e2a30..8ce76909f1 100644 --- a/collects/planet/config.rkt +++ b/collects/planet/config.rkt @@ -1,27 +1,25 @@ -(module config racket/base - (require "private/define-config.rkt") - (define-parameters - (PLANET-SERVER-NAME "planet.racket-lang.org") - (PLANET-SERVER-PORT 270) - (PLANET-CODE-VERSION "300") - (PLANET-BASE-DIR (let ([plt-planet-dir-env-var (getenv "PLTPLANETDIR")]) - (if plt-planet-dir-env-var - (string->path plt-planet-dir-env-var) - (build-path (find-system-path 'addon-dir) - "planet" - (PLANET-CODE-VERSION))))) - (PLANET-DIR (build-path (PLANET-BASE-DIR) (version))) - (CACHE-DIR (build-path (PLANET-DIR) "cache")) - (UNINSTALLED-PACKAGE-CACHE (build-path (PLANET-BASE-DIR) "packages")) - (LINKAGE-FILE (build-path (PLANET-DIR) "LINKAGE")) - (HARD-LINK-FILE (build-path (PLANET-BASE-DIR) (version) "HARD-LINKS")) - (LOGGING-ENABLED? #t) - (LOG-FILE (build-path (PLANET-DIR) "INSTALL-LOG")) - (DEFAULT-PACKAGE-LANGUAGE (version)) - - (USE-HTTP-DOWNLOADS? #t) - (HTTP-DOWNLOAD-SERVLET-URL (let ([plt-planet-url-env-var (getenv "PLTPLANETURL")]) - (or plt-planet-url-env-var - "http://planet.racket-lang.org/servlets/planet-servlet.ss"))) - (PLANET-ARCHIVE-FILTER #f))) - +#lang racket/base +(require "private/define-config.rkt") +(define-parameters + (PLANET-SERVER-NAME "planet.racket-lang.org") + (PLANET-SERVER-PORT 270) + (PLANET-CODE-VERSION "300") + (PLANET-BASE-DIR (let ([plt-planet-dir-env-var (getenv "PLTPLANETDIR")]) + (if plt-planet-dir-env-var + (string->path plt-planet-dir-env-var) + (build-path (find-system-path 'addon-dir) + "planet" + (PLANET-CODE-VERSION))))) + (PLANET-DIR (build-path (PLANET-BASE-DIR) (version))) + (CACHE-DIR (build-path (PLANET-DIR) "cache")) + (UNINSTALLED-PACKAGE-CACHE (build-path (PLANET-BASE-DIR) "packages")) + (LINKAGE-FILE (build-path (PLANET-DIR) "LINKAGE")) + (HARD-LINK-FILE (build-path (PLANET-BASE-DIR) (version) "HARD-LINKS")) + (LOG-FILE (build-path (PLANET-DIR) "INSTALL-LOG")) + (DEFAULT-PACKAGE-LANGUAGE (version)) + + (USE-HTTP-DOWNLOADS? #t) + (HTTP-DOWNLOAD-SERVLET-URL (let ([plt-planet-url-env-var (getenv "PLTPLANETURL")]) + (or plt-planet-url-env-var + "http://planet.racket-lang.org/servlets/planet-servlet.ss"))) + (PLANET-ARCHIVE-FILTER #f)) diff --git a/collects/planet/planet-archives.rkt b/collects/planet/planet-archives.rkt index 69d226da85..928b36e573 100644 --- a/collects/planet/planet-archives.rkt +++ b/collects/planet/planet-archives.rkt @@ -3,29 +3,18 @@ "config.rkt" "cachepath.rkt") -(provide repository-tree - get-installed-planet-archives +(provide get-installed-planet-archives get-hard-linked-packages get-all-planet-packages get-planet-cache-path) -(define (repository-tree) - (define (id x) x) - (filter-tree-by-pattern - (directory->tree - (CACHE-DIR) - (lambda (x) - (not (regexp-match? #rx"/(?:[.]git.*|[.]svn|CVS)$" (path->string x)))) - 4) - (list id id id string->number string->number))) - -;; get-installed-planet-dirs : -> listof (list path[absolute, dir] string string (listof string) nat nat) +;; get-installed-planet-archives : -> listof (list path[absolute, dir] string string (listof string) nat nat) ;; directories of all normally-installed planet archives [excluding hard links] (define (get-installed-planet-archives) (with-handlers ((exn:fail:filesystem:no-directory? (lambda (e) '()))) (tree-apply (lambda (rep-name owner package maj min) - (let ((x (list + (let ((x (list (build-path (CACHE-DIR) owner package (number->string maj) (number->string min)) owner package diff --git a/collects/planet/planet.scrbl b/collects/planet/planet.scrbl index 2b2eb1e11d..3973043f55 100644 --- a/collects/planet/planet.scrbl +++ b/collects/planet/planet.scrbl @@ -464,488 +464,7 @@ reader. The @racketmodname[planet] module (as opposed to the reader used with @hash-lang[]) implements the @exec{raco planet} command-line tool. -@section{Utility Libraries} - -The planet collection provides configuration and utilities for using PLaneT. - -@subsection{Resolver} - -@defmodule[planet/resolver] - -The primary purpose of this library to for @racket[require] to find -@PLaneT packages. It also, however, provides some utilities for manipulating -the resolvers behavior. - -@defproc[(resolve-planet-path [planet-path any/c]) path?]{ - Returns the path where the file named by the require spec @racket[planet-path] is located in the current installation. -} - -@defparam[download? dl? boolean?]{ - A parameter that controls if @PLaneT attempts to download a planet package that isn't already present. - If the package isn't present, the resolver will raise the @racket[exn:fail:planet?] exception - instead of downloading it. -} - -@defparam[install? inst? boolean?]{ - A parameter that controls if @PLaneT attempts to install a planet package that isn't already installed. - If the package isn't installed, the resolver will raise the @racket[exn:fail:planet?] exception - instead of installing it. -} - -@subsection{Client Configuration} - -@defmodule[planet/config] - -The @racketmodname[planet/config] library provides several parameters -useful for configuring how PLaneT works. - -Note that while these parameters can be useful to modify -programmatically, PLaneT code runs at module-expansion time, so -most user programs cannot set them until PLaneT has already -run. Therefore, to meaningfully change these settings, it is best to -manually edit the config.rkt file. - -@defparam[PLANET-DIR dir path-string?]{ -The root PLaneT directory. If the environment variable -@indexed-envvar{PLTPLANETDIR} is -set, default is its value; otherwise the default is the directory in -which @filepath{config.rkt} is found.} - -@defparam[CACHE-DIR dir path-string?]{ -The root of the PLaneT client's cache directory.} - -@defparam[UNINSTALLED-PACKAGE-CACHE dir path-string?]{ -The root of the PLaneT client's uninstalled-packages cache. PLaneT -stores package distribution files in this directory, and searches for -them in this directory for them if necessary. Unlike the main PLaneT -cache, which contains compiled files and is specific to each -particular version of Racket, the uninstalled package cache is -shared by all versions of Racket that use the same package -repository, and it is searched if a package is not installed in the -primary cache and cannot be downloaded from the central PLaneT repository -(for instance due to a loss of Internet connectivity). This behavior -is intended to primarily benefit users who upgrade their Racket -installations frequently.} - -@defparam[LINKAGE-FILE file path-string?]{ -The file to use as the first place PLaneT looks to determine how a -particular PLaneT dependence in a file should be satisfied. The -contents of this file are used to ensure that no "magic upgrades" -occur after a package is installed. The default is the file @filepath{LINKAGE} -in the root PLaneT directory.} - -@defparam[LOG-FILE file (or/c path-string? false?)]{ -If @racket[#f], indicates that no logging should take place. Otherwise -specifies the file into which logging should be written. The default -is the file @filepath{INSTALL-LOG} in the root PLaneT directory.} - -@defboolparam[USE-HTTP-DOWNLOADS? bool]{ -PLaneT can use two different protocols to retrieve packages. If @racket[#t], -PLaneT will use the HTTP protocol; if @racket[#f] it will use the custom-built -PLaneT protocol. The default value for this parameter is @racket[#t] and setting -this parameter to @racket[#f] is not recommended.} - -@defparam[HTTP-DOWNLOAD-SERVLET-URL url string?]{ -The URL for the servlet that will provide PLaneT packages if -@racket[USE-HTTP-DOWNLOADS?] is @racket[#t], represented as a string. -This defaults to the value of the @indexed-envvar{PLTPLANETURL} environment -variable if it is set and otherwise is -@racket["http://planet.racket-lang.org/servlets/planet-servlet.rkt"].} - -@defparam[PLANET-SERVER-NAME host string?]{ -The name of the PLaneT server to which the client should connect if -@racket[USE-HTTP-DOWNLOADS?] is @racket[#f]. The default value for this parameter is -@racket["planet.racket-lang.org"].} - -@defparam[PLANET-SERVER-PORT port natural-number?]{ -The port on the server the client should connect to if -@racket[USE-HTTP-DOWNLOADS?] is @racket[#f]. The default value for this parameter is -@racket[270].} - -@subsection[#:tag "util.rkt"]{Package Archive} - -@defmodule[planet/util] - -The @racketmodname[planet/util] library supports examination of the pieces of -PLaneT. It is meant primarily to support debugging and to allow easier -development of higher-level package-management tools. The -functionality exposed by @seclink["cmdline"]{the @exec{raco planet} command-line tool} is -also available programmatically through this library. - -@defproc[(download/install-pkg [owner string?] - [pkg (and/c string? #rx"[.]plt")] - [maj natural-number/c] - [min natural-number/c]) - (or/c pkg? #f)]{ -Downloads and installs the package specifed by the given owner name, -package name, major and minor version number. Returns false if no such -package is available; otherwise returns a package structure for the -installed package. - -The @racket[pkg] argument must end with @racket[".plt"]. -} - -@defproc[(install-pkg [pkg-spec pkg-spec?] - [file path-string?] - [maj natural-number/c] - [min natural-number/c]) - (or/c pkg-spec? #f)]{ - Installs the package represented by the arguments, using - the @racket[pkg-spec] argument to find the path and name of - the package to install. - - See @racket[get-package-spec] to build a @racket[pkg-spec] argument. - - Returns a new @racket[pkg-spec?] corresponding to the package - that was actually installed. -} - -@defproc[(get-package-spec [owner string?] - [pkg (and/c string? #rx"[.]plt")] - [maj (or/c #f natural-number/c) #f] - [min (or/c #f natural-number/c) #f]) - pkg-spec?]{ - Builds a @racket[pkg-spec?] corresponding to the package specified by - @racket[owner], @racket[pkg], @racket[maj], and @racket[min]. - - The @racket[pkg] argument must end with the string @racket[".plt"]. -} - -@defproc[(pkg-spec? [v any/c]) boolean?]{ - Recognizes the result of @racket[get-package-spec] (and @racket[install-pkg]). -} - -@defparam[current-cache-contents contents - (listof - (list/c string? - (listof - (list/c string? - (cons/c natural-number/c - (listof natural-number/c))))))]{ -Holds a listing of all package names and versions installed in the -local cache.} - -@defproc[(current-linkage) - (listof (list/c path-string? - (list/c string? - (list/c string?) - natural-number/c - natural-number/c)))]{ -Returns the current linkage table. - -The linkage table is an association between file locations (encoded as path strings) -and concrete planet package versions. If a require line in the associated file requests a package, -this table is consulted to determine a particular concrete package to satisfy the request.} - -@defproc[(make-planet-archive [directory path-string?] - [output-file (or/c path? path-string?) - (string-append (path->string name) ".plt")]) - path-string?]{ -Makes a .plt archive file suitable for PLaneT whose contents are all -files in the given directory and returns that file's name. If the -optional filename argument is provided, that filename will be used as -the output file's name.} - -@defproc[(unpack-planet-archive [plt-file (or/c path? path-string?)] - [output-dir (or/c path? path-string?)]) - any]{ -Unpacks the PLaneT archive with the given filename, placing its contents -into the given directory (creating that path if necessary).} - -@defproc[(remove-pkg [owner string?] - [pkg (and/c string? #rx"[.]plt")] - [maj natural-number/c] - [min natural-number/c]) - any]{ -Removes the specified package from the local planet cache. - -The @racket[pkg] argument must end with the string @racket[".plt"]. -} - -@defproc[(display-plt-file-structure [plt-file (or/c path-string? path?)]) - any]{ -Print a tree representing the file and directory structure of the -PLaneT archive .plt file named by @racket[plt-file] to @racket[(current-output-port)].} - -@defproc[(display-plt-archived-file [plt-file (or/c path-string? path?)] - [file-to-print string?]) - any]{ -Print the contents of the file named @racket[file-to-print] within the -PLaneT archive .plt file named by @racket[plt-file] to @racket[(current-output-port)].} - -@defproc[(unlink-all) any]{ -Removes the entire linkage table from the system, which will force all -modules to relink themselves to PLaneT modules the next time they run.} - -@defproc[(add-hard-link [owner string?] - [pkg (and/c string? #rx"[.]plt$")] - [maj natural-number/c] - [min natural-number/c] - [dir path?]) - any]{ -Adds a development link between the specified package and the given -directory; once a link is established, PLaneT will treat the cache as -having a package with the given owner, name, and version whose files -are located in the given path. This is intended for package -development; users only interested in using PLaneT packages -available online should not need to create any development links. - -If the specified package already has a development link, this function -first removes the old link and then adds the new one. - -The @racket[pkg] argument must end with the string @racket[".plt"]. -} - -@defproc[(remove-hard-link [owner string?] - [pkg (and/c string? #rx"[.]plt")] - [maj natural-number/c] - [min natural-number/c] - [#:quiet? quiet? boolean? #false]) - any]{ -Removes any hard link that may be associated with the given package. - -The @racket[pkg] argument must end with the string @racket[".plt"]. -The @racket[maj] and @racket[min] arguments must be integers. This -procedure signals an error if no such link exists, unless -@racket[#:quiet?] is @racket[#true]. -} - -@defproc[(resolve-planet-path [spec quoted-planet-require-spec?]) - path?]{ -Returns the file system path to the file specified by the given quoted -planet require specification. This function downloads and installs the -specified package if necessary, but does not verify that the actual -file within it actually exists.} - -@deftogether[( -@defform[(this-package-version)] -@defform[(this-package-version-name)] -@defform[(this-package-version-owner)] -@defform[(this-package-version-maj)] -@defform[(this-package-version-min)] -)]{ -Aliases of the same bindings from @racketmodname[planet/version] for backward -compatibility. -} - -@defproc[(path->package-version [p path?]) - (or/c (list/c string? string? natural-number/c natural-number/c) #f)]{ - -Given a path that corresponds to a PLaneT package (or some part of one), -produces a list corresponding to its name and version, exactly like -@racket[(this-package-version)]. Given any other path, produces @racket[#f]. - -} - -@defproc[(exn:fail:planet? [val any/c]) boolean?]{ - Returns @racket[#t] if @racket[val] is an exception indicating a planet-specific failure. -} - -@subsection[#:tag "version.rkt"]{Package Version} - -Provides bindings for @|PLaneT| developers that automatically -produce references to the name and version of the containing @|PLaneT| package -so the same code may be reused across releases without accidentally referring to -a different version of the same package. - -@defmodule[planet/version] - -@deftogether[( -@defform[(this-package-version)] -@defform*[[(this-package-version-symbol) - (this-package-version-symbol suffix-id)]] -@defform[(this-package-version-name)] -@defform[(this-package-version-owner)] -@defform[(this-package-version-maj)] -@defform[(this-package-version-min)] -)]{ - -Macros that expand into expressions that evaluate to information about the name, -owner, and version number of the package in which they -appear. @racket[this-package-version] returns a list consisting of a string -naming the package's owner, a string naming the package, a number indicating the -package major version and a number indicating the package minor version, or -@racket[#f] if the expression appears outside the context of a package. -The macros @racket[this-package-version-name], -@racket[this-package-version-owner], @racket[this-package-version-maj], and -@racket[this-package-version-min] produce the relevant fields of the package -version list. - -@racket[this-package-version-symbol] produces a symbol -suitable for use in @racket[planet] module paths. For instance, in version -@racketmodfont{1:0} of the package @racketmodfont{package.plt} owned by -@racketmodfont{author}, @racket[(this-package-version-symbol dir/file)] produces -@racket['author/package:1:0/dir/file]. In the same package, -@racket[(this-package-version-symbol)] produces @racket['author/package:1:0]. - -} - -@defform[(this-package-in suffix-id ...)]{ - -A @racket[require] sub-form that requires modules from within the same @|PLaneT| -package version as the require, as referred to by each @racket[suffix-id]. For -instance, in version @racketmodfont{1:0} of the package -@racketmodfont{package.plt} owned by @racketmodfont{author}, -@racket[(require (this-package-in dir/file))] is equivalent to -@racket[(require (planet author/package:1:0/dir/file))]. - -@italic{Note:} Use @racket[this-package-in] when documenting @|PLaneT| packages -with Scribble to associate each documented binding with the appropriate package. - -} - -@subsection[#:tag "syntax.rkt"]{Macros and Syntax Objects} - -@defmodule[planet/syntax] - -Provides bindings useful for @|PLaneT|-based macros. - -@deftogether[( -@defproc[(syntax-source-planet-package [stx syntax?]) (or/c list? #f)] -@defproc[(syntax-source-planet-package-owner [stx syntax?]) (or/c string? #f)] -@defproc[(syntax-source-planet-package-name [stx syntax?]) (or/c string? #f)] -@defproc[(syntax-source-planet-package-major [stx syntax?]) (or/c integer? #f)] -@defproc[(syntax-source-planet-package-minor [stx syntax?]) (or/c integer? #f)] -@defproc[(syntax-source-planet-package-symbol - [stx syntax?] - [suffix (or/c symbol? #f) #f]) - (or/c symbol? #f)] -)]{ - -Produce output analogous to @racket[this-package-version], -@racket[this-package-version-owner], @racket[this-package-version-name], -@racket[this-package-version-maj], @racket[this-package-version-min], and -@racket[this-package-version-symbol] based on the source location of -@racket[stx]. - -} - -@defproc[(make-planet-require-spec - [stx syntax?] - [suffix (or/c symbol? #f) #f]) - syntax?]{ - -Produces a @racket[require] sub-form for the module referred to by -@racket[suffix] in the @|PLaneT| package containing the source location of -@racket[stx]. - -} - -@subsection[#:tag "scribble.rkt"]{Scribble Documentation} - -@defmodule[planet/scribble] - -Provides bindings for documenting @|PLaneT| packages. - -@defform[(this-package-in suffix-id ...)]{ - -This binding from @racketmodname[planet/version] is also exported from -@racketmodname[planet/scribble], as it is useful for @racket[for-label] imports -in Scribble documentation. - -} - -@deftogether[( -@defform[(racketmod/this-package maybe-file suffix-id datum ...)] -@defform*[((racketmodname/this-package suffix-id) - (racketmodname/this-package (#,(racket unsyntax) suffix-expr)))] -@defform[(racketmodlink/this-package suffix-id pre-content-expr ...)] -@defform[(defmodule/this-package maybe-req suffix-id maybe-sources pre-flow ...)] -@defform*[((defmodulelang/this-package suffix-id maybe-sources pre-flow ...) - (defmodulelang/this-package suffix-id - #:module-paths (mod-suffix-id ...) maybe-sources - pre-flow ...))] -@defform[(defmodulereader/this-package suffix-id maybe-sources pre-flow ...)] -@defform[(defmodule*/this-package maybe-req (suffix-id ...+) - maybe-sources pre-flow ...)] -@defform*[((defmodulelang*/this-package (suffix-id ...+) - maybe-sources pre-flow ...) - (defmodulelang*/this-package (suffix-id ...+) - #:module-paths (mod-suffix-id ...) maybe-sources - pre-flow ...))] -@defform[(defmodulereader*/this-package (suffix-id ...+) - maybe-sources pre-flow ...)] -@defform[(defmodule*/no-declare/this-package maybe-req (suffix-id ...+) - maybe-sources pre-flow ...)] -@defform*[((defmodulelang*/no-declare/this-package (suffix-id ...+) - maybe-sources pre-flow ...) - (defmodulelang*/no-declare/this-package (suffix-id ...+) - #:module-paths (mod-suffix-id ...) maybe-sources pre-flow ...))] -@defform[(defmodulereader*/no-declare/this-package (suffix-id ...+) - maybe-sources pre-flow ...)] -@defform[(declare-exporting/this-package suffix-id ... maybe-sources)] -)]{ - -Variants of @racket[racketmod], @racket[racketmodname], -@racket[racketmodlink], @racket[defmodule], @racket[defmodulereader], -@racket[defmodulelang], @racket[defmodule*], @racket[defmodulelang*], -@racket[defmodulereader*], @racket[defmodule*/no-declare], -@racket[defmodulelang*/no-declare], -@racket[defmodulereader*/no-declare], and @racket[declare-exporting], -respectively, that implicitly refer to the PLaneT package that -contains the enclosing module. - -The full module name passed to @racket[defmodule], etc is formed by -appending the @racket[suffix-id] or @racket[mod-suffix-id] to the -symbol returned by @racket[(this-package-version-symbol)], separated -by a @litchar{/} character, and tagging the resulting symbol as a -@racket[planet] module path. As a special case, if @racket[suffix-id] -is @racketid[main], the suffix is omitted. - -For example, within a package named @tt{package.plt} by @tt{author}, -version @tt{1:0}, the following are equivalent: -@racketblock[ -(defmodule/this-package dir/file) - @#,elem{=} (defmodule (planet author/package:1:0/dir/file)) -] -and -@racketblock[ -(defmodule/this-package main) - @#,elem{=} (defmodule (planet author/package:1:0)) -] -} - -@subsection{Terse Status Updates} - -@defmodule[planet/terse-info] - -This module provides access to some PLaneT status information. This -module is first loaded by PLaneT in the initial namespace (when -PLaneT's resolver is loaded), but PLaneT uses @racket[dynamic-require] to load -this module each time it wants to announce information. Similarly, the -state of which procedures are registered (via @racket[planet-terse-register]) -is saved in the namespace, making the listening and information producing -namespace-specific. - -@defproc[(planet-terse-register - [proc (-> (or/c 'download 'install 'docs-build 'finish) - string? - any/c)]) - void?]{ -Registers @racket[proc] as a function to be called when -@racket[planet-terse-log] is called. - -Note that @racket[proc] is called -asynchronously (ie, on some thread other than the one calling @racket[planet-terse-register]). -} - -@defproc[(planet-terse-log [id (or/c 'download 'install 'finish)] - [msg string?]) void?]{ -This function is called by PLaneT to announce when things are happening. See also -@racket[planet-terse-set-key]. -} - -@defproc[(planet-terse-set-key [key any/c]) void?]{ - This sets a @seclink["threadcells" #:doc '(lib "scribblings/reference/reference.scrbl")]{thread cell} - to the value of @racket[key]. - The value of the thread cell is used as an index into a table to determine which - of the functions passed to @racket[planet-terse-register] to call when - @racket[planet-terse-log] is called. - - The table holding the key uses ephemerons and a weak hash table to ensure that - when the @racket[key] is unreachable, then the procedures passed to @racket[planet-terse-log] - cannot be reached through the table. -} +@include-section["private/util.scrbl"] @section{Developing Packages for PLaneT} diff --git a/collects/planet/parsereq.rkt b/collects/planet/private/parsereq.rkt similarity index 98% rename from collects/planet/parsereq.rkt rename to collects/planet/private/parsereq.rkt index 345d7605cd..f83cc588fe 100644 --- a/collects/planet/parsereq.rkt +++ b/collects/planet/private/parsereq.rkt @@ -1,8 +1,8 @@ #lang racket/base (require mzlib/match - "private/short-syntax-helpers.rkt" - "private/data.rkt") + "short-syntax-helpers.rkt" + "data.rkt") (provide (struct-out request) parse-package-string diff --git a/collects/planet/private/planet-shared.rkt b/collects/planet/private/planet-shared.rkt index eabef0f91a..9cf19b3518 100644 --- a/collects/planet/private/planet-shared.rkt +++ b/collects/planet/private/planet-shared.rkt @@ -611,3 +611,15 @@ Various common pieces of code that both the client and server need to access ;; tree->list : tree[x] -> sexp-tree[x] (define (tree->list tree) (cons (branch-node tree) (map tree->list (branch-children tree)))) + + + + (define (repository-tree) + (define (id x) x) + (filter-tree-by-pattern + (directory->tree + (CACHE-DIR) + (lambda (x) + (not (regexp-match? #rx"/(?:[.]git.*|[.]svn|CVS)$" (path->string x)))) + 4) + (list id id id string->number string->number))) diff --git a/collects/planet/private/resolver.rkt b/collects/planet/private/resolver.rkt new file mode 100644 index 0000000000..f6262b6501 --- /dev/null +++ b/collects/planet/private/resolver.rkt @@ -0,0 +1,815 @@ +#lang racket/base + +#| resolver.rkt -- PLaneT client + +1. Introduction + +The PLaneT system is a method for automatically sharing code packages, both as +libraries and as full applications, that gives every user of a PLaneT client +the illusion of having a local copy of every code package on the server, but is +parsimonious in its transmission. It consists of a centralized server that +holds all packages and individual clients that hold some portion of the archive +locally. Maintenance of that archive should be transparent, and is the complete +responsibility of the PLaneT client. + +2. Client behavior + +The PLaneT client receives user requests (i.e., the "(require (planet ...))" +forms) and loads the appropriate modules in response. In the course of handling +these requests it may download new code packages from the PLaneT server. + +2.1 User interface + +The structure of user PLaneT invocations is listed below. + +PLANET-REQUEST ::= (planet FILE-NAME PKG-SPEC [PATH ...]?) +FILE-NAME ::= string +PKG-SPEC ::= string | (FILE-PATH ... PKG-NAME) + | (FILE-PATH ... PKG-NAME VER-SPEC) +VER-SPEC ::= Nat | (Nat MINOR) +MINOR ::= Nat | (Nat Nat) | (= Nat) | (+ Nat) | (- Nat) +FILE-PATH ::= string +PKG-NAME ::= string +OWNER-NAME ::= string +PATH ::= string + +All strings must be legal filename strings. + +When encountered, a planet-request is interpreted as requiring the given file +name from the given logical package, specified by the package spec and the +collection specification, if given. If no VER-SPEC is provided, the most recent +version is assumed. If no owner-name/path ... clause is provided, the default +package is assumed. + +2. PLaneT protocol + +PLaneT clients support two protocols for communicating with the PLaneT server: +the standard HTTP GET/response system (currently the default) and a specialized +TCP-based protocol that may become more important if PLaneT becomes smarter +about downloading packages behind the scenes. + +In the following sections we describe the specialized protocol only. + +2.1 Overview + +1. PLaneT client establishes TCP connection to PLaneT server. +2. Client transmits a version specifier. +3. Server either refuses that version and closes connection or accepts. +4. Client transmits a sequence of requests terminated by a special + end-of-request marker. Simultaneously, server transmits responses to those + requests. +5. Once the server has handled every request, it closes the connection. + + +I am concerned about the overhead of opening and closing TCP connections for a +large program with many requires, so I want to allow many requests and +responses over the same connection. Unfortunately there's a wrinkle: the +standard client, implemented the obvious way, would be unable to send more than +one request at a time because it gets invoked purely as a response to a require +form and must load an appropriate file before it returns. This means I can't +batch up multiple requires, at least not with an obvious implementation. + +A possible solution would be to implement an install program that walks over +the syntax tree of a program and gathers all requires, then communicates with +the server and learns what additional packages would be necessary due to those +requires, and then downloads all of them at once. We would have to implement +both methods simultaneously, though, to allow for REPL-based PLaneT use and +dynamic-require (unless we want it to be a runtime exception to use PLaneT from +the REPL or via dynamic-require, something I'd rather not do), so I want a +protocol that will allow both forms of access easily. This protocol does that, +and doesn't require too much additional overhead in the case that the client +only takes one package at a time. + +2.2 Communication Details + +After a TCP connection is established, the client transmits a +VERSION-SPECIFIER: + +VERSION-SPECIFIER ::= "PLaneT/1.0\n" + +The server responds with a VERSION-RESPONSE: + +VERSION-RESPONSE ::= +| 'ok "\n" +| ('invalid string) "\n" + +where the string in the invalid case is descriptive text intended for display +to the user that may indicate some specific message about the nature of the +error. + +If the server sends 'invalid, the server closes the connection. Otherwise, the +client may send any number of requests, followed by an end-of-request marker: + +REQUESTS ::= { REQUEST "\n"}* 'end "\n" +REQUEST ::= (SEQ-NO 'get PKG-LANG PKG-NAME (Nat | #f) (Nat | #f) (Nat | #f) + [OWNER-NAME PATH ...]?) +PKG-LANG ::= String +SEQ-NO ::= Nat + +The fields in a request are a uniquely identifying sequence number, the literal +symbol 'get, the name of the package to receive, the required major version and +the lowest and highest acceptable version (with #f meaning that there is no +constraint for that field, and a #f in major-version field implying that both +other fields must also be #f), and the package path. + +As the client is transmitting a REQUESTS sequence, the server begins responding +to it with RESPONSE structures, each with a sequence number indicating to which +request it is responding (except in the case of input too garbled to extract a +sequence number): + +RESPONSE ::= +| ('error 'malformed-input string) "\n" +| (SEQ-NO 'error 'malformed-request string) "\n" +| (SEQ-NO 'bad-language string) "\n" +| (SEQ-NO 'get 'ok Nat Nat Nat) "\n" BYTE-DATA +| (SEQ-NO 'get 'error ERROR-CODE string) "\n" + +ERROR-CODE ::= 'not-found + +If the server receives a malformed request, it may close connection after +sending a malformed-request response without processing any other +requests. Otherwise it must process all requests even in the event of an +error. On a successful get, the three numbers the server returns are the +matched package's major version, the matched package's minor version, and the +number of bytes in the package. + +3 Client Download Policies + +Racket invokes the PLaneT client once for each instance of a require-planet +form in a program being run (i.e., the transitive closure of the "requires" +relation starting from some specified root module; this closure is calculable +statically). At each of these invocations, the client examines its internal +cache to see if an appropriate module exists that matches the specification +given by the user (for details see the next section). If one does, the client +loads that module and returns. If none does, it initiates a transaction with +the server using the PLaneT protocol described in the previous subsection and +sends a single request consisting of the user's request. It installs the +resulting .plt file and then loads the appropriate file. + +The client keeps a cache of downloaded packages locally. It does so in the +$PLTCOLLECTS/planet/cache/ directory and subdirectories, in an intuitive +manner: each item in the package's path in the PLaneT require line correspond +to a subdirectory in the cache directory, starting with the owner name. (They +should be unpacked relative to some user-specific rather than +installation-specific place, possibly, but that's difficult to do so we won't +do it yet). + +To check whether a package is installed when attempting to satisfy a +requirement, the client checks its cache to see if an appropriate entry exists +in its link-table for that require line. If one exists, it uses the named +package directly. If none exists, it checks to see if there is an appropriate +subdirectory. + +||# + + +;; This `resolver' no longer fits the normal protocol for a +;; module name resolver, because it accepts an extra argument in +;; the second case. The extra argument is a parameterization +;; to use for installation actions. +(define resolver + (case-lambda + [(name) (void)] + [(spec module-path stx load? orig-paramz) + ;; ensure these directories exist + (make-directory* (PLANET-DIR)) + (make-directory* (CACHE-DIR)) + (establish-diamond-property-monitor) + (planet-resolve spec + (current-module-declare-name) + stx + load? + orig-paramz)])) + +(require racket/tcp + racket/port + racket/match + racket/path + racket/file + racket/date + + net/url + net/head + + "../config.rkt" + "planet-shared.rkt" + "linkage.rkt" + "parsereq.rkt" + + "../terse-info.rkt" + compiler/cm) + +(provide (rename-out [resolver planet-module-name-resolver]) + resolve-planet-path + pkg-spec->full-pkg-spec + get-package-from-cache + get-package-from-server + download-package + pkg->download-url + pkg-promise->pkg + install-pkg + get-planet-module-path/pkg + download? + install? + (struct-out exn:fail:planet)) + +;; if #f, will not install packages and instead raise a exn:fail:install? error +(define install? (make-parameter #t)) +;; if #f, will not download packages and instead raise a exn:fail:install? error +(define download? (make-parameter #t)) +(define-struct (exn:fail:planet exn:fail) ()) + +;; update doc index only once for a set of installs: +(define planet-nested-install (make-parameter #f)) + +;; ============================================================================= +;; DIAMOND PROPERTY STUFF +;; make sure a module isn't loaded twice with two different versions +;; ============================================================================= +(define VER-CACHE-NAME #f) + +(define (establish-diamond-property-monitor) + (unless VER-CACHE-NAME (set! VER-CACHE-NAME (gensym))) + (unless (namespace-variable-value VER-CACHE-NAME #t (lambda () #f)) + (namespace-set-variable-value! VER-CACHE-NAME (make-hash)))) + +(define (the-version-cache) (namespace-variable-value VER-CACHE-NAME)) +(define (pkg->diamond-key pkg) (cons (pkg-name pkg) (pkg-route pkg))) + +(define (pkg-matches-bounds? pkg bound-info) + (match-let ([(list maj lo hi) bound-info]) + (and (= maj (pkg-maj pkg)) + (or (not lo) (>= (pkg-min pkg) lo)) + (or (not hi) (<= (pkg-min pkg) hi))))) + +;; COMPAT ::= 'none | 'all | `(all-except ,VER-SPEC ...) | `(only ,VER-SPEC ...) +;; build-compatibility-fn : COMPAT -> PKG -> bool +(define (build-compatibility-fn compat-data) + (define pre-fn + (match compat-data + [`none (lambda (_) #f)] + [`all (lambda (_) #t)] + [`(all-except ,vspec ...) + (let ([bounders (map (λ (x) (version->bounds x (λ (_) #f))) vspec)]) + (if (andmap (lambda (x) x) bounders) + (lambda (v) + (not (ormap (lambda (bounder) (pkg-matches-bounds? v bounder)) + bounders))) + #f))] + [`(only ,vspec ...) + (let ([bounders (map (λ (x) (version->bounds x (λ (_) #f))) vspec)]) + (if (andmap (lambda (x) x) bounders) + (lambda (v) + (andmap (lambda (bounder) (pkg-matches-bounds? v bounder)) + bounders)) + #f))] + [_ #f])) + (or pre-fn (lambda (x) #f))) + +;; can-be-loaded-together? : pkg pkg -> boolean +;; side constraint: pkg1 and pkg2 are versions of the same package assumption: +;; pkg1 and pkg2 are versions of the same package determines if the two +;; versions are side-by-side compatible +(define (can-be-loaded-together? pkg1 pkg2) + (cond [(pkg> pkg1 pkg2) (can-be-loaded-together? pkg2 pkg1)] + [(pkg= pkg1 pkg2) #t] + [(pkg< pkg1 pkg2) + (let* ([info (pkg->info pkg2)] + [compat? (build-compatibility-fn + (info 'can-be-loaded-with (lambda () 'none)))]) + (compat? pkg1))])) + +;; stx->origin-string : stx option -> string +;; returns a description [e.g. file name, line#] of the given syntax +(define (stx->origin-string stx) + (if stx (format "~a" (syntax-source stx)) "[unknown]")) + +(define (add-pkg-to-diamond-registry! pkg stx) + (let ([loaded-packages + (hash-ref (the-version-cache) (pkg->diamond-key pkg) '())]) + (unless (list? loaded-packages) + (error 'PLaneT "Inconsistent state: expected loaded-packages to be a list, received: ~s" loaded-packages)) + (let ([all-violations '()]) + (for-each + (lambda (already-loaded-pkg-record) + (let* ([already-loaded-pkg (car already-loaded-pkg-record)] + [prior-stx (cadr already-loaded-pkg-record)] + [prior-stx-origin-string (stx->origin-string prior-stx)]) + (unless (can-be-loaded-together? pkg already-loaded-pkg) + (set! + all-violations + (cons + (list + stx + (make-exn:fail + (format + "Package ~a loaded twice with multiple incompatible versions: +~a attempted to load version ~a.~a while version ~a.~a was already loaded by ~a" + (pkg-name pkg) + (stx->origin-string stx) + (pkg-maj pkg) + (pkg-min pkg) + (pkg-maj already-loaded-pkg) + (pkg-min already-loaded-pkg) + prior-stx-origin-string) + (current-continuation-marks))) + all-violations))))) + loaded-packages) + (unless (null? all-violations) + (let ([worst (or (assq values all-violations) (car all-violations))]) + (raise (cadr worst))))) + (hash-set! (the-version-cache) + (pkg->diamond-key pkg) + (cons (list pkg stx) loaded-packages)))) + +;; ============================================================================= +;; MAIN LOGIC +;; Handles the overall functioning of the resolver +;; ============================================================================= + +;; planet-resolve : PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> symbol +;; resolves the given request. Returns a name corresponding to the module in +;; the correct environment +(define (planet-resolve spec rmp stx load? orig-paramz) + ;; install various parameters that can affect the compilation of a planet package back to their original state + (parameterize ([current-compile (call-with-parameterization orig-paramz current-compile)] + [current-eval (call-with-parameterization orig-paramz current-eval)] + [use-compiled-file-paths (call-with-parameterization orig-paramz use-compiled-file-paths)] + [current-library-collection-paths (call-with-parameterization orig-paramz current-library-collection-paths)]) + (let-values ([(path pkg) (get-planet-module-path/pkg spec rmp stx)]) + (when load? (add-pkg-to-diamond-registry! pkg stx)) + (do-require path (pkg-path pkg) rmp stx load?)))) + +;; resolve-planet-path : planet-require-spec -> path +;; retrieves the path to the given file in the planet package. downloads and +;; installs the package if necessary +(define (resolve-planet-path spec) + (let-values ([(path pkg) (get-planet-module-path/pkg spec #f #f)]) + path)) + +;; get-planet-module-path/pkg :PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG) +;; returns the matching package and the file path to the specific request +(define (get-planet-module-path/pkg spec rmp stx) + (request->pkg (spec->req spec stx) rmp stx)) + +;; request->pkg : request (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG) +(define (request->pkg req rmp stx) + (let* ([result (get-package rmp (request-full-pkg-spec req))]) + (cond [(string? result) + (raise-syntax-error 'require result stx)] + [(pkg? result) + (values (apply build-path (pkg-path result) + (append (request-path req) (list (request-file req)))) + result)]))) + +;; PKG-GETTER ::= module-path pspec +;; (pkg -> A) +;; ((uninstalled-pkg -> void) +;; (pkg -> void) +;; ((string | #f) -> string | #f) -> A) +;; -> A +;; +;; a pkg-getter is a function that tries to fetch a package; it is written in a +;; quasi-cps style; the first argument is what it calls to succeed, and the +;; second argument is what it calls when it fails. In the second case, it must +;; provide two things: a function to take action if a match is found +;; eventually, and a function that gets to mess with the error message if the +;; entire message eventually fails. + +;; get-package : (resolved-module-path | #f) FULL-PKG-SPEC -> (PKG | string) +;; gets the package specified by pspec requested by the module in the given +;; module path, or returns a descriptive error message string if that's not +;; possible +(define (get-package rmp pspec) + (let loop ([getters (*package-search-chain*)] + [pre-install-updaters '()] + [post-install-updaters '()] + [error-reporters '()]) + (if (null? getters) + ;; we have failed to fetch the package, generate an appropriate error + ;; message and bail + (let ([msg (foldl (λ (f str) (f str)) #f error-reporters)]) + (or msg (format "Could not find package matching ~s" + (list (pkg-spec-name pspec) + (pkg-spec-maj pspec) + (list (pkg-spec-minor-lo pspec) + (pkg-spec-minor-hi pspec)) + (pkg-spec-path pspec))))) + ;; try the next error reporter. recursive call is in the failure + ;; continuation + ((car getters) + rmp + pspec + (λ (pkg) + (when (uninstalled-pkg? pkg) + (for-each (λ (u) (u pkg)) pre-install-updaters)) + (let ([installed-pkg (pkg-promise->pkg pkg)]) + (for-each (λ (u) (u installed-pkg)) post-install-updaters) + installed-pkg)) + (λ (pre-updater post-updater error-reporter) + (loop (cdr getters) + (cons pre-updater pre-install-updaters) + (cons post-updater post-install-updaters) + (cons error-reporter error-reporters))))))) + +;; ============================================================================= +;; PHASE 2: CACHE SEARCH +;; If there's no linkage, there might still be an appropriate cached module +;; (either installed or uninstalled) +;; ============================================================================= + +;; get/installed-cache : pkg-getter +(define (get/installed-cache _ pkg-spec success-k failure-k) + (let ([p (lookup-package pkg-spec)]) + (if p (success-k p) (failure-k void void (λ (x) x))))) + +;; get-package-from-cache : FULL-PKG-SPEC -> PKG | #f +(define (get-package-from-cache pkg-spec) + (lookup-package pkg-spec)) + +;; get/uninstalled-cache-dummy : pkg-getter +;; always fails, but records the package to the uninstalled package cache upon +;; the success of some other getter later in the chain. +(define (get/uninstalled-cache-dummy _ pkg-spec success-k failure-k) + (failure-k save-to-uninstalled-pkg-cache! void (λ (x) x))) + +;; get/uninstalled-cache : pkg-getter +;; note: this does not yet work with minimum-required-version specifiers if you +;; install a package and then use an older mzscheme +(define (get/uninstalled-cache _ pkg-spec success-k failure-k) + (let ([p (lookup-package pkg-spec (UNINSTALLED-PACKAGE-CACHE))]) + (if (and p (file-exists? (build-path (pkg-path p) + (pkg-spec-name pkg-spec)))) + (begin + (planet-log "found local, uninstalled copy of package at ~a" + (build-path (pkg-path p) + (pkg-spec-name pkg-spec))) + (success-k + ;; note: it's a little sloppy that lookup-pkg returns PKG structures, + ;; since it doesn't actually know whether or not the package is + ;; installed. hence I have to convert what appears to be an installed + ;; package into an uninstalled package + (make-uninstalled-pkg (build-path (pkg-path p) (pkg-spec-name pkg-spec)) + pkg-spec + (pkg-maj p) + (pkg-min p)))) + (failure-k void void (λ (x) x))))) + +;; save-to-uninstalled-pkg-cache! : uninstalled-pkg -> path[file] +;; copies the given uninstalled package into the uninstalled-package cache, +;; replacing any old file that might be there. Returns the path it copied the +;; file into. +(define (save-to-uninstalled-pkg-cache! uninst-p) + (let* ([pspec (uninstalled-pkg-spec uninst-p)] + [owner (car (pkg-spec-path pspec))] + [name (pkg-spec-name pspec)] + [maj (uninstalled-pkg-maj uninst-p)] + [min (uninstalled-pkg-min uninst-p)] + [dir (build-path (UNINSTALLED-PACKAGE-CACHE) + owner + name + (number->string maj) + (number->string min))] + [full-pkg-path (build-path dir name)]) + (make-directory* dir) + (unless (equal? (normalize-path (uninstalled-pkg-path uninst-p)) + (normalize-path full-pkg-path)) + (when (file-exists? full-pkg-path) (delete-file full-pkg-path)) + (copy-file (uninstalled-pkg-path uninst-p) full-pkg-path)) + full-pkg-path)) + +;; ============================================================================= +;; PHASE 3: SERVER RETRIEVAL +;; Ask the PLaneT server for an appropriate package if we don't have one +;; locally. +;; ============================================================================= + +(define (get/server _ pkg-spec success-k failure-k) + (let ([p (get-package-from-server pkg-spec)]) + (cond + [(pkg-promise? p) (success-k p)] + [(string? p) + ;; replace any existing error message with the server download error + ;; message + (planet-log p) + (failure-k void void (λ (_) p))]))) + +;; get-package-from-server : FULL-PKG-SPEC -> PKG-PROMISE | #f | string[error message] +;; downloads the given package file from the PLaneT server and installs it in +;; the uninstalled-packages cache, then returns a promise for it +(define (get-package-from-server pkg) + (match (download-package pkg) + [(list #t tmpfile-path maj min) + (let* ([upkg (make-uninstalled-pkg tmpfile-path pkg maj min)] + [cached-path (save-to-uninstalled-pkg-cache! upkg)] + [final (make-uninstalled-pkg cached-path pkg maj min)]) + (unless (equal? (normalize-path tmpfile-path) + (normalize-path cached-path)) + (delete-file tmpfile-path)) ;; remove the tmp file, we're done with it + final)] + [(list #f str) + (string-append "PLaneT could not find the requested package: " str)] + [(? string? s) + (string-append "PLaneT could not download the requested package: " s)])) + +(define (download-package pkg) + (unless (download?) + (raise (make-exn:fail:planet + (format + "PLaneT error: cannot download package ~s since the download? parameter is set to #f" + (list (car (pkg-spec-path pkg)) (pkg-spec-name pkg))) + (current-continuation-marks)))) + ((if (USE-HTTP-DOWNLOADS?) download-package/http download-package/planet) + pkg)) + +(define (current-time) + (let ([date (seconds->date (current-seconds))]) + (parameterize ([date-display-format 'rfc2822]) + (format "~a ~a:~a:~a" + (date->string date) + (date-hour date) + (date-minute date) + (date-second date))))) + +;; pkg-promise->pkg : pkg-promise -> pkg +;; "forces" the given pkg-promise (i.e., installs the package if it isn't +;; installed yet) +(define (pkg-promise->pkg p) + (cond [(pkg? p) p] + [(uninstalled-pkg? p) + (install-pkg (uninstalled-pkg-spec p) + (uninstalled-pkg-path p) + (uninstalled-pkg-maj p) + (uninstalled-pkg-min p))])) + +;; install-pkg : FULL-PKG-SPEC path[file] Nat Nat -> PKG +;; install the given pkg to the planet cache and return a PKG representing the +;; installed file +(define (install-pkg pkg path maj min) + (let ([pkg-path (pkg-spec-path pkg)] + [pkg-name (pkg-spec-name pkg)] + [pkg-string (pkg-spec->string pkg)]) + (unless (install?) + (raise (make-exn:fail:planet + (format + "PLaneT error: cannot install package ~s since the install? parameter is set to #f" + (list (car pkg-path) pkg-name maj min)) + (current-continuation-marks)))) + (let* ([owner (car pkg-path)] + [extra-path (cdr pkg-path)] + [the-dir + (apply build-path (CACHE-DIR) + (append pkg-path (list pkg-name + (number->string maj) + (number->string min))))] + [was-nested? (planet-nested-install)]) + (if (directory-exists? the-dir) + (raise (make-exn:fail + "PLaneT error: trying to install already-installed package" + (current-continuation-marks))) + (parameterize ([planet-nested-install #t]) + (planet-terse-log 'install pkg-string) + (with-logging + (LOG-FILE) + (lambda () + (printf "\n============= Installing ~a on ~a =============\n" + pkg-name + (current-time)) + ;; oh man is this a bad hack! + (parameterize ([current-namespace (make-base-namespace)]) + (let ([ipp (dynamic-require 'setup/plt-single-installer + 'install-planet-package)] + [rud (dynamic-require 'setup/plt-single-installer + 'reindex-user-documentation)] + [msfh (dynamic-require 'compiler/cm 'manager-skip-file-handler)]) + (parameterize ([msfh (manager-skip-file-handler)] + [use-compiled-file-paths (list (string->path "compiled"))]) + (ipp path the-dir (list owner pkg-name + extra-path maj min)) + (unless was-nested? + (planet-terse-log 'docs-build pkg-string) + (printf "------------- Rebuilding documentation index -------------\n") + (rud))))))) + (planet-terse-log 'finish pkg-string) + (make-pkg pkg-name pkg-path + maj min the-dir 'normal)))))) + +;; download-package : FULL-PKG-SPEC -> RESPONSE +;; RESPONSE ::= (list #f string) | (list #t path[file] Nat Nat) + +;; downloads the given package and returns (list bool string): if bool is #t, +;; the path is to a file that contains the package. If bool is #f, the package +;; didn't exist and the string is the server's informative message. +;; raises an exception if some protocol failure occurs in the download process +(define (download-package/planet pkg) + + (define stupid-internal-define-syntax + (let ([msg (format "downloading ~a from ~a via planet protocol" + (pkg-spec->string pkg) + (PLANET-SERVER-NAME))]) + (planet-terse-log 'download (pkg-spec->string pkg)) + (planet-log msg))) + + (define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT))) + + (define (close-ports) (close-input-port ip) (close-output-port op)) + + (define (request-pkg-list pkgs) + (for-each/n (lambda (pkg seqno) + (write-line (list* seqno 'get + (DEFAULT-PACKAGE-LANGUAGE) + (pkg-spec-name pkg) + (pkg-spec-maj pkg) + (pkg-spec-minor-lo pkg) + (pkg-spec-minor-hi pkg) + (pkg-spec-path pkg)) + op)) + pkgs) + (write-line 'end op) + (flush-output op)) + + (define (state:initialize) + (fprintf op "PLaneT/1.0\n") + (flush-output op) + (match (read ip) + ['ok (state:send-pkg-request)] + [(list 'invalid (? string? msg)) (state:abort (string-append "protocol version error: " msg))] + [bad-msg (state:abort (format "server protocol error (received invalid response): ~a" bad-msg))])) + + (define (state:send-pkg-request) + (request-pkg-list (list pkg)) + (state:receive-package)) + + (define (state:receive-package) + (match (read ip) + [(list _ 'get 'ok (? nat? maj) (? nat? min) (? nat? bytes)) + (let ([filename (make-temporary-file "planettmp~a.plt")]) + (read-char ip) ; throw away newline that must be present + (read-n-chars-to-file bytes ip filename) + (list #t filename maj min))] + [(list _ 'error 'malformed-request (? string? msg)) + (state:abort (format "Internal error (malformed request): ~a" msg))] + [(list _ 'get 'error 'not-found (? string? msg)) + (state:failure (format "Server had no matching package: ~a" msg))] + [(list _ 'get 'error (? symbol? code) (? string? msg)) + (state:abort (format "Unknown error ~a receiving package: ~a" code msg))] + [bad-response (state:abort (format "Server returned malformed message: ~e" bad-response))])) + + (define (state:abort msg) + (raise (make-exn:i/o:protocol msg (current-continuation-marks)))) + (define (state:failure msg) (list #f msg)) + + (with-handlers ([void (lambda (e) (close-ports) (raise e))]) + (begin0 + (state:initialize) + (close-ports)))) + +;; ------------------------------------------------------------ +;; HTTP VERSION OF THE PROTOCOL + +;; pkg->servlet-args : FULL-PKG-SPEC -> environment[from net/url] +;; gets the appropriate query arguments to request the given package from the +;; PLaneT HTTP download servlet +(define (pkg->servlet-args pkg) + (let ([get (lambda (access) (format "~s" (access pkg)))]) + `((lang . ,(format "~s" (DEFAULT-PACKAGE-LANGUAGE))) + (name . ,(get pkg-spec-name)) + (maj . ,(get pkg-spec-maj)) + (min-lo . ,(get pkg-spec-minor-lo)) + (min-hi . ,(get pkg-spec-minor-hi)) + (path . ,(get pkg-spec-path))))) + +;; get-http-response-code : header[from net/head] -> string or #f +;; gets the HTTP response code in the given header +(define (get-http-response-code header) + (let ([parsed (regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header)]) + (and parsed (cadr parsed)))) + +;; pkg->download-url : FULL-PKG-SPEC -> url +;; gets the download url for the given package +(define (pkg->download-url pkg) + (struct-copy url + (string->url (HTTP-DOWNLOAD-SERVLET-URL)) + [query (pkg->servlet-args pkg)])) + +;; download-package/http : FULL-PKG-SPEC -> RESPONSE +;; a drop-in replacement for download-package that uses HTTP rather than the +;; planet protocol. The HTTP protocol does not allow any kind of complicated +;; negotiation, but it appears that many more users can make HTTP requests than +;; requests from nonstandard protocols. +(define (download-package/http pkg) + (let/ec return + (let loop ([attempts 1]) + (when (> attempts 5) + (return "Download failed too many times (possibly due to an unreliable network connection)")) + + (let ([msg (format "downloading ~a from ~a via HTTP~a" + (pkg-spec->string pkg) + (PLANET-SERVER-NAME) + (if (= attempts 1) + "" + (format ", attempt #~a" attempts)))]) + (planet-terse-log 'download (pkg-spec->string pkg)) + (planet-log "~a" msg)) + + (with-handlers ([exn:fail:network? (λ (e) (return (exn-message e)))]) + (let* ([target (pkg->download-url pkg)] + [ip (get-impure-port target)] + [head (purify-port ip)] + [response-code/str (get-http-response-code head)] + [response-code (and response-code/str + (string->number response-code/str))]) + + (define (abort msg) + (close-input-port ip) + (return msg)) + + (case response-code + [(#f) + (abort (format "Server returned invalid HTTP response code ~s" + response-code/str))] + [(200) + (let ([maj/str (extract-field "Package-Major-Version" head)] + [min/str (extract-field "Package-Minor-Version" head)] + [content-length/str (extract-field "Content-Length" head)]) + (unless (and maj/str min/str content-length/str + (nat? (string->number maj/str)) + (nat? (string->number min/str)) + (nat? (string->number content-length/str))) + (abort "Server did not include valid major and minor version information")) + (let* ([filename (make-temporary-file "planettmp~a.plt")] + [maj (string->number maj/str)] + [min (string->number min/str)] + [content-length (string->number content-length/str)] + [op (open-output-file filename #:exists 'truncate/replace)]) + (copy-port ip op) + (close-input-port ip) + (close-output-port op) + (if (= (file-size filename) content-length) + (list #t filename maj min) + (loop (add1 attempts)))))] + [(404) + (begin0 (list #f (format "Server had no matching package: ~a" + (read-line ip))) + (close-input-port ip))] + [(400) + (abort (format "Internal error (malformed request): ~a" + (read-line ip)))] + [(500) + (abort (format "Server internal error: ~a" + (apply string-append + (let loop () + (let ([line (read-line ip)]) + (if (eof-object? line) + '() + (list* line "\n" (loop))))))))] + [else + (abort (format "Internal error (unknown HTTP response code ~a)" + response-code))])))))) + +;; formats the pkg-spec back into a string the way the user typed it in, +;; except it never shows the minor version number (since some later one may actually be being used) +;; assumes that the pkg-spec comes from the command-line +(define (pkg-spec->string pkg) + (format "~a/~a~a" + (if (pair? (pkg-spec-path pkg)) + (car (pkg-spec-path pkg)) + "<>") ;; this shouldn't happen + (regexp-replace #rx"\\.plt$" (pkg-spec-name pkg) "") + (if (pkg-spec-maj pkg) + (format ":~a" (pkg-spec-maj pkg)) + ""))) + +;; ============================================================================= +;; MODULE MANAGEMENT +;; Handles interaction with the module system +;; ============================================================================= + +;; do-require : path path symbol syntax -> symbol +;; requires the given filename, which must be a module, in the given path. +(define (do-require file-path package-path module-path stx load?) + (parameterize ([current-load-relative-directory package-path]) + ((current-module-name-resolver) file-path module-path stx load?))) + +(define *package-search-chain* + (make-parameter + (list get/linkage + get/installed-cache + get/uninstalled-cache-dummy + get/server + get/uninstalled-cache))) + +;; ============================================================ +;; UTILITY +;; A few small utility functions + +;; make-directory*/paths : path -> (listof path) +;; like make-directory*, but returns what directories it actually created +(define (make-directory*/paths dir) + (let ([dir (if (string? dir) (string->path dir) dir)]) + (let-values ([(base name dir?) (split-path dir)]) + (cond [(directory-exists? dir) '()] + [(directory-exists? base) (make-directory dir) (list dir)] + [else (let ([dirs (make-directory*/paths base)]) + (make-directory dir) + (cons dir dirs))])))) diff --git a/collects/planet/private/util.scrbl b/collects/planet/private/util.scrbl new file mode 100644 index 0000000000..495b82d02d --- /dev/null +++ b/collects/planet/private/util.scrbl @@ -0,0 +1,651 @@ +#lang scribble/manual + +@(require + (for-label + racket/base + scribble/manual + planet/resolver + planet/config + planet/util + planet/version + planet/syntax + planet/scribble)) + +@title{Utility Libraries} + +The planet collection provides configuration and utilities for using PLaneT. + +@section{Resolver} + +@defmodule[planet/resolver] + +The primary purpose of this library to for @racket[require] to find +@PLaneT packages. It also, however, provides some utilities for manipulating +the resolvers behavior. + +@defproc*[(((planet-module-name-resolver [r-m-p resolved-module-path?]) + void?) + ((planet-module-name-resolver [spec (or/c module-path? path?)] + [module-path (or/c #f resolved-module-path?)] + [stx (or/c #f syntax?)] + [load boolean?] + [orig-paramz parameterization?]) + resolved-module-path?))]{ + This implements the @|PLaneT| module resolution process. It is @racket[dynamic-require]d + by racket when the first planet module require is needed. It acts much like a + @racket[current-module-name-resolver] would, but racket provides it with a special + @racket[parameterization?] (giving it special privileges) that it uses when installing new packages. +} + +@defproc[(get-planet-module-path/pkg [spec (or/c module-path? path?)] + [module-path (or/c #f resolved-module-path?)] + [stx (or/c #f syntax?)]) + (values path? pkg?)]{ + Returns the path corresponding to the planet package (interpreting the arguments + the same way as @racket[planet-module-name-resolver] and @racket[(current-module-name-resolver)]). +} + +@defproc[(resolve-planet-path [planet-path any/c]) path?]{ + Returns the path where the file named by the require spec @racket[planet-path] is located in the current installation. +} + +@defparam[download? dl? boolean?]{ + A parameter that controls if @PLaneT attempts to download a planet package that isn't already present. + If the package isn't present, the resolver will raise the @racket[exn:fail:planet?] exception + instead of downloading it. +} + +@defparam[install? inst? boolean?]{ + A parameter that controls if @PLaneT attempts to install a planet package that isn't already installed. + If the package isn't installed, the resolver will raise the @racket[exn:fail:planet?] exception + instead of installing it. +} + +@section{Client Configuration} + +@defmodule[planet/config] + +The @racketmodname[planet/config] library provides several parameters +useful for configuring how PLaneT works. + +Note that while these parameters can be useful to modify +programmatically, PLaneT code runs at module-expansion time, so +most user programs cannot set them until PLaneT has already +run. Therefore, to meaningfully change these settings, it is best to +manually edit the @filepath{config.rkt} file. + +@defparam[PLANET-BASE-DIR dir path-string?]{ + The root of the tree where planet stores all of its files. Defaults to + @racketblock[(let ([plt-planet-dir-env-var (getenv "PLTPLANETDIR")]) + (if plt-planet-dir-env-var + (string->path plt-planet-dir-env-var) + (build-path (find-system-path 'addon-dir) + "planet" + (PLANET-CODE-VERSION))))] +} + +@defparam[PLANET-DIR dir path-string?]{ +The root of the version-specific PLaneT files. +Defaults to @racket[(build-path (PLANET-BASE-DIR) (version))]. +} + +@defparam[CACHE-DIR dir path-string?]{ +The root of the PLaneT client's cache directory.} + +@defparam[UNINSTALLED-PACKAGE-CACHE dir path-string?]{ +The root of the PLaneT client's uninstalled-packages cache. PLaneT +stores package distribution files in this directory, and searches for +them in this directory for them if necessary. Unlike the main PLaneT +cache, which contains compiled files and is specific to each +particular version of Racket, the uninstalled package cache is +shared by all versions of Racket that use the same package +repository, and it is searched if a package is not installed in the +primary cache and cannot be downloaded from the central PLaneT repository +(for instance due to a loss of Internet connectivity). This behavior +is intended to primarily benefit users who upgrade their Racket +installations frequently.} + +@defparam[LINKAGE-FILE file path-string?]{ +The file to use as the first place PLaneT looks to determine how a +particular PLaneT dependence in a file should be satisfied. The +contents of this file are used to ensure that no "magic upgrades" +occur after a package is installed. The default is the file @filepath{LINKAGE} +in the root PLaneT directory.} + +@defparam[LOG-FILE file (or/c path-string? false?)]{ +If @racket[#f], indicates that no logging should take place. Otherwise +specifies the file into which logging should be written. The default +is the file @filepath{INSTALL-LOG} in the root PLaneT directory.} + +@defboolparam[USE-HTTP-DOWNLOADS? bool]{ +PLaneT can use two different protocols to retrieve packages. If @racket[#t], +PLaneT will use the HTTP protocol; if @racket[#f] it will use the custom-built +PLaneT protocol. The default value for this parameter is @racket[#t] and setting +this parameter to @racket[#f] is not recommended.} + +@defparam[HTTP-DOWNLOAD-SERVLET-URL url string?]{ +The URL for the servlet that will provide PLaneT packages if +@racket[USE-HTTP-DOWNLOADS?] is @racket[#t], represented as a string. +This defaults to the value of the @indexed-envvar{PLTPLANETURL} environment +variable if it is set and otherwise is +@racket["http://planet.racket-lang.org/servlets/planet-servlet.rkt"].} + +@defparam[PLANET-SERVER-NAME host string?]{ +The name of the PLaneT server to which the client should connect if +@racket[USE-HTTP-DOWNLOADS?] is @racket[#f]. The default value for this parameter is +@racket["planet.racket-lang.org"].} + +@defparam[PLANET-SERVER-PORT port natural-number?]{ +The port on the server the client should connect to if +@racket[USE-HTTP-DOWNLOADS?] is @racket[#f]. The default value for this parameter is +@racket[270].} + +@defparam[HARD-LINK-FILE file path?]{ + The name of the file where hard links are saved. Defaults to + @racket[(build-path (PLANET-BASE-DIR) (version) "HARD-LINKS")]. +} +@defparam[PLANET-ARCHIVE-FILTER regexp-filter (or/c #f string? regexp?)]{ + A regular-expression based filter that is used to skip files when building a @|PLaneT| archive. +} +@defparam[PLANET-CODE-VERSION vers string?]{ + Used to compute @racket[PLANET-BASE-VERSION]. +} + +@defparam[DEFAULT-PACKAGE-LANGUAGE vers string?]{ + The package language used when communicating with the server to find + which package to download. + + Defaults to @racket[(version)]. +} + +@section{Package Archives} + +@defmodule[planet/planet-archives] + +@defproc[(get-all-planet-packages) + (listof (list/c (and/c path? absolute-path?) string? string? (listof string?) + exact-nonnegative-integer? + exact-nonnegative-integer?))]{ + Returns the installed planet package. Each element of the result list corresponds to + a single package. The first element in an inner list is the location of the installed files. + The second and third elements are the owner and package names. The last two elements + are the major and minor verisons +} + +@defproc[(get-installed-planet-archives) + (listof (list/c (and/c path? absolute-path?) string? string? (listof string?) + exact-nonnegative-integer? + exact-nonnegative-integer?))]{ + Like @racket[get-all-planet-archives], except that it does not return packages linked in + with ``raco planet link''. + +} + +@defproc[(get-hard-linked-packages) + (listof (list/c (and/c path? absolute-path?) string? string? (listof string?) + exact-nonnegative-integer? + exact-nonnegative-integer?))]{ + Like @racket[get-all-planet-archives], except that it return only packages linked in + with ``raco planet link''. + +} + +@section[#:tag "util.rkt"]{Package Utils} + +@defmodule[planet/util] + +The @racketmodname[planet/util] library supports examination of the pieces of +PLaneT. It is meant primarily to support debugging and to allow easier +development of higher-level package-management tools. The +functionality exposed by @seclink["cmdline"]{the @exec{raco planet} command-line tool} is +also available programmatically through this library. + +@defproc[(download/install-pkg [owner string?] + [pkg (and/c string? #rx"[.]plt$")] + [maj natural-number/c] + [min natural-number/c]) + (or/c pkg? #f)]{ +Downloads and installs the package specifed by the given owner name, +package name, major and minor version number. Returns false if no such +package is available; otherwise returns a package structure for the +installed package. + +The @racket[pkg] argument must end with @racket[".plt"]. +} + +@defproc[(install-pkg [pkg-spec pkg-spec?] + [file path-string?] + [maj natural-number/c] + [min natural-number/c]) + (or/c pkg-spec? #f)]{ + Installs the package represented by the arguments, using + the @racket[pkg-spec] argument to find the path and name of + the package to install. + + See @racket[get-package-spec] to build a @racket[pkg-spec] argument. + + Returns a new @racket[pkg-spec?] corresponding to the package + that was actually installed. +} + + + +@defproc[(get-package-spec [owner string?] + [pkg (and/c string? #rx"[.]plt$")] + [maj (or/c #f natural-number/c) #f] + [min (or/c #f natural-number/c) #f]) + pkg-spec?]{ + Builds a @racket[pkg-spec?] corresponding to the package specified by + @racket[owner], @racket[pkg], @racket[maj], and @racket[min]. + + The @racket[pkg] argument must end with the string @racket[".plt"]. +} + +@defproc[(pkg-spec? [v any/c]) boolean?]{ + Recognizes the result of @racket[get-package-spec] (and @racket[install-pkg]). +} + +@defparam[current-cache-contents contents + (listof + (list/c string? + (listof + (list/c string? + (cons/c natural-number/c + (listof natural-number/c))))))]{ +Holds a listing of all package names and versions installed in the +local cache.} + +@defproc[(current-linkage) + (listof (list/c path-string? + (list/c string? + (list/c string?) + natural-number/c + natural-number/c)))]{ +Returns the current linkage table. + +The linkage table is an association between file locations (encoded as path strings) +and concrete planet package versions. If a require line in the associated file requests a package, +this table is consulted to determine a particular concrete package to satisfy the request.} + +@defproc[(make-planet-archive [directory path-string?] + [output-file (or/c path? path-string?) + (string-append (path->string name) ".plt")]) + path-string?]{ +Makes a .plt archive file suitable for PLaneT whose contents are all +files in the given directory and returns that file's name. If the +optional filename argument is provided, that filename will be used as +the output file's name. + +See also @racket[build-scribble-docs?] and @racket[force-package-building?] +} + +@defparam[build-scribble-docs? b boolean?]{ + Determines if @racket[make-planet-archive] builds scribble docs (or not). +} + +@defparam[force-package-building? b boolean?]{ + Determines if @racket[make-planet-archive] is more strict and thus aborts more often. +} + +@defproc[(download-package [pkg-spec pkg-spec?]) + (or/c (list/c #true path? natural-number/c natural-number/c) + string? + (list/c #false string?))]{ + Downloads the package given by @racket[pkg-spec]. If the result is + a list whose first element is @racket[#true], then the package was + downloaded successfully and the rest of the elements of the list + indicate where it was downloaded, and the precise version number. + + The other two possible results indicate errors. If the result is + a list, then the server is saying that there is no matching package; + otherwise the error is some lower-level problem (perhaps no networking, etc.) +} + +@defproc[(pkg->download-url [pkg pkg?]) url?]{ + Returns the url for a given package. +} + +@defproc[(get-package-from-cache [pkg-spec pkg-spec?]) (or/c #false path?)]{ + Returns the location of the already downloaded package, + if it exists (and @racket[#false] otherwise). +} + +@defproc[(lookup-package-by-keys [owner string?] + [name string?] + [major exact-nonnegative-integer?] + [minor-lo exact-nonnegative-integer?] + [minor-hi exact-nonnegative-integer?]) + (or/c (list/c path? + string? + string? + (listof string?) + exact-nonnegative-integer? + exact-nonnegative-integer?) + #false)]{ + Looks up and returns a list representation of the package named by the given owner, + package name, major and (range of) minor version(s). +} + +@defproc[(unpack-planet-archive [plt-file (or/c path? path-string?)] + [output-dir (or/c path? path-string?)]) + any]{ +Unpacks the PLaneT archive with the given filename, placing its contents +into the given directory (creating that path if necessary).} + +@defproc[(remove-pkg [owner string?] + [pkg (and/c string? #rx"[.]plt$")] + [maj natural-number/c] + [min natural-number/c]) + any]{ +Removes the specified package from the local planet cache. +} + +@defproc[(erase-pkg [owner string?] + [pkg (and/c string? #rx"[.]plt$")] + [maj natural-number/c] + [min natural-number/c]) + any]{ +Removes the specified package from the local planet cache and deletes +all of the files corresponding to the package. +} + +@defproc[(display-plt-file-structure [plt-file (or/c path-string? path?)]) + any]{ +Print a tree representing the file and directory structure of the +PLaneT archive .plt file named by @racket[plt-file] to @racket[(current-output-port)].} + +@defproc[(display-plt-archived-file [plt-file (or/c path-string? path?)] + [file-to-print string?]) + any]{ +Print the contents of the file named @racket[file-to-print] within the +PLaneT archive .plt file named by @racket[plt-file] to @racket[(current-output-port)].} + +@defproc[(unlink-all) any]{ +Removes the entire linkage table from the system, which will force all +modules to relink themselves to PLaneT modules the next time they run.} + +@defproc[(add-hard-link [owner string?] + [pkg (and/c string? #rx"[.]plt$")] + [maj natural-number/c] + [min natural-number/c] + [dir path?]) + any]{ +Adds a development link between the specified package and the given +directory; once a link is established, PLaneT will treat the cache as +having a package with the given owner, name, and version whose files +are located in the given path. This is intended for package +development; users only interested in using PLaneT packages +available online should not need to create any development links. + +If the specified package already has a development link, this function +first removes the old link and then adds the new one. + +The @racket[pkg] argument must end with the string @racket[".plt"]. +} + +@defproc[(remove-hard-link [owner string?] + [pkg (and/c string? #rx"[.]plt$")] + [maj natural-number/c] + [min natural-number/c] + [#:quiet? quiet? boolean? #false]) + any]{ +Removes any hard link that may be associated with the given package. + +The @racket[pkg] argument must end with the string @racket[".plt"]. +The @racket[maj] and @racket[min] arguments must be integers. This +procedure signals an error if no such link exists, unless +@racket[#:quiet?] is @racket[#true]. +} + +@defproc[(resolve-planet-path [spec quoted-planet-require-spec?]) + path?]{ +Returns the file system path to the file specified by the given quoted +planet require specification. This function downloads and installs the +specified package if necessary, but does not verify that the actual +file within it actually exists.} + +@defproc[(path->package-version [p path?]) + (or/c (list/c string? string? natural-number/c natural-number/c) #f)]{ + +Given a path that corresponds to a PLaneT package (or some part of one), +produces a list corresponding to its name and version, exactly like +@racket[(this-package-version)]. Given any other path, produces @racket[#f]. + +} + +@defstruct[(exn:fail:planet exn:fail) ([message string?] [continuation-marks continuation-mark-set?])]{ + This exception record is used to report planet-specific exceptions. +} + +@defproc[(pkg? [v any/c]) boolean?]{ + Determines if its argument is a pkg, the representation of an installed package. +} + +@section[#:tag "version.rkt"]{Package Version} + +Provides bindings for @|PLaneT| developers that automatically +produce references to the name and version of the containing @|PLaneT| package +so the same code may be reused across releases without accidentally referring to +a different version of the same package. + +@defmodule[planet/version #:use-sources (planet/private/version)] + +@deftogether[( +@defform[(this-package-version)] +@defform*[[(this-package-version-symbol) + (this-package-version-symbol suffix-id)]] +@defform[(this-package-version-name)] +@defform[(this-package-version-owner)] +@defform[(this-package-version-maj)] +@defform[(this-package-version-min)] +)]{ + +Macros that expand into expressions that evaluate to information about the name, +owner, and version number of the package in which they +appear. @racket[this-package-version] returns a list consisting of a string +naming the package's owner, a string naming the package, a number indicating the +package major version and a number indicating the package minor version, or +@racket[#f] if the expression appears outside the context of a package. +The macros @racket[this-package-version-name], +@racket[this-package-version-owner], @racket[this-package-version-maj], and +@racket[this-package-version-min] produce the relevant fields of the package +version list. + +@racket[this-package-version-symbol] produces a symbol +suitable for use in @racket[planet] module paths. For instance, in version +@racketmodfont{1:0} of the package @racketmodfont{package.plt} owned by +@racketmodfont{author}, @racket[(this-package-version-symbol dir/file)] produces +@racket['author/package:1:0/dir/file]. In the same package, +@racket[(this-package-version-symbol)] produces @racket['author/package:1:0]. + +} + +@defform[(this-package-in suffix-id ...)]{ + +A @racket[require] sub-form that requires modules from within the same @|PLaneT| +package version as the require, as referred to by each @racket[suffix-id]. For +instance, in version @racketmodfont{1:0} of the package +@racketmodfont{package.plt} owned by @racketmodfont{author}, +@racket[(require (this-package-in dir/file))] is equivalent to +@racket[(require (planet author/package:1:0/dir/file))]. + +@italic{Note:} Use @racket[this-package-in] when documenting @|PLaneT| packages +with Scribble to associate each documented binding with the appropriate package. + +} + +@defproc[(make-planet-symbol [stx syntax?] + [suffix (or/c #false string?) #false]) + (or/c #false symbol?)]{ + Returns a symbol representing a require spec for the location of @racket[stx], + as a planet package. +} + +@defproc[(package-version->symbol [ver (or/c (list/c string? string? exact-nonnegative-integer? exact-nonnegative-integer?) + #false)] + [suffix (or/c #false string?) #false]) + (or/c #false symbol?)]{ + Returns a symbol representing the require spec for @racket[ver], + as a planet package. +} + +@section[#:tag "syntax.rkt"]{Macros and Syntax Objects} + +@defmodule[planet/syntax] + +Provides bindings useful for @|PLaneT|-based macros. + +@deftogether[( +@defproc[(syntax-source-planet-package [stx syntax?]) (or/c list? #f)] +@defproc[(syntax-source-planet-package-owner [stx syntax?]) (or/c string? #f)] +@defproc[(syntax-source-planet-package-name [stx syntax?]) (or/c string? #f)] +@defproc[(syntax-source-planet-package-major [stx syntax?]) (or/c integer? #f)] +@defproc[(syntax-source-planet-package-minor [stx syntax?]) (or/c integer? #f)] +@defproc[(syntax-source-planet-package-symbol + [stx syntax?] + [suffix (or/c symbol? #f) #f]) + (or/c symbol? #f)] +)]{ + +Produce output analogous to @racket[this-package-version], +@racket[this-package-version-owner], @racket[this-package-version-name], +@racket[this-package-version-maj], @racket[this-package-version-min], and +@racket[this-package-version-symbol] based on the source location of +@racket[stx]. + +} + +@defproc[(make-planet-require-spec + [stx syntax?] + [suffix (or/c symbol? #f) #f]) + syntax?]{ + +Produces a @racket[require] sub-form for the module referred to by +@racket[suffix] in the @|PLaneT| package containing the source location of +@racket[stx]. + +} + +@section[#:tag "scribble.rkt"]{Scribble Documentation} + +@defmodule[planet/scribble] + +Provides bindings for documenting @|PLaneT| packages. + +@defform[(this-package-in suffix-id ...)]{ + +This binding from @racketmodname[planet/version] is also exported from +@racketmodname[planet/scribble], as it is useful for @racket[for-label] imports +in Scribble documentation. + +} + +@deftogether[( +@defform[(racketmod/this-package maybe-file suffix-id datum ...)] +@defform*[((racketmodname/this-package suffix-id) + (racketmodname/this-package (#,(racket unsyntax) suffix-expr)))] +@defform[(racketmodlink/this-package suffix-id pre-content-expr ...)] +@defform[(defmodule/this-package maybe-req suffix-id maybe-sources pre-flow ...)] +@defform*[((defmodulelang/this-package suffix-id maybe-sources pre-flow ...) + (defmodulelang/this-package suffix-id + #:module-paths (mod-suffix-id ...) maybe-sources + pre-flow ...))] +@defform[(defmodulereader/this-package suffix-id maybe-sources pre-flow ...)] +@defform[(defmodule*/this-package maybe-req (suffix-id ...+) + maybe-sources pre-flow ...)] +@defform*[((defmodulelang*/this-package (suffix-id ...+) + maybe-sources pre-flow ...) + (defmodulelang*/this-package (suffix-id ...+) + #:module-paths (mod-suffix-id ...) maybe-sources + pre-flow ...))] +@defform[(defmodulereader*/this-package (suffix-id ...+) + maybe-sources pre-flow ...)] +@defform[(defmodule*/no-declare/this-package maybe-req (suffix-id ...+) + maybe-sources pre-flow ...)] +@defform*[((defmodulelang*/no-declare/this-package (suffix-id ...+) + maybe-sources pre-flow ...) + (defmodulelang*/no-declare/this-package (suffix-id ...+) + #:module-paths (mod-suffix-id ...) maybe-sources pre-flow ...))] +@defform[(defmodulereader*/no-declare/this-package (suffix-id ...+) + maybe-sources pre-flow ...)] +@defform[(declare-exporting/this-package suffix-id ... maybe-sources)] +)]{ + +Variants of @racket[racketmod], @racket[racketmodname], +@racket[racketmodlink], @racket[defmodule], @racket[defmodulereader], +@racket[defmodulelang], @racket[defmodule*], @racket[defmodulelang*], +@racket[defmodulereader*], @racket[defmodule*/no-declare], +@racket[defmodulelang*/no-declare], +@racket[defmodulereader*/no-declare], and @racket[declare-exporting], +respectively, that implicitly refer to the PLaneT package that +contains the enclosing module. + +The full module name passed to @racket[defmodule], etc is formed by +appending the @racket[suffix-id] or @racket[mod-suffix-id] to the +symbol returned by @racket[(this-package-version-symbol)], separated +by a @litchar{/} character, and tagging the resulting symbol as a +@racket[planet] module path. As a special case, if @racket[suffix-id] +is @racketid[main], the suffix is omitted. + +For example, within a package named @tt{package.plt} by @tt{author}, +version @tt{1:0}, the following are equivalent: +@racketblock[ +(defmodule/this-package dir/file) + @#,elem{=} (defmodule (planet author/package:1:0/dir/file)) +] +and +@racketblock[ +(defmodule/this-package main) + @#,elem{=} (defmodule (planet author/package:1:0)) +] +} + +@section{Terse Status Updates} + +@defmodule[planet/terse-info] + +This module provides access to some PLaneT status information. This +module is first loaded by PLaneT in the initial namespace (when +PLaneT's resolver is loaded), but PLaneT uses @racket[dynamic-require] to load +this module each time it wants to announce information. Similarly, the +state of which procedures are registered (via @racket[planet-terse-register]) +is saved in the namespace, making the listening and information producing +namespace-specific. + +@defproc[(planet-terse-register + [proc (-> (or/c 'download 'install 'docs-build 'finish) + string? + any/c)]) + void?]{ +Registers @racket[proc] as a function to be called when +@racket[planet-terse-log] is called. + +Note that @racket[proc] is called +asynchronously (ie, on some thread other than the one calling @racket[planet-terse-register]). +} + +@defproc[(planet-terse-log [id (or/c 'download 'install 'finish)] + [msg string?]) void?]{ +This function is called by PLaneT to announce when things are happening. See also +@racket[planet-terse-set-key]. +} + +@defproc[(planet-terse-set-key [key any/c]) void?]{ + This sets a @seclink["threadcells" #:doc '(lib "scribblings/reference/reference.scrbl")]{thread cell} + to the value of @racket[key]. + The value of the thread cell is used as an index into a table to determine which + of the functions passed to @racket[planet-terse-register] to call when + @racket[planet-terse-log] is called. + + The table holding the key uses ephemerons and a weak hash table to ensure that + when the @racket[key] is unreachable, then the procedures passed to @racket[planet-terse-log] + cannot be reached through the table. +} + +@section{The Cache File's Path} + +@defmodule[planet/cachepath] + +@defproc[(get-planet-cache-path) (and/c path? absolute-path?)]{ + Returns the path to the @filepath{cache.rktd} file for the planet installation. +} \ No newline at end of file diff --git a/collects/planet/private/version.rkt b/collects/planet/private/version.rkt new file mode 100644 index 0000000000..ff9db78a2a --- /dev/null +++ b/collects/planet/private/version.rkt @@ -0,0 +1,103 @@ +#lang racket +(require (for-syntax syntax/parse) + unstable/syntax + racket/syntax + "../planet-archives.rkt") + +(provide this-package-version + this-package-version-name + this-package-version-owner + this-package-version-maj + this-package-version-min + this-package-version-symbol + package-version->symbol + make-planet-symbol + (rename-out [this-package-version/proc path->package-version])) + +(define-syntax (this-package-version stx) + (syntax-case stx () + [(_) + #`(this-package-version/proc + (this-expression-source-directory #,stx))])) + +(define-syntax define-getters + (syntax-rules () + [(define-getters (name position) ...) + (begin + (define-syntax (name stx) + (syntax-case stx () + [(name) + #`(let ([p #,(datum->syntax stx `(,#'this-package-version))]) + (and p (position p)))])) + ...)])) + +(define-getters + (this-package-version-name pd->name) + (this-package-version-owner pd->owner) + (this-package-version-maj pd->maj) + (this-package-version-min pd->min)) + +(define-syntax (this-package-version-symbol stx) + (syntax-parse stx + [(_ (~optional suffix:id)) + #`(package-version->symbol + (this-package-version/proc + (this-expression-source-directory #,stx)) + #,@(if (attribute suffix) #'['suffix] #'[]))])) + + +;; ---------------------------------------- + +(define (make-planet-symbol stx [suffix #f]) + (match (syntax-source-directory stx) + [#f #f] + [dir (match (this-package-version/proc dir) + [#f #f] + [ver (package-version->symbol ver suffix)])])) + +(define (package-version->symbol ver [suffix #f]) + (match ver + [(list owner name major minor) + (string->symbol + (format "~a/~a:~a:~a~a" + owner + (regexp-replace #rx"\\.plt$" name "") + major + minor + (if suffix (format-symbol "/~a" suffix) "")))] + [#f #f])) + +(define (this-package-version/proc srcdir) + (define (archive-retval->simple-retval p) + (list-refs p '(1 2 4 5))) + + ;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X) + (define (predicate->projection pred) (λ (x) (if (pred x) x #f))) + + (let* ([package-roots (get-all-planet-packages)] + [thepkg (ormap (predicate->projection (contains-dir? srcdir)) + package-roots)]) + (and thepkg (archive-retval->simple-retval thepkg)))) + +;; contains-dir? : path -> pkg -> boolean +(define ((contains-dir? srcdir) alleged-superdir-pkg) + (let* ([nsrcdir (simple-form-path srcdir)] + [nsuperdir (simple-form-path (car alleged-superdir-pkg))] + [nsrclist (explode-path nsrcdir)] + [nsuperlist (explode-path nsuperdir)]) + (list-prefix? nsuperlist nsrclist))) + +(define (list-prefix? sup sub) + (let loop ([sub sub] + [sup sup]) + (cond + [(null? sup) #t] + [(equal? (car sup) (car sub)) + (loop (cdr sub) (cdr sup))] + [else #f]))) + +(define-values (pd->owner pd->name pd->maj pd->min) + (apply values (map (λ (n) (λ (l) (list-ref l n))) '(0 1 2 3)))) + +(define (list-refs p ns) + (map (λ (n) (list-ref p n)) ns)) diff --git a/collects/planet/resolver.rkt b/collects/planet/resolver.rkt index b51d4e98d4..b3e5ce0b65 100644 --- a/collects/planet/resolver.rkt +++ b/collects/planet/resolver.rkt @@ -1,820 +1,7 @@ -#lang mzscheme - -#| resolver.rkt -- PLaneT client - -1. Introduction - -The PLaneT system is a method for automatically sharing code packages, both as -libraries and as full applications, that gives every user of a PLaneT client -the illusion of having a local copy of every code package on the server, but is -parsimonious in its transmission. It consists of a centralized server that -holds all packages and individual clients that hold some portion of the archive -locally. Maintenance of that archive should be transparent, and is the complete -responsibility of the PLaneT client. - -2. Client behavior - -The PLaneT client receives user requests (i.e., the "(require (planet ...))" -forms) and loads the appropriate modules in response. In the course of handling -these requests it may download new code packages from the PLaneT server. - -2.1 User interface - -The structure of user PLaneT invocations is listed below. - -PLANET-REQUEST ::= (planet FILE-NAME PKG-SPEC [PATH ...]?) -FILE-NAME ::= string -PKG-SPEC ::= string | (FILE-PATH ... PKG-NAME) - | (FILE-PATH ... PKG-NAME VER-SPEC) -VER-SPEC ::= Nat | (Nat MINOR) -MINOR ::= Nat | (Nat Nat) | (= Nat) | (+ Nat) | (- Nat) -FILE-PATH ::= string -PKG-NAME ::= string -OWNER-NAME ::= string -PATH ::= string - -All strings must be legal filename strings. - -When encountered, a planet-request is interpreted as requiring the given file -name from the given logical package, specified by the package spec and the -collection specification, if given. If no VER-SPEC is provided, the most recent -version is assumed. If no owner-name/path ... clause is provided, the default -package is assumed. - -2. PLaneT protocol - -PLaneT clients support two protocols for communicating with the PLaneT server: -the standard HTTP GET/response system (currently the default) and a specialized -TCP-based protocol that may become more important if PLaneT becomes smarter -about downloading packages behind the scenes. - -In the following sections we describe the specialized protocol only. - -2.1 Overview - -1. PLaneT client establishes TCP connection to PLaneT server. -2. Client transmits a version specifier. -3. Server either refuses that version and closes connection or accepts. -4. Client transmits a sequence of requests terminated by a special - end-of-request marker. Simultaneously, server transmits responses to those - requests. -5. Once the server has handled every request, it closes the connection. - - -I am concerned about the overhead of opening and closing TCP connections for a -large program with many requires, so I want to allow many requests and -responses over the same connection. Unfortunately there's a wrinkle: the -standard client, implemented the obvious way, would be unable to send more than -one request at a time because it gets invoked purely as a response to a require -form and must load an appropriate file before it returns. This means I can't -batch up multiple requires, at least not with an obvious implementation. - -A possible solution would be to implement an install program that walks over -the syntax tree of a program and gathers all requires, then communicates with -the server and learns what additional packages would be necessary due to those -requires, and then downloads all of them at once. We would have to implement -both methods simultaneously, though, to allow for REPL-based PLaneT use and -dynamic-require (unless we want it to be a runtime exception to use PLaneT from -the REPL or via dynamic-require, something I'd rather not do), so I want a -protocol that will allow both forms of access easily. This protocol does that, -and doesn't require too much additional overhead in the case that the client -only takes one package at a time. - -2.2 Communication Details - -After a TCP connection is established, the client transmits a -VERSION-SPECIFIER: - -VERSION-SPECIFIER ::= "PLaneT/1.0\n" - -The server responds with a VERSION-RESPONSE: - -VERSION-RESPONSE ::= -| 'ok "\n" -| ('invalid string) "\n" - -where the string in the invalid case is descriptive text intended for display -to the user that may indicate some specific message about the nature of the -error. - -If the server sends 'invalid, the server closes the connection. Otherwise, the -client may send any number of requests, followed by an end-of-request marker: - -REQUESTS ::= { REQUEST "\n"}* 'end "\n" -REQUEST ::= (SEQ-NO 'get PKG-LANG PKG-NAME (Nat | #f) (Nat | #f) (Nat | #f) - [OWNER-NAME PATH ...]?) -PKG-LANG ::= String -SEQ-NO ::= Nat - -The fields in a request are a uniquely identifying sequence number, the literal -symbol 'get, the name of the package to receive, the required major version and -the lowest and highest acceptable version (with #f meaning that there is no -constraint for that field, and a #f in major-version field implying that both -other fields must also be #f), and the package path. - -As the client is transmitting a REQUESTS sequence, the server begins responding -to it with RESPONSE structures, each with a sequence number indicating to which -request it is responding (except in the case of input too garbled to extract a -sequence number): - -RESPONSE ::= -| ('error 'malformed-input string) "\n" -| (SEQ-NO 'error 'malformed-request string) "\n" -| (SEQ-NO 'bad-language string) "\n" -| (SEQ-NO 'get 'ok Nat Nat Nat) "\n" BYTE-DATA -| (SEQ-NO 'get 'error ERROR-CODE string) "\n" - -ERROR-CODE ::= 'not-found - -If the server receives a malformed request, it may close connection after -sending a malformed-request response without processing any other -requests. Otherwise it must process all requests even in the event of an -error. On a successful get, the three numbers the server returns are the -matched package's major version, the matched package's minor version, and the -number of bytes in the package. - -3 Client Download Policies - -Racket invokes the PLaneT client once for each instance of a require-planet -form in a program being run (i.e., the transitive closure of the "requires" -relation starting from some specified root module; this closure is calculable -statically). At each of these invocations, the client examines its internal -cache to see if an appropriate module exists that matches the specification -given by the user (for details see the next section). If one does, the client -loads that module and returns. If none does, it initiates a transaction with -the server using the PLaneT protocol described in the previous subsection and -sends a single request consisting of the user's request. It installs the -resulting .plt file and then loads the appropriate file. - -The client keeps a cache of downloaded packages locally. It does so in the -$PLTCOLLECTS/planet/cache/ directory and subdirectories, in an intuitive -manner: each item in the package's path in the PLaneT require line correspond -to a subdirectory in the cache directory, starting with the owner name. (They -should be unpacked relative to some user-specific rather than -installation-specific place, possibly, but that's difficult to do so we won't -do it yet). - -To check whether a package is installed when attempting to satisfy a -requirement, the client checks its cache to see if an appropriate entry exists -in its link-table for that require line. If one exists, it uses the named -package directly. If none exists, it checks to see if there is an appropriate -subdirectory. - -||# - - -;; This `resolver' no longer fits the normal protocol for a -;; module name resolver, because it accepts an extra argument in -;; the second and third cases. The extra argument is a parameterization -;; to use for installation actions. -(define resolver - (case-lambda - [(name) (void)] - [(spec module-path stx orig-paramz) - (resolver spec module-path stx #t orig-paramz)] - [(spec module-path stx load? orig-paramz) - ;; ensure these directories exist - (make-directory* (PLANET-DIR)) - (make-directory* (CACHE-DIR)) - (establish-diamond-property-monitor) - (planet-resolve spec - (current-module-declare-name) ;; seems more reliable than module-path in v3.99 - stx - load? - orig-paramz)])) - -(require mzlib/match - mzlib/file - mzlib/port - mzlib/list - - mzlib/date - - net/url - net/head - mzlib/struct - - "config.rkt" - "private/planet-shared.rkt" - "private/linkage.rkt" - "parsereq.rkt" - - "terse-info.rkt" - compiler/cm) - -(provide (rename resolver planet-module-name-resolver) +#lang racket/base +(require "private/resolver.rkt") +(provide planet-module-name-resolver resolve-planet-path - pkg-spec->full-pkg-spec - get-package-from-cache - get-package-from-server - download-package - pkg->download-url - pkg-promise->pkg - install-pkg - get-planet-module-path/pkg + install? download? - install? - exn:fail:planet? - make-exn:fail:planet) - -;; if #f, will not install packages and instead raise a exn:fail:install? error -(define install? (make-parameter #t)) -;; if #f, will not download packages and instead raise a exn:fail:install? error -(define download? (make-parameter #t)) -(define-struct (exn:fail:planet exn:fail) ()) - -;; update doc index only once for a set of installs: -(define planet-nested-install (make-parameter #f)) - -;; ============================================================================= -;; DIAMOND PROPERTY STUFF -;; make sure a module isn't loaded twice with two different versions -;; ============================================================================= -(define VER-CACHE-NAME #f) - -(define (establish-diamond-property-monitor) - (unless VER-CACHE-NAME (set! VER-CACHE-NAME (gensym))) - (unless (namespace-variable-value VER-CACHE-NAME #t (lambda () #f)) - (namespace-set-variable-value! VER-CACHE-NAME (make-hash-table 'equal)))) - -(define (the-version-cache) (namespace-variable-value VER-CACHE-NAME)) -(define (pkg->diamond-key pkg) (cons (pkg-name pkg) (pkg-route pkg))) - -(define (pkg-matches-bounds? pkg bound-info) - (match-let ([(maj lo hi) bound-info]) - (and (= maj (pkg-maj pkg)) - (or (not lo) (>= (pkg-min pkg) lo)) - (or (not hi) (<= (pkg-min pkg) hi))))) - -;; COMPAT ::= 'none | 'all | `(all-except ,VER-SPEC ...) | `(only ,VER-SPEC ...) -;; build-compatibility-fn : COMPAT -> PKG -> bool -(define (build-compatibility-fn compat-data) - (define pre-fn - (match compat-data - [`none (lambda (_) #f)] - [`all (lambda (_) #t)] - [`(all-except ,vspec ...) - (let ([bounders (map (λ (x) (version->bounds x (λ (_) #f))) vspec)]) - (if (andmap (lambda (x) x) bounders) - (lambda (v) - (not (ormap (lambda (bounder) (pkg-matches-bounds? v bounder)) - bounders))) - #f))] - [`(only ,vspec ...) - (let ([bounders (map (λ (x) (version->bounds x (λ (_) #f))) vspec)]) - (if (andmap (lambda (x) x) bounders) - (lambda (v) - (andmap (lambda (bounder) (pkg-matches-bounds? v bounder)) - bounders))) - #f)] - [_ #f])) - (or pre-fn (lambda (x) #f))) - -;; can-be-loaded-together? : pkg pkg -> boolean -;; side constraint: pkg1 and pkg2 are versions of the same package assumption: -;; pkg1 and pkg2 are versions of the same package determines if the two -;; versions are side-by-side compatible -(define (can-be-loaded-together? pkg1 pkg2) - (cond [(pkg> pkg1 pkg2) (can-be-loaded-together? pkg2 pkg1)] - [(pkg= pkg1 pkg2) #t] - [(pkg< pkg1 pkg2) - (let* ([info (pkg->info pkg2)] - [compat? (build-compatibility-fn - (info 'can-be-loaded-with (lambda () 'none)))]) - (compat? pkg1))])) - -;; stx->origin-string : stx option -> string -;; returns a description [e.g. file name, line#] of the given syntax -(define (stx->origin-string stx) - (if stx (format "~a" (syntax-source stx)) "[unknown]")) - -(define (add-pkg-to-diamond-registry! pkg stx) - (let ([loaded-packages - (hash-table-get (the-version-cache) (pkg->diamond-key pkg) '())]) - (unless (list? loaded-packages) - (error 'PLaneT "Inconsistent state: expected loaded-packages to be a list, received: ~s" loaded-packages)) - (let ([all-violations '()]) - (for-each - (lambda (already-loaded-pkg-record) - (let* ([already-loaded-pkg (car already-loaded-pkg-record)] - [prior-stx (cadr already-loaded-pkg-record)] - [prior-stx-origin-string (stx->origin-string prior-stx)]) - (unless (can-be-loaded-together? pkg already-loaded-pkg) - (set! - all-violations - (cons - (list - stx - (make-exn:fail - (format - "Package ~a loaded twice with multiple incompatible versions: -~a attempted to load version ~a.~a while version ~a.~a was already loaded by ~a" - (pkg-name pkg) - (stx->origin-string stx) - (pkg-maj pkg) - (pkg-min pkg) - (pkg-maj already-loaded-pkg) - (pkg-min already-loaded-pkg) - prior-stx-origin-string) - (current-continuation-marks))) - all-violations))))) - loaded-packages) - (unless (null? all-violations) - (let ([worst (or (assq values all-violations) (car all-violations))]) - (raise (cadr worst))))) - (hash-table-put! (the-version-cache) - (pkg->diamond-key pkg) - (cons (list pkg stx) loaded-packages)))) - -;; ============================================================================= -;; MAIN LOGIC -;; Handles the overall functioning of the resolver -;; ============================================================================= - -;; planet-resolve : PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> symbol -;; resolves the given request. Returns a name corresponding to the module in -;; the correct environment -(define (planet-resolve spec rmp stx load? orig-paramz) - ;; install various parameters that can affect the compilation of a planet package back to their original state - (parameterize ([current-compile (call-with-parameterization orig-paramz current-compile)] - [current-eval (call-with-parameterization orig-paramz current-eval)] - [use-compiled-file-paths (call-with-parameterization orig-paramz use-compiled-file-paths)] - [current-library-collection-paths (call-with-parameterization orig-paramz current-library-collection-paths)]) - (let-values ([(path pkg) (get-planet-module-path/pkg spec rmp stx)]) - (when load? (add-pkg-to-diamond-registry! pkg stx)) - (do-require path (pkg-path pkg) rmp stx load?)))) - -;; resolve-planet-path : planet-require-spec -> path -;; retrieves the path to the given file in the planet package. downloads and -;; installs the package if necessary -(define (resolve-planet-path spec) - (let-values ([(path pkg) (get-planet-module-path/pkg spec #f #f)]) - path)) - -;; get-planet-module-path/pkg :PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG) -;; returns the matching package and the file path to the specific request -(define (get-planet-module-path/pkg spec rmp stx) - (request->pkg (spec->req spec stx) rmp stx)) - -;; request->pkg : request (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG) -(define (request->pkg req rmp stx) - (let* ([result (get-package rmp (request-full-pkg-spec req))]) - (cond [(string? result) - (raise-syntax-error 'require result stx)] - [(pkg? result) - (values (apply build-path (pkg-path result) - (append (request-path req) (list (request-file req)))) - result)]))) - -;; PKG-GETTER ::= module-path pspec -;; (pkg -> A) -;; ((uninstalled-pkg -> void) -;; (pkg -> void) -;; ((string | #f) -> string | #f) -> A) -;; -> A -;; -;; a pkg-getter is a function that tries to fetch a package; it is written in a -;; quasi-cps style; the first argument is what it calls to succeed, and the -;; second argument is what it calls when it fails. In the second case, it must -;; provide two things: a function to take action if a match is found -;; eventually, and a function that gets to mess with the error message if the -;; entire message eventually fails. - -;; get-package : (resolved-module-path | #f) FULL-PKG-SPEC -> (PKG | string) -;; gets the package specified by pspec requested by the module in the given -;; module path, or returns a descriptive error message string if that's not -;; possible -(define (get-package rmp pspec) - (let loop ([getters (*package-search-chain*)] - [pre-install-updaters '()] - [post-install-updaters '()] - [error-reporters '()]) - (if (null? getters) - ;; we have failed to fetch the package, generate an appropriate error - ;; message and bail - (let ([msg (foldl (λ (f str) (f str)) #f error-reporters)]) - (or msg (format "Could not find package matching ~s" - (list (pkg-spec-name pspec) - (pkg-spec-maj pspec) - (list (pkg-spec-minor-lo pspec) - (pkg-spec-minor-hi pspec)) - (pkg-spec-path pspec))))) - ;; try the next error reporter. recursive call is in the failure - ;; continuation - ((car getters) - rmp - pspec - (λ (pkg) - (when (uninstalled-pkg? pkg) - (for-each (λ (u) (u pkg)) pre-install-updaters)) - (let ([installed-pkg (pkg-promise->pkg pkg)]) - (for-each (λ (u) (u installed-pkg)) post-install-updaters) - installed-pkg)) - (λ (pre-updater post-updater error-reporter) - (loop (cdr getters) - (cons pre-updater pre-install-updaters) - (cons post-updater post-install-updaters) - (cons error-reporter error-reporters))))))) - -;; ============================================================================= -;; PHASE 2: CACHE SEARCH -;; If there's no linkage, there might still be an appropriate cached module -;; (either installed or uninstalled) -;; ============================================================================= - -;; get/installed-cache : pkg-getter -(define (get/installed-cache _ pkg-spec success-k failure-k) - (let ([p (lookup-package pkg-spec)]) - (if p (success-k p) (failure-k void void (λ (x) x))))) - -;; get-package-from-cache : FULL-PKG-SPEC -> PKG | #f -(define (get-package-from-cache pkg-spec) - (lookup-package pkg-spec)) - -;; get/uninstalled-cache-dummy : pkg-getter -;; always fails, but records the package to the uninstalled package cache upon -;; the success of some other getter later in the chain. -(define (get/uninstalled-cache-dummy _ pkg-spec success-k failure-k) - (failure-k save-to-uninstalled-pkg-cache! void (λ (x) x))) - -;; get/uninstalled-cache : pkg-getter -;; note: this does not yet work with minimum-required-version specifiers if you -;; install a package and then use an older mzscheme -(define (get/uninstalled-cache _ pkg-spec success-k failure-k) - (let ([p (lookup-package pkg-spec (UNINSTALLED-PACKAGE-CACHE))]) - (if (and p (file-exists? (build-path (pkg-path p) - (pkg-spec-name pkg-spec)))) - (begin - (planet-log "found local, uninstalled copy of package at ~a" - (build-path (pkg-path p) - (pkg-spec-name pkg-spec))) - (success-k - ;; note: it's a little sloppy that lookup-pkg returns PKG structures, - ;; since it doesn't actually know whether or not the package is - ;; installed. hence I have to convert what appears to be an installed - ;; package into an uninstalled package - (make-uninstalled-pkg (build-path (pkg-path p) (pkg-spec-name pkg-spec)) - pkg-spec - (pkg-maj p) - (pkg-min p)))) - (failure-k void void (λ (x) x))))) - -;; save-to-uninstalled-pkg-cache! : uninstalled-pkg -> path[file] -;; copies the given uninstalled package into the uninstalled-package cache, -;; replacing any old file that might be there. Returns the path it copied the -;; file into. -(define (save-to-uninstalled-pkg-cache! uninst-p) - (let* ([pspec (uninstalled-pkg-spec uninst-p)] - [owner (car (pkg-spec-path pspec))] - [name (pkg-spec-name pspec)] - [maj (uninstalled-pkg-maj uninst-p)] - [min (uninstalled-pkg-min uninst-p)] - [dir (build-path (UNINSTALLED-PACKAGE-CACHE) - owner - name - (number->string maj) - (number->string min))] - [full-pkg-path (build-path dir name)]) - (make-directory* dir) - (unless (equal? (normalize-path (uninstalled-pkg-path uninst-p)) - (normalize-path full-pkg-path)) - (when (file-exists? full-pkg-path) (delete-file full-pkg-path)) - (copy-file (uninstalled-pkg-path uninst-p) full-pkg-path)) - full-pkg-path)) - -;; ============================================================================= -;; PHASE 3: SERVER RETRIEVAL -;; Ask the PLaneT server for an appropriate package if we don't have one -;; locally. -;; ============================================================================= - -(define (get/server _ pkg-spec success-k failure-k) - (let ([p (get-package-from-server pkg-spec)]) - (cond - [(pkg-promise? p) (success-k p)] - [(string? p) - ;; replace any existing error message with the server download error - ;; message - (planet-log p) - (failure-k void void (λ (_) p))]))) - -;; get-package-from-server : FULL-PKG-SPEC -> PKG-PROMISE | #f | string[error message] -;; downloads the given package file from the PLaneT server and installs it in -;; the uninstalled-packages cache, then returns a promise for it -(define (get-package-from-server pkg) - (match (download-package pkg) - [(#t tmpfile-path maj min) - (let* ([upkg (make-uninstalled-pkg tmpfile-path pkg maj min)] - [cached-path (save-to-uninstalled-pkg-cache! upkg)] - [final (make-uninstalled-pkg cached-path pkg maj min)]) - (unless (equal? (normalize-path tmpfile-path) - (normalize-path cached-path)) - (delete-file tmpfile-path)) ;; remove the tmp file, we're done with it - final)] - [(#f str) - (string-append "PLaneT could not find the requested package: " str)] - [(? string? s) - (string-append "PLaneT could not download the requested package: " s)])) - -(define (download-package pkg) - (unless (download?) - (raise (make-exn:fail:planet - (format - "PLaneT error: cannot download package ~s since the download? parameter is set to #f" - (list (car (pkg-spec-path pkg)) (pkg-spec-name pkg))) - (current-continuation-marks)))) - ((if (USE-HTTP-DOWNLOADS?) download-package/http download-package/planet) - pkg)) - -(define (current-time) - (let ([date (seconds->date (current-seconds))]) - (parameterize ([date-display-format 'rfc2822]) - (format "~a ~a:~a:~a" - (date->string date) - (date-hour date) - (date-minute date) - (date-second date))))) - -;; pkg-promise->pkg : pkg-promise -> pkg -;; "forces" the given pkg-promise (i.e., installs the package if it isn't -;; installed yet) -(define (pkg-promise->pkg p) - (cond [(pkg? p) p] - [(uninstalled-pkg? p) - (install-pkg (uninstalled-pkg-spec p) - (uninstalled-pkg-path p) - (uninstalled-pkg-maj p) - (uninstalled-pkg-min p))])) - -;; install-pkg : FULL-PKG-SPEC path[file] Nat Nat -> PKG -;; install the given pkg to the planet cache and return a PKG representing the -;; installed file -(define (install-pkg pkg path maj min) - (let ([pkg-path (pkg-spec-path pkg)] - [pkg-name (pkg-spec-name pkg)] - [pkg-string (pkg-spec->string pkg)]) - (unless (install?) - (raise (make-exn:fail:planet - (format - "PLaneT error: cannot install package ~s since the install? parameter is set to #f" - (list (car pkg-path) pkg-name maj min)) - (current-continuation-marks)))) - (let* ([owner (car pkg-path)] - [extra-path (cdr pkg-path)] - [the-dir - (apply build-path (CACHE-DIR) - (append pkg-path (list pkg-name - (number->string maj) - (number->string min))))] - [was-nested? (planet-nested-install)]) - (if (directory-exists? the-dir) - (raise (make-exn:fail - "PLaneT error: trying to install already-installed package" - (current-continuation-marks))) - (parameterize ([planet-nested-install #t]) - (planet-terse-log 'install pkg-string) - (with-logging - (LOG-FILE) - (lambda () - (printf "\n============= Installing ~a on ~a =============\n" - pkg-name - (current-time)) - ;; oh man is this a bad hack! - (parameterize ([current-namespace (make-namespace)]) - (let ([ipp (dynamic-require 'setup/plt-single-installer - 'install-planet-package)] - [rud (dynamic-require 'setup/plt-single-installer - 'reindex-user-documentation)] - [msfh (dynamic-require 'compiler/cm 'manager-skip-file-handler)]) - (parameterize ([msfh (manager-skip-file-handler)] - [use-compiled-file-paths (list (string->path "compiled"))]) - (ipp path the-dir (list owner pkg-name - extra-path maj min)) - (unless was-nested? - (planet-terse-log 'docs-build pkg-string) - (printf "------------- Rebuilding documentation index -------------\n") - (rud))))))) - (planet-terse-log 'finish pkg-string) - (make-pkg pkg-name pkg-path - maj min the-dir 'normal)))))) - -;; download-package : FULL-PKG-SPEC -> RESPONSE -;; RESPONSE ::= (list #f string) | (list #t path[file] Nat Nat) - -;; downloads the given package and returns (list bool string): if bool is #t, -;; the path is to a file that contains the package. If bool is #f, the package -;; didn't exist and the string is the server's informative message. -;; raises an exception if some protocol failure occurs in the download process -(define (download-package/planet pkg) - - (define stupid-internal-define-syntax - (let ([msg (format "downloading ~a from ~a via planet protocol" - (pkg-spec->string pkg) - (PLANET-SERVER-NAME))]) - (planet-terse-log 'download (pkg-spec->string pkg)) - (planet-log msg))) - - (define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT))) - - (define (close-ports) (close-input-port ip) (close-output-port op)) - - (define (request-pkg-list pkgs) - (for-each/n (lambda (pkg seqno) - (write-line (list* seqno 'get - (DEFAULT-PACKAGE-LANGUAGE) - (pkg-spec-name pkg) - (pkg-spec-maj pkg) - (pkg-spec-minor-lo pkg) - (pkg-spec-minor-hi pkg) - (pkg-spec-path pkg)) - op)) - pkgs) - (write-line 'end op) - (flush-output op)) - - (define (state:initialize) - (fprintf op "PLaneT/1.0\n") - (flush-output op) - (match (read ip) - ['ok (state:send-pkg-request)] - [('invalid (? string? msg)) (state:abort (string-append "protocol version error: " msg))] - [bad-msg (state:abort (format "server protocol error (received invalid response): ~a" bad-msg))])) - - (define (state:send-pkg-request) - (request-pkg-list (list pkg)) - (state:receive-package)) - - (define (state:receive-package) - (match (read ip) - [(_ 'get 'ok (? nat? maj) (? nat? min) (? nat? bytes)) - (let ([filename (make-temporary-file "planettmp~a.plt")]) - (read-char ip) ; throw away newline that must be present - (read-n-chars-to-file bytes ip filename) - (list #t filename maj min))] - [(_ 'error 'malformed-request (? string? msg)) - (state:abort (format "Internal error (malformed request): ~a" msg))] - [(_ 'get 'error 'not-found (? string? msg)) - (state:failure (format "Server had no matching package: ~a" msg))] - [(_ 'get 'error (? symbol? code) (? string? msg)) - (state:abort (format "Unknown error ~a receiving package: ~a" code msg))] - [bad-response (state:abort (format "Server returned malformed message: ~e" bad-response))])) - - (define (state:abort msg) - (raise (make-exn:i/o:protocol msg (current-continuation-marks)))) - (define (state:failure msg) (list #f msg)) - - (with-handlers ([void (lambda (e) (close-ports) (raise e))]) - (begin0 - (state:initialize) - (close-ports)))) - -;; ------------------------------------------------------------ -;; HTTP VERSION OF THE PROTOCOL - -;; pkg->servlet-args : FULL-PKG-SPEC -> environment[from net/url] -;; gets the appropriate query arguments to request the given package from the -;; PLaneT HTTP download servlet -(define (pkg->servlet-args pkg) - (let ([get (lambda (access) (format "~s" (access pkg)))]) - `((lang . ,(format "~s" (DEFAULT-PACKAGE-LANGUAGE))) - (name . ,(get pkg-spec-name)) - (maj . ,(get pkg-spec-maj)) - (min-lo . ,(get pkg-spec-minor-lo)) - (min-hi . ,(get pkg-spec-minor-hi)) - (path . ,(get pkg-spec-path))))) - -;; get-http-response-code : header[from net/head] -> string or #f -;; gets the HTTP response code in the given header -(define (get-http-response-code header) - (let ([parsed (regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header)]) - (and parsed (cadr parsed)))) - -;; pkg->download-url : FULL-PKG-SPEC -> url -;; gets the download url for the given package -(define (pkg->download-url pkg) - (copy-struct url (string->url (HTTP-DOWNLOAD-SERVLET-URL)) - (url-query (pkg->servlet-args pkg)))) - -;; download-package/http : FULL-PKG-SPEC -> RESPONSE -;; a drop-in replacement for download-package that uses HTTP rather than the -;; planet protocol. The HTTP protocol does not allow any kind of complicated -;; negotiation, but it appears that many more users can make HTTP requests than -;; requests from nonstandard protocols. -(define (download-package/http pkg) - (let/ec return - (let loop ([attempts 1]) - (when (> attempts 5) - (return "Download failed too many times (possibly due to an unreliable network connection)")) - - (let ([msg (format "downloading ~a from ~a via HTTP~a" - (pkg-spec->string pkg) - (PLANET-SERVER-NAME) - (if (= attempts 1) - "" - (format ", attempt #~a" attempts)))]) - (planet-terse-log 'download (pkg-spec->string pkg)) - (planet-log "~a" msg)) - - (with-handlers ([exn:fail:network? (λ (e) (return (exn-message e)))]) - (let* ([target (pkg->download-url pkg)] - [ip (get-impure-port target)] - [head (purify-port ip)] - [response-code/str (get-http-response-code head)] - [response-code (and response-code/str - (string->number response-code/str))]) - - (define (abort msg) - (close-input-port ip) - (return msg)) - - (case response-code - [(#f) - (abort (format "Server returned invalid HTTP response code ~s" - response-code/str))] - [(200) - (let ([maj/str (extract-field "Package-Major-Version" head)] - [min/str (extract-field "Package-Minor-Version" head)] - [content-length/str (extract-field "Content-Length" head)]) - (unless (and maj/str min/str content-length/str - (nat? (string->number maj/str)) - (nat? (string->number min/str)) - (nat? (string->number content-length/str))) - (abort "Server did not include valid major and minor version information")) - (let* ([filename (make-temporary-file "planettmp~a.plt")] - [maj (string->number maj/str)] - [min (string->number min/str)] - [content-length (string->number content-length/str)] - [op (open-output-file filename 'truncate/replace)]) - (copy-port ip op) - (close-input-port ip) - (close-output-port op) - (if (= (file-size filename) content-length) - (list #t filename maj min) - (loop (add1 attempts)))))] - [(404) - (begin0 (list #f (format "Server had no matching package: ~a" - (read-line ip))) - (close-input-port ip))] - [(400) - (abort (format "Internal error (malformed request): ~a" - (read-line ip)))] - [(500) - (abort (format "Server internal error: ~a" - (apply string-append - (let loop () - (let ([line (read-line ip)]) - (if (eof-object? line) - '() - (list* line "\n" (loop))))))))] - [else - (abort (format "Internal error (unknown HTTP response code ~a)" - response-code))])))))) - -;; formats the pkg-spec back into a string the way the user typed it in, -;; except it never shows the minor version number (since some later one may actually be being used) -;; assumes that the pkg-spec comes from the command-line -(define (pkg-spec->string pkg) - (format "~a/~a~a" - (if (pair? (pkg-spec-path pkg)) - (car (pkg-spec-path pkg)) - "<>") ;; this shouldn't happen - (regexp-replace #rx"\\.plt$" (pkg-spec-name pkg) "") - (if (pkg-spec-maj pkg) - (format ":~a" (pkg-spec-maj pkg)) - ""))) - -;; ============================================================================= -;; MODULE MANAGEMENT -;; Handles interaction with the module system -;; ============================================================================= - -;; do-require : path path symbol syntax -> symbol -;; requires the given filename, which must be a module, in the given path. -(define (do-require file-path package-path module-path stx load?) - (parameterize ([current-load-relative-directory package-path]) - ((current-module-name-resolver) file-path module-path stx load?))) - -(define *package-search-chain* - (make-parameter - (list get/linkage - get/installed-cache - get/uninstalled-cache-dummy - get/server - get/uninstalled-cache))) - -;; ============================================================ -;; UTILITY -;; A few small utility functions - -(define (last l) (car (last-pair l))) - -;; make-directory*/paths : path -> (listof path) -;; like make-directory*, but returns what directories it actually created -(define (make-directory*/paths dir) - (let ([dir (if (string? dir) (string->path dir) dir)]) - (let-values ([(base name dir?) (split-path dir)]) - (cond [(directory-exists? dir) '()] - [(directory-exists? base) (make-directory dir) (list dir)] - [else (let ([dirs (make-directory*/paths base)]) - (make-directory dir) - (cons dir dirs))])))) + get-planet-module-path/pkg) diff --git a/collects/planet/syntax.rkt b/collects/planet/syntax.rkt index c5366b8893..43b62fdfbb 100644 --- a/collects/planet/syntax.rkt +++ b/collects/planet/syntax.rkt @@ -10,7 +10,6 @@ (require racket/match planet/util - syntax/parse racket/syntax unstable/syntax (for-template racket/base) diff --git a/collects/planet/tests/test-docs-complete.rkt b/collects/planet/tests/test-docs-complete.rkt deleted file mode 100644 index b814f8165d..0000000000 --- a/collects/planet/tests/test-docs-complete.rkt +++ /dev/null @@ -1,13 +0,0 @@ -#lang racket/base -(require rackunit/docs-complete) -(check-docs (quote planet/version)) -(check-docs (quote planet/util)) -(check-docs (quote planet/syntax)) -(check-docs (quote planet/scribble)) -(check-docs (quote planet/resolver)) -(check-docs (quote planet/raco)) -(check-docs (quote planet/planet)) -(check-docs (quote planet/planet-archives)) -(check-docs (quote planet/parsereq)) -(check-docs (quote planet/config)) -(check-docs (quote planet/cachepath)) diff --git a/collects/planet/util.rkt b/collects/planet/util.rkt index 2cf13e7705..c5b11a5c6d 100644 --- a/collects/planet/util.rkt +++ b/collects/planet/util.rkt @@ -6,7 +6,9 @@ "private/planet-shared.rkt" "private/linkage.rkt" - "resolver.rkt" + "private/resolver.rkt" + "private/version.rkt" + net/url xml/xml @@ -50,9 +52,9 @@ display-plt-archived-file get-package-from-cache pkg->download-url - exn:fail:planet? - make-exn:fail:planet - pkg-spec?) + (struct-out exn:fail:planet) + pkg-spec? + pkg?) (provide/contract [get-package-spec @@ -63,19 +65,19 @@ (list/c #t path? natural-number/c natural-number/c) (list/c #f string?)))] [download/install-pkg - (-> string? (and/c string? #rx"[.]plt") natural-number/c any/c (or/c pkg? #f))] + (-> string? (and/c string? #rx"[.]plt$") natural-number/c any/c (or/c pkg? #f))] [install-pkg (-> pkg-spec? path-string? natural-number/c any/c (or/c pkg? #f))] [add-hard-link - (-> string? (and/c string? #rx"[.]plt") natural-number/c natural-number/c path? void?)] + (-> string? (and/c string? #rx"[.]plt$") natural-number/c natural-number/c path? void?)] [remove-hard-link - (->* (string? (and/c string? #rx"[.]plt") natural-number/c natural-number/c) + (->* (string? (and/c string? #rx"[.]plt$") natural-number/c natural-number/c) (#:quiet? boolean?) void?)] [remove-pkg - (-> string? (and/c string? #rx"[.]plt") natural-number/c natural-number/c void?)] + (-> string? (and/c string? #rx"[.]plt$") natural-number/c natural-number/c void?)] [erase-pkg - (-> string? (and/c string? #rx"[.]plt") natural-number/c natural-number/c void?)]) + (-> string? (and/c string? #rx"[.]plt$") natural-number/c natural-number/c void?)]) ;; get-package-spec : string string [nat | #f] [min-ver-spec | #f] -> pkg? @@ -415,22 +417,25 @@ (build-path SCRIBBLE-DOCUMENT-DIR name) (memq 'multi-page flags)))))))) - (unless - (or (null? critical-errors) - (force-package-building?)) - (raise-user-error '|PLaneT packager| "~a\nRefusing to continue packaging." (car critical-errors))) + (unless (or (null? critical-errors) + (force-package-building?)) + (raise-user-error '|PLaneT packager| "~a\nRefusing to continue packaging." + (if (pair? critical-errors) + (car critical-errors) + ""))) (pack archive-name "archive" (list ".") ;; if this changes, the filter (just below) must also change null - (if (PLANET-ARCHIVE-FILTER) - (regexp->filter (PLANET-ARCHIVE-FILTER)) - (λ (p) - (or (for/and ([always-in (list 'same (string->path "planet-docs"))] - [this-one (explode-path p)]) - (equal? always-in this-one)) - (std-filter p)))) + (let ([p-a-f (PLANET-ARCHIVE-FILTER)]) + (if p-a-f + (regexp->filter p-a-f) + (λ (p) + (or (for/and ([always-in (list 'same (string->path "planet-docs"))] + [this-one (explode-path p)]) + (equal? always-in this-one)) + (std-filter p))))) #t 'file #f @@ -790,7 +795,8 @@ ;; ============================================================ ;; VERSION INFO - +;; re-provided here for backwards compatibility (no idea +;; why it was here in the first place, actually) (provide this-package-version this-package-version-name this-package-version-owner @@ -799,91 +805,4 @@ this-package-version-symbol package-version->symbol make-planet-symbol - (rename-out [this-package-version/proc path->package-version])) - -(define-syntax (this-package-version stx) - (syntax-case stx () - [(_) - #`(this-package-version/proc - (this-expression-source-directory #,stx))])) - -(define-syntax define-getters - (syntax-rules () - [(define-getters (name position) ...) - (begin - (define-syntax (name stx) - (syntax-case stx () - [(name) - #`(let ([p #,(datum->syntax stx `(,#'this-package-version))]) - (and p (position p)))])) - ...)])) - -(define-getters - (this-package-version-name pd->name) - (this-package-version-owner pd->owner) - (this-package-version-maj pd->maj) - (this-package-version-min pd->min)) - -(define-syntax (this-package-version-symbol stx) - (syntax-parse stx - [(_ (~optional suffix:id)) - #`(package-version->symbol - (this-package-version/proc - (this-expression-source-directory #,stx)) - #,@(if (attribute suffix) #'['suffix] #'[]))])) - -;; ---------------------------------------- - -(define (make-planet-symbol stx [suffix #f]) - (match (syntax-source-directory stx) - [#f #f] - [dir (match (this-package-version/proc dir) - [#f #f] - [ver (package-version->symbol ver suffix)])])) - -(define (package-version->symbol ver [suffix #f]) - (match ver - [(list owner name major minor) - (string->symbol - (format "~a/~a:~a:~a~a" - owner - (regexp-replace #rx"\\.plt$" name "") - major - minor - (if suffix (format-symbol "/~a" suffix) "")))] - [#f #f])) - -(define (this-package-version/proc srcdir) - (let* ([package-roots (get-all-planet-packages)] - [thepkg (ormap (predicate->projection (contains-dir? srcdir)) - package-roots)]) - (and thepkg (archive-retval->simple-retval thepkg)))) - -;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X) -(define (predicate->projection pred) (λ (x) (if (pred x) x #f))) - -;; contains-dir? : path -> pkg -> boolean -(define ((contains-dir? srcdir) alleged-superdir-pkg) - (let* ([nsrcdir (simple-form-path srcdir)] - [nsuperdir (simple-form-path (car alleged-superdir-pkg))] - [nsrclist (explode-path nsrcdir)] - [nsuperlist (explode-path nsuperdir)]) - (list-prefix? nsuperlist nsrclist))) - -(define (list-prefix? sup sub) - (let loop ([sub sub] - [sup sup]) - (cond - [(null? sup) #t] - [(equal? (car sup) (car sub)) - (loop (cdr sub) (cdr sup))] - [else #f]))) - -(define (archive-retval->simple-retval p) - (list-refs p '(1 2 4 5))) - -(define-values (pd->owner pd->name pd->maj pd->min) - (apply values (map (λ (n) (λ (l) (list-ref l n))) '(0 1 2 3)))) - -(define (list-refs p ns) - (map (λ (n) (list-ref p n)) ns)) + path->package-version) diff --git a/collects/planet/version.rkt b/collects/planet/version.rkt index 587065285a..df1d8f07a1 100644 --- a/collects/planet/version.rkt +++ b/collects/planet/version.rkt @@ -6,15 +6,17 @@ this-package-version-maj this-package-version-min this-package-version-symbol - this-package-in) + this-package-in + make-planet-symbol + package-version->symbol) (require - planet/util - (for-syntax - racket/base - racket/require-transform - syntax/parse - planet/syntax)) + "private/version.rkt" + (for-syntax + racket/base + racket/require-transform + syntax/parse + planet/syntax)) (define-syntax this-package-in (make-require-transformer diff --git a/collects/tests/planet/cmdline-tool.rkt b/collects/tests/planet/cmdline-tool.rkt index 614c14cbf7..2c66441a35 100644 --- a/collects/tests/planet/cmdline-tool.rkt +++ b/collects/tests/planet/cmdline-tool.rkt @@ -12,7 +12,10 @@ using 'system' to call out to the tool and then reading its results, etc. net/url) (define planet-bin-path - (simplify-path (build-path (collection-path "racket") 'up 'up "bin" "planet"))) + (simplify-path (build-path (collection-path "racket") 'up 'up + (if (eq? (system-type) 'windows) + "planet.exe" + (build-path "bin" "planet"))))) (define test-connection-spec '("planet" "test-connection.plt" "1" "0")) (define test-connection.plt-cache @@ -179,7 +182,7 @@ using 'system' to call out to the tool and then reading its results, etc. (copy-port port sp))) (get-output-string sp))) - (system (format "rm -rf ~a" tmp-dir)) + (delete-directory/files tmp-dir) (printf "done\n") (unless (equal? open-files structure-files) (error 'cmdline-tool.rkt "expected planet structure to produce the same files as planet open, got ~s and ~s" diff --git a/collects/tests/planet/test-docs-complete.rkt b/collects/tests/planet/test-docs-complete.rkt new file mode 100644 index 0000000000..c64d4af17a --- /dev/null +++ b/collects/tests/planet/test-docs-complete.rkt @@ -0,0 +1,12 @@ +#lang racket/base +(require rackunit/docs-complete) +(check-docs 'planet/version) +(check-docs 'planet/util) +(check-docs 'planet/syntax) +(check-docs 'planet/scribble) +(check-docs 'planet/resolver) +(check-docs 'planet/raco) +(check-docs 'planet/planet) +(check-docs 'planet/planet-archives) +(check-docs 'planet/config) +(check-docs 'planet/cachepath) diff --git a/collects/tests/unstable/planet-syntax.rkt b/collects/tests/unstable/planet-syntax.rkt index b43e8fefe1..bbb1757589 100644 --- a/collects/tests/unstable/planet-syntax.rkt +++ b/collects/tests/unstable/planet-syntax.rkt @@ -1,7 +1,6 @@ #lang racket (require mzlib/etc - planet/util rackunit rackunit/text-ui planet/syntax