From ede983c90bd4cdece708820e1d52a2d1894a51c8 Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov Date: Sun, 22 Sep 2013 18:50:06 +0000 Subject: [PATCH] guix package: Add '--delete-generations'. * guix/scripts/package.scm (link-to-empty-environment) (switch-to-previous-generation): New functions. (roll-back): Replace internal functions with the new ones. (show-help): Add '--delete-generations'. (%options): Likewise. (guix-package): Add 'apply-to-generations'. (guix-package)[process-actions]: Add support for '--delete-generations'. (guix-package)[process-query]: Replace 'cond' with 'apply-to-generations'. * tests/guix-package.sh: Test '--delete-generations'. * doc/guix.texi (Invoking guix-package): Document '--delete-generations'. --- doc/guix.texi | 7 ++ guix/scripts/package.scm | 271 ++++++++++++++++++++++++++++------------------ tests/guix-package.sh | 7 ++ 3 files changed, 178 insertions(+), 107 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index fdddcc5..3d61630 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -639,6 +639,13 @@ or months by passing an integer along with the first letter of the duration, e.g., @code{--list-generations=20d}. @end itemize address@hidden address@hidden address@hidden -d address@hidden +Delete generations. + +When @var{pattern} is specified, delete only the matching generations. +This command accepts the same patterns as @option{--list-generations}. + @item address@hidden @itemx -p @var{profile} Use @var{profile} instead of the user's default profile. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index c0cedcd..c72b56e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -214,6 +214,25 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." (compose string->number (cut match:substring <> 1))) 0)) +(define (link-to-empty-environment generation) + "Link GENERATION, a string, to the empty environment." + (let* ((drv (profile-derivation (%store) '())) + (prof (derivation->output-path drv "out"))) + (when (not (build-derivations (%store) (list drv))) + (leave (_ "failed to build the empty profile~%"))) + + (switch-symlinks generation prof))) + +(define (switch-to-previous-generation profile) + "Atomically switch PROFILE to the previous generation." + (let* ((number (generation-number profile)) + (previous-number (previous-generation-number profile number)) + (previous-generation (format #f "~a-~a-link" + profile previous-number))) + (format #t (_ "switching from generation ~a to ~a~%") + number previous-number) + (switch-symlinks profile previous-generation))) + (define (roll-back profile) "Roll back to the previous generation of PROFILE." (let* ((number (generation-number profile)) @@ -222,28 +241,18 @@ all of PACKAGES, a list of name/version/output/path/deps tuples." profile previous-number)) (manifest (string-append previous-generation "/manifest"))) - (define (switch-link) - ;; Atomically switch PROFILE to the previous generation. - (format #t (_ "switching from generation ~a to ~a~%") - number previous-number) - (switch-symlinks profile previous-generation)) - - (cond ((not (file-exists? profile)) ; invalid profile + (cond ((not (file-exists? profile)) ; invalid profile (leave (_ "profile `~a' does not exist~%") profile)) - ((zero? number) ; empty profile + ((zero? number) ; empty profile (format (current-error-port) (_ "nothing to do: already at the empty profile~%"))) - ((or (zero? previous-number) ; going to emptiness + ((or (zero? previous-number) ; going to emptiness (not (file-exists? previous-generation))) - (let* ((drv (profile-derivation (%store) '())) - (prof (derivation->output-path drv "out"))) - (when (not (build-derivations (%store) (list drv))) - (leave (_ "failed to build the empty profile~%"))) - - (switch-symlinks previous-generation prof) - (switch-link))) - (else (switch-link))))) ; anything else + (begin (link-to-empty-environment previous-generation) + (switch-to-previous-generation profile))) + (else + (switch-to-previous-generation profile))))) ; anything else (define (generation-time profile number) "Return the creation time of a generation in the UTC format." @@ -511,6 +520,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (display (_ " -l, --list-generations[=PATTERN] list generations matching PATTERN")) + (display (_ " + -d, --delete-generations[=PATTERN] + delete generations matching PATTERN")) (newline) (display (_ " -p, --profile=PROFILE use PROFILE instead of the user's default profile")) @@ -574,6 +586,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (lambda (opt name arg result) (cons `(query list-generations ,(or arg "")) result))) + (option '(#\d "delete-generations") #f #t + (lambda (opt name arg result) + (alist-cons 'delete-generations (or arg "") + result))) (option '("search-paths") #f #f (lambda (opt name arg result) (cons `(query search-paths) result))) @@ -742,6 +758,20 @@ more information.~%")) %profile-directory (or (getenv "USER") (getuid))) (rtfm)))) + (define (apply-to-generations function profile pattern) + (cond ((not (file-exists? profile)) ; XXX: race condition + (leave (_ "profile '~a' does not exist~%") + profile)) + ((string-null? pattern) + (for-each function + (generation-numbers profile))) + ((matching-generations pattern profile) + => + (cut for-each function <>)) + (else + (leave (_ "invalid syntax: ~a~%") + pattern)))) + (define (process-actions opts) ;; Process any install/remove/upgrade action from OPTS. @@ -824,85 +854,123 @@ more information.~%")) install)))) (_ #f))) + (define (delete-generation number) + (define (display-and-delete generation) + (begin (format #t "deleting ~a~%" generation) + (delete-file generation))) + + (define (current-generation? profile generation) + (string=? (readlink profile) generation)) + + (let* ((generation (format #f "~a-~a-link" profile number)) + (previous-number (previous-generation-number profile number)) + (previous-generation (format #f "~a-~a-link" + profile previous-number))) + (cond ((zero? number)) ; do not delete generation 0 + ((and (current-generation? profile generation) + (not (file-exists? previous-generation))) + (begin (link-to-empty-environment previous-generation) + (switch-to-previous-generation profile) + (display-and-delete generation))) + ((current-generation? profile generation) + (begin (roll-back profile) + (display-and-delete generation))) + (else + (display-and-delete generation))))) + ;; First roll back if asked to. - (if (and (assoc-ref opts 'roll-back?) (not dry-run?)) - (begin - (roll-back profile) - (process-actions (alist-delete 'roll-back? opts))) - (let* ((installed (manifest-packages (profile-manifest profile))) - (upgrade-regexps (filter-map (match-lambda - (('upgrade . regexp) - (make-regexp (or regexp ""))) - (_ #f)) - opts)) - (upgrade (if (null? upgrade-regexps) - '() - (let ((newest (find-newest-available-packages))) - (filter-map (match-lambda - ((name version output path _) - (and (any (cut regexp-exec <> name) - upgrade-regexps) - (upgradeable? name version path) - (find-package name - (or output "out")))) - (_ #f)) - installed)))) - (install (append - upgrade - (filter-map (match-lambda - (('install . (? package? p)) - (package->tuple p)) - (('install . (? store-path?)) - #f) - (('install . package) - (find-package package)) - (_ #f)) - opts))) - (drv (filter-map (match-lambda - ((name version sub-drv - (? package? package) - (deps ...)) - (check-package-freshness package) - (package-derivation (%store) package)) - (_ #f)) - install)) - (install* (append - (filter-map (match-lambda - (('install . (? package? p)) - #f) - (('install . (? store-path? path)) - (let-values (((name version) - (package-name->name+version - (store-path-package-name - path)))) - `(,name ,version #f ,path ()))) + (cond ((and (assoc-ref opts 'roll-back?) (not dry-run?)) + (begin + (roll-back profile) + (process-actions (alist-delete 'roll-back? opts)))) + ((and (assoc-ref opts 'delete-generations) + (not dry-run?)) + (filter-map (match-lambda + (('delete-generations . pattern) + (begin (apply-to-generations delete-generation + profile pattern) + (process-actions + (alist-delete 'delete-generations opts)))) + (_ #f)) + opts)) + (else + (let* ((installed (manifest-packages (profile-manifest profile))) + (upgrade-regexps (filter-map (match-lambda + (('upgrade . regexp) + (make-regexp (or regexp ""))) + (_ #f)) + opts)) + (upgrade (if (null? upgrade-regexps) + '() + (let ((newest (find-newest-available-packages))) + (filter-map + (match-lambda + ((name version output path _) + (and (any (cut regexp-exec <> name) + upgrade-regexps) + (upgradeable? name version path) + (find-package name + (or output "out")))) + (_ #f)) + installed)))) + (install (append + upgrade + (filter-map (match-lambda + (('install . (? package? p)) + (package->tuple p)) + (('install . (? store-path?)) + #f) + (('install . package) + (find-package package)) + (_ #f)) + opts))) + (drv (filter-map (match-lambda + ((name version sub-drv + (? package? package) + (deps ...)) + (check-package-freshness package) + (package-derivation (%store) package)) + (_ #f)) + install)) + (install* + (append + (filter-map (match-lambda + (('install . (? package? p)) + #f) + (('install . (? store-path? path)) + (let-values (((name version) + (package-name->name+version + (store-path-package-name + path)))) + `(,name ,version #f ,path ()))) + (_ #f)) + opts) + (map (lambda (tuple drv) + (match tuple + ((name version sub-drv _ (deps ...)) + (let ((output-path + (derivation->output-path + drv sub-drv))) + `(,name ,version ,sub-drv ,output-path + ,(canonicalize-deps deps)))))) + install drv))) + (remove (filter-map (match-lambda + (('remove . package) + package) (_ #f)) - opts) - (map (lambda (tuple drv) - (match tuple - ((name version sub-drv _ (deps ...)) - (let ((output-path - (derivation->output-path - drv sub-drv))) - `(,name ,version ,sub-drv ,output-path - ,(canonicalize-deps deps)))))) - install drv))) - (remove (filter-map (match-lambda - (('remove . package) - package) - (_ #f)) - opts)) - (remove* (filter-map (cut assoc <> installed) remove)) - (packages (append install* - (fold (lambda (package result) - (match package - ((name _ out _ ...) - (filter (negate - (cut same-package? <> - name out)) - result)))) - (fold alist-delete installed remove) - install*)))) + opts)) + (remove* (filter-map (cut assoc <> installed) remove)) + (packages + (append install* + (fold (lambda (package result) + (match package + ((name _ out _ ...) + (filter (negate + (cut same-package? <> + name out)) + result)))) + (fold alist-delete installed remove) + install*)))) (when (equal? profile %current-profile) (ensure-default-profile)) @@ -946,7 +1014,7 @@ more information.~%")) count) count) (display-search-paths packages - profile)))))))))) + profile))))))))))) (define (process-query opts) ;; Process any query specified by OPTS. Return #t when a query was @@ -970,18 +1038,7 @@ more information.~%")) (format #f "~a-~a-link" profile number)))) (newline))) - (cond ((not (file-exists? profile)) ; XXX: race condition - (leave (_ "profile '~a' does not exist~%") - profile)) - ((string-null? pattern) - (for-each list-generation - (generation-numbers profile))) - ((matching-generations pattern profile) - => - (cut for-each list-generation <>)) - (else - (leave (_ "invalid syntax: ~a~%") - pattern))) + (apply-to-generations list-generation profile pattern) #t) (('list-installed regexp) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index b09a9c0..65bc94c 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -132,6 +132,13 @@ then # Make sure LIBRARY_PATH gets listed by `--search-paths'. guix package --bootstrap -p "$profile" -i guile-bootstrap -i gcc-bootstrap guix package --search-paths -p "$profile" | grep LIBRARY_PATH + + # Delete the third generation and check that it was actually deleted. + guix package -p "$profile" --delete-generations=3 + test -z "`guix package -p "$profile" -l 3`" + + # Do not output anything when such a generation does not exist. + test -z "`guix package -p "$profile" --delete-generations=42`" fi # Make sure the `:' syntax works. -- 1.7.9.5