diff --git a/collects/planet/planet.ss b/collects/planet/planet.ss index cb73dae7a7..86208211b0 100644 --- a/collects/planet/planet.ss +++ b/collects/planet/planet.ss @@ -179,16 +179,16 @@ PLANNED FEATURES: (min (string->number minstr))) (unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0)) (fail "Invalid major/minor version")) - (unless (remove-pkg owner pkg maj min) - (fail "Could not find package")))) + (with-handlers ([exn:fail:planet? (λ (e) (fail (exn-message e)))]) + (remove-pkg owner pkg maj min)))) (define (erase owner pkg majstr minstr) (let ((maj (string->number majstr)) (min (string->number minstr))) (unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0)) (fail "Invalid major/minor version")) - (unless (erase-pkg owner pkg maj min) - (fail "Could not find package")))) + (with-handlers ([exn:fail:planet? (λ (e) (fail (exn-message e)))]) + (erase-pkg owner pkg maj min)))) (define (show-installed-packages) (let ([normal-packages (get-installed-planet-archives)] diff --git a/collects/planet/private/planet-shared.ss b/collects/planet/private/planet-shared.ss index f2a1c085b1..39f3a18688 100644 --- a/collects/planet/private/planet-shared.ss +++ b/collects/planet/private/planet-shared.ss @@ -36,14 +36,21 @@ Various common pieces of code that both the client and server need to access core-version ; string ) (make-inspector)) - ; PKG : string (listof string) Nat Nat path - (define-struct pkg (name route maj min path)) + ; PKG : string (listof string) Nat Nat path ORIGIN + (define-struct pkg (name route maj min path origin)) ; UNINSTALLED-PKG : path FULL-PKG-SPEC Nat Nat (define-struct uninstalled-pkg (path spec maj min)) ; PKG-PROMISE : PKG | UNINSTALLED-PKG + ; ORIGIN : 'normal | 'development-link (define (pkg-promise? p) (or (pkg? p) (uninstalled-pkg? p))) + (define (normally-installed-pkg? p) + (eq? (pkg-origin p) 'normal)) + + (define (development-link-pkg? p) + (eq? (pkg-origin p) 'development-link)) + ; ========================================================================================== ; CACHE LOGIC ; Handles checking the cache for an appropriate module @@ -140,7 +147,8 @@ Various common pieces of code that both the client and server need to access (pkg-spec-path pkg) maj min the-path - min-core-version)) + min-core-version + 'normal)) #f))) (if (directory-exists? path) @@ -176,7 +184,7 @@ Various common pieces of code that both the client and server need to access (define (get-hard-link-table) (verify-well-formed-hard-link-parameter!) (if (file-exists? (HARD-LINK-FILE)) - (map (lambda (item) (update-element 4 bytes->path item)) + (map (lambda (item) (update/create-element 6 (λ (_) 'development-link) (update-element 4 bytes->path item))) (with-input-from-file (HARD-LINK-FILE) read-all)) '())) @@ -217,7 +225,7 @@ Various common pieces of code that both the client and server need to access (let ([complete-dir (path->complete-path dir)]) (let* ([original-table (get-hard-link-table)] [new-table (cons - (make-assoc-table-row name path maj min complete-dir #f) + (make-assoc-table-row name path maj min complete-dir #f 'development-link) (filter (lambda (row) (not (points-to? row name path maj min))) original-table))]) @@ -239,6 +247,17 @@ Various common pieces of code that both the client and server need to access [(zero? n) (cons (f (car l)) (cdr l))] [else (cons (car l) (update-element (sub1 n) f (cdr l)))])) + (define (update/create-element n f l) + (cond + [(and (null? l) (zero? n)) + (list (f #f))] + [(and (null? l) (not (zero? n))) + (error 'update/create-element "Index too large")] + [(and (not (null? l)) (zero? n)) + (cons (f (car l)) (cdr l))] + [else (cons (car l) (update/create-element (sub1 n) f (cdr l)))])) + + ; add-to-table assoc-table (listof assoc-table-row) -> assoc-table (define add-to-table append) @@ -258,11 +277,12 @@ Various common pieces of code that both the client and server need to access assoc-table-row->maj assoc-table-row->min assoc-table-row->dir - assoc-table-row->required-version) - (first-n-list-selectors 6)) + assoc-table-row->required-version + assoc-table-row->type) + (first-n-list-selectors 7)) - (define (make-assoc-table-row name path maj min dir required-version) - (list name path maj min dir required-version)) + (define (make-assoc-table-row name path maj min dir required-version type) + (list name path maj min dir required-version type)) (define-struct mz-version (major minor)) @@ -342,7 +362,8 @@ Various common pieces of code that both the client and server need to access (pkg-spec-path spec) (assoc-table-row->maj best-row) (assoc-table-row->min best-row) - (assoc-table-row->dir best-row))))))) + (assoc-table-row->dir best-row) + (assoc-table-row->type best-row))))))) ;; get-installed-package : string string nat nat -> PKG | #f diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index 6c9c3b3d99..81af8b4619 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -599,7 +599,7 @@ an appropriate subdirectory. (parameterize ((current-namespace (make-namespace))) (let ([ipp (dynamic-require '(lib "plt-single-installer.ss" "setup") 'install-planet-package)]) (ipp path the-dir (list owner (pkg-spec-name pkg) extra-path maj min)))))) - (make-pkg (pkg-spec-name pkg) (pkg-spec-path pkg) maj min the-dir))))) + (make-pkg (pkg-spec-name pkg) (pkg-spec-path pkg) maj min the-dir 'normal))))) ; download-package : FULL-PKG-SPEC -> RESPONSE ; RESPONSE ::= (list #f string) | (list #t path[file] Nat Nat) diff --git a/collects/planet/util.ss b/collects/planet/util.ss index 174142f8e9..744ae3c27d 100644 --- a/collects/planet/util.ss +++ b/collects/planet/util.ss @@ -28,11 +28,10 @@ force-package-building? get-installed-planet-archives get-hard-linked-packages - remove-pkg unlink-all lookup-package-by-keys - - resolve-planet-path) + resolve-planet-path + (struct exn:fail:planet ())) (provide/contract [download/install-pkg @@ -41,8 +40,10 @@ (-> string? string? natural-number/c natural-number/c path? void?)] [remove-hard-link (-> string? string? natural-number/c natural-number/c void?)] + [remove-pkg + (-> string? string? natural-number/c natural-number/c void?)] [erase-pkg - (-> string? string? natural-number/c natural-number/c boolean?)]) + (-> string? string? natural-number/c natural-number/c void?)]) ;; download/install-pkg : string string nat nat -> pkg | #f (define (download/install-pkg owner name maj min) @@ -66,20 +67,27 @@ ;; -- remove relevant infodomain cache entries ;; -- delete files from cache directory ;; -- remove any existing linkage for package - ;; returns #t if the removal worked; #f if no package existed. + ;; returns void if the removal worked; raises an exception if no package existed. + + (define-struct (exn:fail:planet exn:fail) ()) + (define (remove-pkg owner name maj min) (let ((p (get-installed-package owner name maj min))) - (and p - (let ((path (pkg-path p))) - (with-logging - (LOG-FILE) - (lambda () - (printf "\n============= Removing ~a =============\n" (list owner name maj min)) - (clean-planet-package path (list owner name '() maj min)))) - (erase-metadata p) - (delete-directory/files path) - (trim-directory (CACHE-DIR) path) - #t)))) + (unless p + (raise (make-exn:fail:planet "Could not find package" (current-continuation-marks)))) + (unless (normally-installed-pkg? p) + (raise (make-exn:fail:planet "Not a normally-installed package, can't remove" (current-continuation-marks)))) + + (let ((path (pkg-path p))) + (with-logging + (LOG-FILE) + (lambda () + (printf "\n============= Removing ~a =============\n" (list owner name maj min)) + (clean-planet-package path (list owner name '() maj min)))) + (erase-metadata p) + (delete-directory/files path) + (trim-directory (CACHE-DIR) path) + (void)))) ;; erase-metadata : pkg -> void ;; clears out any references to the given package in planet's metadata files @@ -135,16 +143,17 @@ (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?)))) + [uninstalled-pkg-file (build-path uninstalled-pkg-dir name)] + [uninstalled-file-exists? (file-exists? uninstalled-pkg-file)]) + (when uninstalled-file-exists? + (delete-file uninstalled-pkg-file) + (trim-directory (UNINSTALLED-PACKAGE-CACHE) uninstalled-pkg-dir)) + (with-handlers ([exn:fail:planet? + (λ (e) (if uninstalled-file-exists? + ;; not really a failure, just return + (void) + (raise e)))]) + (remove-pkg owner name maj min)))) ;; listof X * listof X -> nonempty listof X ;; returns de-prefixed version of l2 if l1 is a proper prefix of l2;