From f02c4d7a805694fd4417cc8222b44f6f3d309b64 Mon Sep 17 00:00:00 2001 From: Jacob Matthews Date: Fri, 4 Aug 2006 01:00:31 +0000 Subject: [PATCH] Added a local uninstalled-packages cache and associated tools; refactored the planet download search order code svn: r3951 --- collects/planet/config.ss | 1 + collects/planet/doc.txt | 31 ++- collects/planet/planet.ss | 21 +- collects/planet/private/linkage.ss | 16 +- collects/planet/private/planet-shared.ss | 57 +++-- collects/planet/resolver.ss | 286 ++++++++++++++++------- collects/planet/util.ss | 36 ++- 7 files changed, 332 insertions(+), 116 deletions(-) diff --git a/collects/planet/config.ss b/collects/planet/config.ss index dbbd41d7ac..c3020cd851 100644 --- a/collects/planet/config.ss +++ b/collects/planet/config.ss @@ -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) diff --git a/collects/planet/doc.txt b/collects/planet/doc.txt index 7a98096a71..1be93a4b28 100644 --- a/collects/planet/doc.txt +++ b/collects/planet/doc.txt @@ -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 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 Remove the specified package from the local cache. +-e, --erase + +Remove the specified package from the local cache and the +uninstalled-packages cache. + -p, --packages List the packages installed in the local cache. diff --git a/collects/planet/planet.ss b/collects/planet/planet.ss index 046459c047..5d88d3844c 100644 --- a/collects/planet/planet.ss +++ b/collects/planet/planet.ss @@ -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) @@ -160,6 +167,14 @@ PLANNED FEATURES: (fail "Invalid major/minor version")) (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)] diff --git a/collects/planet/private/linkage.ss b/collects/planet/private/linkage.ss index 2f7fd81559..08d3efc9ab 100644 --- a/collects/planet/private/linkage.ss +++ b/collects/planet/private/linkage.ss @@ -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! @@ -16,6 +17,17 @@ ; PHASE 1: LINKAGE ; The first check is to see if there is a valid linkage for the module. ; ========================================================================================== + + ;; get/linkage : pkg-getter [see ../resolver.ss] + ;; getter for the linkage table + (define (get/linkage 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 @@ -92,6 +104,8 @@ (pkg-maj pkg) (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 diff --git a/collects/planet/private/planet-shared.ss b/collects/planet/private/planet-shared.ss index 804b262d7c..6824df98cf 100644 --- a/collects/planet/private/planet-shared.ss +++ b/collects/planet/private/planet-shared.ss @@ -15,10 +15,35 @@ Various common pieces of code that both the client and server need to access "../config.ss") (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,11 +320,7 @@ 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 (define (get-installed-package owner name maj min) diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index 65d8eb083d..8bd528c1ea 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -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,21 +294,57 @@ 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" - (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))] + [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)))))] + [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) (define (pkg name maj lo hi path) (make-pkg-spec name maj lo hi path stx (version))) @@ -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]))) + (match (download-package pkg) + [(#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) @@ -422,7 +524,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" ; didn't exist and the string is the server's informative message. ; raises an exception if some protocol failure occurs in the download process (define (download-package/planet pkg) - + (define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT))) (define (close-ports) @@ -505,70 +607,67 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" ;; 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 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)))) + (let/ec return + (let loop ([attempts 1]) + (when (> attempts 5) + (return "Download failed too many times (possibly due to an unreliable network connection)")) - (let* ((target (pkg->download-url pkg)) - (ip (get-impure-port target)) - (head (purify-port ip)) - (response-code/str (get-http-response-code head)) - (response-code (string->number response-code/str))) - - (define (abort msg) - (close-input-port ip) - (raise (make-exn:i/o:protocol (string->immutable-string msg) - (current-continuation-marks)))) - - (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))) - (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)) - (min (string->number min/str)) - (content-length (string->number content-length/str))) - (let ([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))) - (cond - [(eof-object? line) '()] - [else (list* line "\n" (loop))]))))))] - [else - (abort (format "Internal error (unknown HTTP response code ~a)" response-code))])))) - + (with-handlers ([exn:fail:network? (λ (e) (return (exn-message e)))]) + (let* ((target (pkg->download-url pkg)) + (ip (get-impure-port target)) + (head (purify-port ip)) + (response-code/str (get-http-response-code head)) + (response-code (string->number response-code/str))) + + (define (abort msg) + (close-input-port ip) + (return msg)) + + (case response-code + [(#f) (abort (format "Server returned invalid HTTP response code ~s" response-code/str))] + [(200) + (let ((maj/str (extract-field "Package-Major-Version" head)) + (min/str (extract-field "Package-Minor-Version" head)) + (content-length/str (extract-field "Content-Length" head))) + (unless (and maj/str min/str content-length/str + (nat? (string->number maj/str)) + (nat? (string->number min/str)) + (nat? (string->number content-length/str))) + (abort "Server did not include valid major and minor version information")) + (let* ((filename (make-temporary-file "planettmp~a.plt")) + (maj (string->number maj/str)) + (min (string->number min/str)) + (content-length (string->number content-length/str))) + (let ([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))) + (cond + [(eof-object? line) '()] + [else (list* line "\n" (loop))]))))))] + [else + (abort (format "Internal error (unknown HTTP response code ~a)" response-code))])))))) + ; ========================================================================================== ; MODULE MANAGEMENT ; Handles interaction with the module system @@ -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))]))))) diff --git a/collects/planet/util.ss b/collects/planet/util.ss index 0b143f9dcb..1ea018cd55 100644 --- a/collects/planet/util.ss +++ b/collects/planet/util.ss @@ -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,11 +26,24 @@ 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 (define (current-cache-contents) @@ -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)))))))