Added a local uninstalled-packages cache and associated tools;

refactored the planet download search order code

svn: r3951

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)

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 <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.

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)]

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

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)
+  (define lookup-package
-    (let* ((at (build-assoc-table pkg)))
+    (case-lambda 
-      (get-best-match at pkg)))
+      [(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
+  ; pkg->assoc-table : FULL-PKG-SPEC path -> assoc-table
-  ; returns the on-disk packages for the given planet dir
+  ; returns the on-disk packages for the given planet package in the
-  (define (dir->assoc-table pkg)
+  ; on-disk table rooted at the given directory
-    (define path (build-path (apply build-path (CACHE-DIR) (pkg-spec-path pkg)) (pkg-spec-name pkg)))
+  (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)

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)
+            [result (get-package module-path pspec)])
-                     (add-linkage! module-path pspec
+         (cond
-                                   (or
+           [(string? result)
-                                    (get-package-from-cache pspec)
+            (raise-syntax-error 'require (string->immutable-string result) stx)]
-                                    (get-package-from-server pspec)
+           [(pkg-promise? result)
-                                    (raise-syntax-error #f (format "Could not find package matching ~s" 
+            (let ([pkg (pkg-promise->pkg result)])
-                                                                   (list (pkg-spec-name pspec)
+              (values (apply build-path (pkg-path pkg) (append path (list file-name))) pkg))]))]
-                                                                         (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-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
+  (define (get/server module-spec pkg-spec success-k failure-k)
-  ; downloads and installs the given package from the PLaneT server and installs it in the cache,
+    (let ([p (get-package-from-server pkg-spec)])
-  ; then returns a path to it 
+      (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
+    (match (download-package pkg)
-        (#;[exn:fail? (lambda (e) 
+      [(#t path maj min) 
-                      (raise (make-exn:fail
+       (let ([upkg (make-uninstalled-pkg path pkg maj min)])
-                              (string->immutable-string
+         (save-to-uninstalled-pkg-cache! upkg)
-                               (format 
+         upkg)]
-                                "Error downloading module from PLaneT server: ~a"
+      [(#f str) #f]))
-                                (exn-message e)))
-                              (exn-continuation-marks e))))])
-      (match (download-package pkg)
-        [(#t path maj min) (install-pkg pkg path maj min)]
-        [(#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])
+    (let/ec return
-      (when (> attempts 5)
+      (let loop ([attempts 1])
-        (raise (make-exn:i/o:protocol 
+        (when (> attempts 5)
-                "Download failed too many times (possibly due to an unreliable network connection)"
+          (return "Download failed too many times (possibly due to an unreliable network connection)"))
-                (current-continuation-marks))))
         
-      (let* ((target            (pkg->download-url pkg))
+        (with-handlers ([exn:fail:network? (λ (e) (return (exn-message e)))])
-             (ip                (get-impure-port target))
+          (let* ((target            (pkg->download-url pkg))
-             (head              (purify-port ip))
+                 (ip                (get-impure-port target))
-             (response-code/str (get-http-response-code head))
+                 (head              (purify-port ip))
-             (response-code     (string->number response-code/str)))
+                 (response-code/str (get-http-response-code head))
-        
+                 (response-code     (string->number response-code/str)))
-        (define (abort msg)
+            
-          (close-input-port ip)
+            (define (abort msg)
-          (raise (make-exn:i/o:protocol (string->immutable-string msg)
+              (close-input-port ip)
-                                        (current-continuation-marks))))
+              (return msg))
-      
+            
-        (case response-code
+            (case response-code
-          [(#f)  (abort (format "Server returned invalid HTTP response code ~s" response-code/str))]
+              [(#f)  (abort (format "Server returned invalid HTTP response code ~s" response-code/str))]
-          [(200)
+              [(200)
-           (let ((maj/str (extract-field "Package-Major-Version" head))
+               (let ((maj/str (extract-field "Package-Major-Version" head))
-                 (min/str (extract-field "Package-Minor-Version" head))
+                     (min/str (extract-field "Package-Minor-Version" head))
-                 (content-length/str (extract-field "Content-Length" head)))
+                     (content-length/str (extract-field "Content-Length" head)))
-             (unless (and maj/str min/str content-length/str
+                 (unless (and maj/str min/str content-length/str
-                          (nat? (string->number maj/str))
+                              (nat? (string->number maj/str))
-                          (nat? (string->number min/str))
+                              (nat? (string->number min/str))
-                          (nat? (string->number content-length/str)))
+                              (nat? (string->number content-length/str)))
-               (printf "~a" head)
+                   (abort "Server did not include valid major and minor version information"))
-               (abort "Server did not include valid major and minor version information"))
+                 (let* ((filename (make-temporary-file "planettmp~a.plt"))
-             (let* ((filename (make-temporary-file "planettmp~a.plt"))
+                        (maj      (string->number maj/str))
-                    (maj      (string->number maj/str))
+                        (min      (string->number min/str))
-                    (min      (string->number min/str))
+                        (content-length (string->number content-length/str)))
-                    (content-length (string->number content-length/str)))
+                   (let ([op (open-output-file filename 'truncate/replace)])
-               (let ([op (open-output-file filename 'truncate/replace)])
+                     (copy-port ip op)
-                 (copy-port ip op)
+                     (close-input-port ip)
-                 (close-input-port ip)
+                     (close-output-port op)
-                 (close-output-port op)
+                     (if (= (file-size filename) content-length)
-                 (if (= (file-size filename) content-length)
+                         (list #t filename maj min)
-                     (list #t filename maj min)
+                         (loop (add1 attempts))))))]
-                     (loop (add1 attempts))))))]
+              [(404)
-          [(404)
+               (begin0
-           (begin0
+                 (list #f (format "Server had no matching package: ~a" (read-line ip)))
-             (list #f (format "Server had no matching package: ~a" (read-line ip)))
+                 (close-input-port ip))]
-             (close-input-port ip))]
+              [(400)
-          [(400)
+               (abort (format "Internal error (malformed request): ~a" (read-line ip)))]
-           (abort (format "Internal error (malformed request): ~a" (read-line ip)))]
+              [(500)
-          [(500)
+               (abort (format "Server internal error: ~a"
-           (abort (format "Server internal error: ~a"
+                              (apply string-append
-                          (apply string-append
+                                     (let loop ()
-                                 (let loop ()
+                                       (let ((line (read-line ip)))
-                                   (let ((line (read-line ip)))
+                                         (cond
-                                     (cond
+                                           [(eof-object? line) '()]
-                                       [(eof-object? line) '()]
+                                           [else (list* line "\n" (loop))]))))))]
-                                       [else (list* line "\n" (loop))]))))))]
+              [else
-          [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
   ; 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))])))))
-  
-  )

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)))))))
-
-  
-  )