Re: New ‘--list-generations’ and ‘--delete-generations’ options

[Nikita Karetnikov <nikita@karetnikov.org>]

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

> I’d prefer clearer case analysis as shown above.

OK, what do you think about this diff?  If everything is fine, I’ll make
it output generations in the recutils format.

(Is it necessary to mention that ‘maybe-comma-separated-integers’ accepts
something like ‘1,2,3,’ or ‘1,,,2’.  Or should I change the function?)

I don’t know if the code works with non-default profiles because my
store is broken.  When I try to install or build a new package (with or
without substitutes), I get the following message:

guix package: error: build failed: getting attributes of path `/nix/store/fcwh19ljibqjfx0c3cwnwcc7p31aq227-glibc-2.17-locales': No such file or directory

I’ve already tried to run ‘guix gc’, but it didn’t help.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: list-generations.diff --]
[-- Type: text/x-diff, Size: 7076 bytes --]

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 1393ca3..6e8171c 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -34,6 +34,7 @@
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
@@ -246,6 +247,127 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
              (switch-link)))
           (else (switch-link)))))                 ; anything else
 
+(define (string->generations str)
+  "Return a list of generations matching a pattern in STR.  This function
+accepts the following patterns: \"1\", \"1,2,3\", \"1..9\", \"1..\", \"..9\"."
+  (define (maybe-integer)
+    (let ((x (string->number str)))
+      (and (integer? x)
+           x)))
+
+  (define (maybe-comma-separated-integers)
+    (let ((lst (delete-duplicates
+                (map string->number
+                     (delete "" (string-split str #\,))))))
+      (and (every integer? lst)
+           lst)))
+
+  (cond ((maybe-integer)
+         =>
+         list)
+        ((maybe-comma-separated-integers)
+         =>
+         identity)
+        ((string-match "^([0-9]+)\\.\\.([0-9]+)$" str)
+         =>
+         (lambda (match)
+           (let ((s (string->number (match:substring match 1)))
+                 (e (string->number (match:substring match 2))))
+             (and (every integer? (list s e))
+                  (<= s e)
+                  (iota (1+ (- e s)) s)))))
+        ((string-match "^([0-9]+)\\.\\.$" str)
+         =>
+         (lambda (match)
+           (let ((s (string->number (match:substring match 1))))
+             (and (integer? s)
+                  `(>= ,s)))))
+        ((string-match "^\\.\\.([0-9]+)$" str)
+         =>
+         (lambda (match)
+           (let ((e (string->number (match:substring match 1))))
+             (and (integer? e)
+                  `(<= ,e)))))
+        (else #f)))
+
+(define (string->duration str)
+  "Return a duration matching a pattern in STR.  This function accepts the
+following patterns: \"1d\", \"1w\", \"1m\"."
+  (define (hours->duration hours match)
+    (make-time time-duration 0
+               (* 3600 hours (string->number (match:substring match 1)))))
+
+  (cond ((string-match "^([0-9]+)d$" str)
+         =>
+         (lambda (match)
+           (hours->duration 24 match)))
+        ((string-match "^([0-9]+)w$" str)
+         =>
+         (lambda (match)
+           (hours->duration (* 24 7) match)))
+        ((string-match "^([0-9]+)m$" str)
+         =>
+         (lambda (match)
+           (hours->duration (* 24 30) match)))
+        (else #f)))
+
+(define* (available-generations str #:optional (profile %current-profile))
+  "Return a list of available generations matching pattern in STR.  See
+'string->generations' and 'string->duration' for a list of valid patterns."
+  (define (valid-generations lst)
+    (define (valid-generation? n)
+      (any (cut = n <>) (generation-numbers profile)))
+
+    (fold-right (lambda (x acc)
+                  (if (valid-generation? x)
+                      (cons x acc)
+                      acc))
+                '()
+                lst))
+
+  (define (filter-generations generations)
+    (match generations
+      (() '())
+      (('>= n)
+       (drop-while (cut > n <>)
+                   (generation-numbers profile)))
+      (('<= n)
+       (valid-generations (iota n 1)))
+      ((lst ..1)
+       (valid-generations lst))
+      (_ #f)))
+
+  (define (filter-by-duration duration)
+    (define dates-generations
+      ;; Return an alist of dates and generations.
+      (map (lambda (x)
+             (cons (and=> (stat (format #f "~a-~a-link"
+                                        profile (number->string x)))
+                          stat:ctime)
+                   x))
+           (generation-numbers profile)))
+
+    (define dates
+      (fold-right (lambda (x acc)
+                    (cons (first x) acc))
+                  '()
+                  dates-generations))
+
+    (match duration
+      (#f #f)
+      (res
+       (let ((s (time-second (subtract-duration (current-time) duration))))
+         (map (cut assoc-ref dates-generations <>)
+              (filter (cut <= s <>) dates))))))
+
+  (cond ((string->generations str)
+         =>
+         filter-generations)
+        ((string->duration str)
+         =>
+         filter-by-duration)
+        (else #f)))
+
 (define (find-packages-by-description rx)
   "Search in SYNOPSIS and DESCRIPTION using RX.  Return a list of
 matching packages."
@@ -441,6 +563,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
       --roll-back        roll back to the previous generation"))
   (display (_ "
       --search-paths     display needed environment variable definitions"))
+  (display (_ "
+  -l  --list-generations[=REGEXP]
+                         list generations matching REGEXP"))
   (newline)
   (display (_ "
   -p, --profile=PROFILE  use PROFILE instead of the user's default profile"))
@@ -500,6 +625,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
         (option '("roll-back") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'roll-back? #t result)))
+        (option '(#\l "list-generations") #f #t
+                (lambda (opt name arg result)
+                  (cons `(query list-generations ,(or arg ""))
+                        result)))
         (option '("search-paths") #f #f
                 (lambda (opt name arg result)
                   (cons `(query search-paths) result)))
@@ -879,6 +1008,24 @@ more information.~%"))
     ;; actually processed, #f otherwise.
     (let ((profile  (assoc-ref opts 'profile)))
       (match (assoc-ref opts 'query)
+        (('list-generations regexp)
+         (define* (list-generation number)
+           (begin
+             (format #t "Generation ~a:~%" (number->string number))
+             (for-each (match-lambda
+                        ((name version output location _)
+                         (format #t "~a\t~a\t~a\t~a~%"
+                                 name version output location)))
+                       (manifest-packages
+                        (profile-manifest
+                         (format #f "~a-~a-link" profile number))))))
+
+         (let ((lst (if (string-null? regexp)
+                        (generation-numbers profile)
+                        (or (available-generations regexp profile)
+                            (leave (_ "invalid syntax: ~a~%") regexp)))))
+             (for-each list-generation lst)))
+
         (('list-installed regexp)
          (let* ((regexp    (and regexp (make-regexp regexp)))
                 (manifest  (profile-manifest profile))

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