[PATCH] guix package: Add '--delete-generations'.

[Nikita Karetnikov <nikita@karetnikov.org>]

[-- Attachment #1.1: Type: text/plain, Size: 266 bytes --]

Can I push this patch to ‘master’?  Do you see any problems?

I had noticed that ‘--roll-back’ doesn’t output anything with
‘--dry-run’, so I implemented ‘--delete-generations’ similarly.  Maybe
it would be better to print something.  WDYT?


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0001-guix-package-Add-delete-generations.patch --]
[-- Type: text/x-diff, Size: 20291 bytes --]

From ede983c90bd4cdece708820e1d52a2d1894a51c8 Mon Sep 17 00:00:00 2001
From: Nikita Karetnikov <nikita@karetnikov.org>
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
 
+@item --delete-generations[=@var{pattern}]
+@itemx -d [@var{pattern}]
+Delete generations.
+
+When @var{pattern} is specified, delete only the matching generations.
+This command accepts the same patterns as @option{--list-generations}.
+
 @item --profile=@var{profile}
 @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


[-- Attachment #2: Type: application/pgp-signature, Size: 835 bytes --]