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

Added a local uninstalled-packages cache and associated tools;

Browse Source 
refactored the planet download search order code

svn: r3951
This commit is contained in:
Jacob Matthews 2006-08-04 01:00:31 +00:00
parent f910f430fa
commit f02c4d7a80
7 changed files with 332 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/planet/config.ss
View File

@ -11,6 +11,7 @@
(PLANET-CODE-VERSION))))
(PLANET-DIR (build-path (PLANET-BASE-DIR) (version)))
(CACHE-DIR (build-path (PLANET-DIR) "cache"))
(UNINSTALLED-PACKAGE-CACHE (build-path (PLANET-BASE-DIR) "packages"))
(LINKAGE-FILE (build-path (PLANET-DIR) "LINKAGE"))
(HARD-LINK-FILE (build-path (PLANET-BASE-DIR) "HARD-LINKS"))
(LOGGING-ENABLED? #t)

31
collects/planet/doc.txt
View File

@ -70,6 +70,19 @@ which config.ss is found.
The root of the PLaneT client's cache directory.
> (UNINSTALLED-PACKAGE-CACHE) -> directory-string
> (UNINSTALLED-PACKAGE-CACHE directory-string) -> void
The root of the PLaneT client's uninstalled-packages cache. PLaneT
stores package distribution files in this directory, and searches for
them in this directory for them if necessary. Unlike the main PLaneT
cache, which contains compiled files and is specific to each
particular version of PLT Scheme, the uninstalled package cache is
shared by all versions of PLT Scheme that use the same package
repository, and it is searched if a package is not installed in the
primary cache. This behavior is intended to primarily benefit users
who upgrade their PLT Scheme installations frequently.
> (LINKAGE-FILE) file-string
> (LINKAGE-FILE file-string) -> void
@ -129,6 +142,13 @@ The functions in this module support examination of the pieces of
PLaneT. They are meant primarily to support debugging and to allow
easier development of higher-level package-management tools.
> (download/install-pkg string? string? nat nat) -> (union pkg? false/c))
Downloads and installs the package specifed by the given owner name,
package name, major and minor version number. Returns false if no such
package is available; otherwise returns a package structure for the
installed package.
> (current-cache-contents) -> ((string ((string ((nat (nat ...)) ...)) ...)) ...)
Returns a listing of all package names and versions installed in the
@ -235,15 +255,24 @@ would install. In this mode, min can be any s-expression that
the (require (planet ...)) form can interpret, not just a natural
number.
This function updates the uninstalled-package cache if it downloads
a package that already appears there.
-d, --download <owner> <pkg> <maj> <min>
Download the given package file (specified as with the --install
flag) without installing it.
flag) without installing it. This function does not update the
uninstalled-package cache.
-r, --remove <owner> <pkg> <maj> <min>
Remove the specified package from the local cache.
-e, --erase <owner> <pkg> <maj> <min>
Remove the specified package from the local cache and the
uninstalled-packages cache.
-p, --packages
List the packages installed in the local cache.

21
collects/planet/planet.ss
View File

@ -62,6 +62,13 @@ PLANNED FEATURES:
""
"Remove the specified package from the local cache"
(set! actions (cons (lambda () (remove owner pkg maj min)) actions)))
(("-e" "--erase")
owner pkg maj min
""
"Erase the specified package, removing it as -r does and "
"eliminating the package's distribution file from the "
"uninstalled-package cache"
(set! actions (cons (lambda () (erase owner pkg maj min)) actions)))
(("-U" "--unlink-all")
""
"Clear the linkage table, unlinking all packages and allowing upgrades"
@ -107,13 +114,13 @@ PLANNED FEATURES:
(define (fail s . args)
(raise (make-exn:fail (string->immutable-string (apply format s args)) (current-continuation-marks))))
(define (download/install owner pkg majstr minstr)
(define (download/install owner name majstr minstr)
(let* ([maj (read-from-string majstr)]
[min (read-from-string minstr)]
[full-pkg-spec (pkg-spec->full-pkg-spec (list owner pkg maj min) #f)])
[full-pkg-spec (pkg-spec->full-pkg-spec (list owner name maj min) #f)])
(when (get-package-from-cache full-pkg-spec)
(fail "No package installed (cache already contains a matching package)"))
(unless (get-package-from-server full-pkg-spec)
(unless (download/install-pkg owner name maj min)
(fail "Could not find matching package"))))
(define (download/no-install owner pkg majstr minstr)
@ -161,6 +168,14 @@ PLANNED FEATURES:
(unless (remove-pkg owner pkg maj min)
(fail "Could not find package"))))
(define (erase owner pkg majstr minstr)
(let ((maj (string->number majstr))
(min (string->number minstr)))
(unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0))
(fail "Invalid major/minor version"))
(unless (erase-pkg owner pkg maj min)
(fail "Could not find package"))))
(define (show-installed-packages)
(let ([normal-packages (get-installed-planet-archives)]
[devel-link-packages (get-hard-linked-packages)])

16
collects/planet/private/linkage.ss
View File

@ -6,7 +6,8 @@
(lib "match.ss")
(prefix srfi1: (lib "1.ss" "srfi")))
(provide get-linkage
(provide get/linkage
get-linkage
add-linkage!
remove-linkage-to!
@ -17,6 +18,17 @@
; The first check is to see if there is a valid linkage for the module.
; ==========================================================================================
;; get/linkage : pkg-getter [see ../resolver.ss]
;; getter for the linkage table
(define (get/linkage module-specifier pkg-specifier success-k failure-k)
(let ([linked-pkg (get-linkage module-specifier pkg-specifier)])
(if linked-pkg
(success-k linked-pkg)
(failure-k
(λ (pkg) (add-linkage! module-specifier pkg-specifier pkg))
(λ (x) x)))))
;; NOTE :: right now we have a nasty situation with the linkage-table: it doesn't associate
;; keys to packages, which it seems it should. Instead it associates keys to the arguments
;; to the pkg-spec constructor; this is done to facilitate reading the data from disk but
@ -93,6 +105,8 @@
(pkg-min pkg)
(path->bytes (pkg-path pkg))))
; get-linkage : symbol FULL-PKG-SPEC -> PKG | #f
; returns the already-linked module location, or #f if there is none
(define (get-linkage module-specifier pkg-specifier)

55
collects/planet/private/planet-shared.ss
View File

@ -16,9 +16,34 @@ Various common pieces of code that both the client and server need to access
(provide (all-defined))
; ==========================================================================================
; DATA
; defines common data used by the PLaneT system
; ==========================================================================================
; exn:i/o:protocol: exception indicating that a protocol error occured
(define-struct (exn:i/o:protocol exn:fail:network) ())
; FULL-PKG-SPEC : struct pkg-spec
(define-struct pkg-spec
(name ; string
maj ; (Nat | #f)
minor-lo ; (Nat | #f)
minor-hi ; (Nat | #f)
path ; (listof string)
stx ; (syntax | #f)
core-version ; string
)
(make-inspector))
; PKG : string (listof string) Nat Nat path
(define-struct pkg (name route maj min path))
; UNINSTALLED-PKG : path FULL-PKG-SPEC Nat Nat
(define-struct uninstalled-pkg (path spec maj min))
; PKG-PROMISE : PKG | UNINSTALLED-PKG
(define (pkg-promise? p) (or (pkg? p) (uninstalled-pkg? p)))
; ==========================================================================================
; CACHE LOGIC
; Handles checking the cache for an appropriate module
@ -41,18 +66,21 @@ Various common pieces of code that both the client and server need to access
(define (legal-language? l)
(and (language-version->repository l) #t))
; lookup-package : FULL-PKG-SPEC -> PKG | #f
; lookup-package : FULL-PKG-SPEC [path (optional)] -> PKG | #f
; returns the directory pointing to the appropriate package in the cache, the user's hardlink table,
; or #f if the given package isn't in the cache or the hardlink table
(define (lookup-package pkg)
(let* ((at (build-assoc-table pkg)))
(get-best-match at pkg)))
(define lookup-package
(case-lambda
[(pkg) (lookup-package pkg (CACHE-DIR))]
[(pkg dir)
(let* ((at (build-assoc-table pkg dir)))
(get-best-match at pkg))]))
; build-assoc-table : FULL-PKG-SPEC -> assoc-table
; build-assoc-table : FULL-PKG-SPEC path -> assoc-table
; returns a version-number -> directory association table for the given package
(define (build-assoc-table pkg)
(define (build-assoc-table pkg dir)
(add-to-table
(dir->assoc-table pkg)
(pkg->assoc-table pkg dir)
(hard-links pkg)))
;; assoc-table ::= (listof (list n n path))
@ -69,10 +97,11 @@ Various common pieces of code that both the client and server need to access
#f))
#f)))
; dir->assoc-table : FULL-PKG-SPEC -> assoc-table
; returns the on-disk packages for the given planet dir
(define (dir->assoc-table pkg)
(define path (build-path (apply build-path (CACHE-DIR) (pkg-spec-path pkg)) (pkg-spec-name pkg)))
; pkg->assoc-table : FULL-PKG-SPEC path -> assoc-table
; returns the on-disk packages for the given planet package in the
; on-disk table rooted at the given directory
(define (pkg->assoc-table pkg dir)
(define path (build-path (apply build-path dir (pkg-spec-path pkg)) (pkg-spec-name pkg)))
(define (tree-stuff->row-or-false p majs mins)
(let ((maj (string->number majs))
@ -291,10 +320,6 @@ Various common pieces of code that both the client and server need to access
(assoc-table-row->min best-row)
(assoc-table-row->dir best-row)))))))
; FULL-PKG-SPEC : (make-pkg-spec string (Nat | #f) (Nat | #f) (Nat | #f) (listof string) (syntax | #f)) string
(define-struct pkg-spec (name maj minor-lo minor-hi path stx core-version) (make-inspector))
; PKG : string (listof string) Nat Nat path
(define-struct pkg (name route maj min path))
;; get-installed-package : string string nat nat -> PKG | #f
;; gets the package associated with this package specification, if any

176
collects/planet/resolver.ss
View File

@ -165,6 +165,7 @@ an appropriate subdirectory.
get-package-from-server
download-package
pkg->download-url
pkg-promise->pkg
install-pkg
get-planet-module-path/pkg)
@ -293,20 +294,56 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
(match-let*
([pspec (pkg-spec->full-pkg-spec pkg-spec stx)]
[pkg (or (get-linkage module-path pspec)
(add-linkage! module-path pspec
(or
(get-package-from-cache pspec)
(get-package-from-server pspec)
(raise-syntax-error #f (format "Could not find package matching ~s"
[result (get-package module-path pspec)])
(cond
[(string? result)
(raise-syntax-error 'require (string->immutable-string result) stx)]
[(pkg-promise? result)
(let ([pkg (pkg-promise->pkg result)])
(values (apply build-path (pkg-path pkg) (append path (list file-name))) pkg))]))]
[_ (raise-syntax-error 'require (format "Illegal PLaneT invocation: ~e" (cdr spec)) stx)]))
;; PKG-GETTER ::= module-path pspec (pkg -> A) ((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 : module-path 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 module-path pspec)
(let loop ([getters (*package-search-chain*)]
[updaters '()]
[error-reporters '()])
(cond
[(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)))
stx))))])
(values (apply build-path (pkg-path pkg) (append path (list file-name))) pkg))]
[_ (raise-syntax-error 'require (format "Illegal PLaneT invocation: ~e" (cdr spec)) stx)]))
(pkg-spec-path pspec)))))]
[else
; try the next error reporter. recursive call is in the failure continuation
((car getters)
module-path
pspec
(λ (pkg)
(for-each (λ (u) (u pkg)) updaters)
pkg)
(λ (updater error-reporter)
(loop (cdr getters)
(cons updater updaters)
(cons error-reporter error-reporters))))])))
; pkg-spec->full-pkg-spec : PKG-SPEC syntax -> FULL-PKG-SPEC
(define (pkg-spec->full-pkg-spec spec stx)
@ -344,33 +381,85 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
; ==========================================================================================
; PHASE 2: CACHE SEARCH
; If there's no linkage, there might still be an appropriate cached module.
; 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 module-spec pkg-spec success-k failure-k)
(let ([p (lookup-package pkg-spec)])
(if p (success-k p) (failure-k 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 : 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 module-spec pkg-spec success-k failure-k)
(let ([p (lookup-package pkg-spec (UNINSTALLED-PACKAGE-CACHE))])
(if (and p (file-exists? (build-path (pkg-path p) (pkg-spec-name pkg-spec))))
(success-k
; note: it's a little sloppy that lookup-pkg returns PKG structures, since
; it doesn't actually know whether or not the package is installed. hence
; I have to convert what appears to be an installed package into an
; uninstalled package
(make-uninstalled-pkg
(build-path (pkg-path p) (pkg-spec-name pkg-spec))
pkg-spec
(pkg-maj p)
(pkg-min p)))
(failure-k
(λ (pkg-promise)
(cond
[(uninstalled-pkg? pkg-promise)
(save-to-uninstalled-pkg-cache! pkg-promise)]
[else (void)]))
(λ (x) x)))))
;; save-to-uninstalled-pkg-cache! : uninstalled-pkg -> void
;; copies the given uninstalled package into the uninstalled-package cache.
;; replaces any old file that might be there
(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)
(when (file-exists? full-pkg-path) (delete-file full-pkg-path))
(copy-file (uninstalled-pkg-path uninst-p) full-pkg-path)))
; ==========================================================================================
; PHASE 3: SERVER RETRIEVAL
; Ask the PLaneT server for an appropriate package if we don't have one locally.
; ==========================================================================================
; get-package-from-server : FULL-PKG-SPEC -> PKG | #f
; downloads and installs the given package from the PLaneT server and installs it in the cache,
; then returns a path to it
(define (get/server module-spec pkg-spec success-k failure-k)
(let ([p (get-package-from-server pkg-spec)])
(cond
[(pkg-promise? p) (success-k p)]
[(string? p)
; replace any existing error message with the server download error message
(failure-k void (λ (_) p))])))
; get-package-from-server : FULL-PKG-SPEC -> PKG-PROMISE | #f
; 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)
(with-handlers
(#;[exn:fail? (lambda (e)
(raise (make-exn:fail
(string->immutable-string
(format
"Error downloading module from PLaneT server: ~a"
(exn-message e)))
(exn-continuation-marks e))))])
(match (download-package pkg)
[(#t path maj min) (install-pkg pkg path maj min)]
[(#f str) #f])))
[(#t path maj min)
(let ([upkg (make-uninstalled-pkg path pkg maj min)])
(save-to-uninstalled-pkg-cache! upkg)
upkg)]
[(#f str) #f]))
(define (download-package pkg)
((if (USE-HTTP-DOWNLOADS?)
@ -387,6 +476,19 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
(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)
@ -506,18 +608,17 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
(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)
(raise (make-exn:i/o:protocol
"Download failed too many times (possibly due to an unreliable network connection)"
(current-continuation-marks))))
(return "Download failed too many times (possibly due to an unreliable network connection)"))
(with-handlers ([exn:fail:network? (λ (e) (return (exn-message e)))])
(let* ((target (pkg->download-url pkg))
(ip (get-impure-port target))
(head (purify-port ip))
@ -526,8 +627,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
(define (abort msg)
(close-input-port ip)
(raise (make-exn:i/o:protocol (string->immutable-string msg)
(current-continuation-marks))))
(return msg))
(case response-code
[(#f) (abort (format "Server returned invalid HTTP response code ~s" response-code/str))]
@ -539,7 +639,6 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
(nat? (string->number maj/str))
(nat? (string->number min/str))
(nat? (string->number content-length/str)))
(printf "~a" head)
(abort "Server did not include valid major and minor version information"))
(let* ((filename (make-temporary-file "planettmp~a.plt"))
(maj (string->number maj/str))
@ -567,7 +666,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
[(eof-object? line) '()]
[else (list* line "\n" (loop))]))))))]
[else
(abort (format "Internal error (unknown HTTP response code ~a)" response-code))]))))
(abort (format "Internal error (unknown HTTP response code ~a)" response-code))]))))))
; ==========================================================================================
; MODULE MANAGEMENT
@ -584,6 +683,15 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
stx
load?)))
(define *package-search-chain*
(make-parameter
(list
get/linkage
get/installed-cache
get/uninstalled-cache
get/server)))
; ============================================================
; UTILITY
; A few small utility functions
@ -604,6 +712,4 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
[else
(let ((dirs (make-directory*/paths base)))
(make-directory dir)
(cons dir dirs))]))))
)
(cons dir dirs))])))))

36
collects/planet/util.ss
View File

@ -5,6 +5,7 @@
"private/planet-shared.ss"
"private/linkage.ss"
"resolver.ss"
(lib "url.ss" "net")
(lib "pack.ss" "setup")
(lib "contract.ss")
@ -15,6 +16,7 @@
#| The util collection provides a number of useful functions for interacting with the PLaneT system. |#
(provide
current-cache-contents
current-linkage
make-planet-archive
@ -24,10 +26,23 @@
unlink-all)
(provide/contract
[download/install-pkg
(-> string? string? natural-number/c natural-number/c (union pkg? false/c))]
[add-hard-link
(-> string? string? natural-number/c natural-number/c path? void?)]
[remove-hard-link
(-> string? string? natural-number/c natural-number/c void?)])
(-> string? string? natural-number/c natural-number/c void?)]
[erase-pkg
(-> string? string? natural-number/c natural-number/c boolean?)])
;; download/install-pkg : string string nat nat -> pkg | #f
(define (download/install-pkg owner name maj min)
(let* ([pspec (pkg-spec->full-pkg-spec (list owner name maj min) #f)]
[upkg (get-package-from-server pspec)])
(cond
[(uninstalled-pkg? upkg)
(pkg-promise->pkg upkg)]
[else #f])))
;; current-cache-contents : -> ((string ((string ((nat (nat ...)) ...)) ...)) ...)
;; returns the packages installed in the local PLaneT cache
@ -79,6 +94,20 @@
(printf "\n")))
'truncate/replace)))))
(define (erase-pkg owner name maj min)
(let* ([uninstalled-pkg-dir
(build-path (UNINSTALLED-PACKAGE-CACHE) owner name (number->string maj) (number->string min))]
[uninstalled-pkg-file (build-path uninstalled-pkg-dir name)])
(let ([removed-something? (remove-pkg owner name maj min)]
[erased-something?
(if (file-exists? uninstalled-pkg-file)
(begin
(delete-file uninstalled-pkg-file)
(trim-directory (UNINSTALLED-PACKAGE-CACHE) uninstalled-pkg-dir)
#t)
#f)])
(or removed-something? erased-something?))))
;; listof X * listof X -> nonempty listof X
;; returns de-prefixed version of l2 if l1 is a proper prefix of l2;
;; signals an error otherwise.
@ -186,7 +215,4 @@
(lambda (row)
(let ([p (row->package row)])
(when p
(erase-metadata p))))))
)
(erase-metadata p)))))))