PRELIMINARY: [PATCH] guix package: Add '--list-generations'.

[Nikita Karetnikov <nikita@karetnikov.org>]

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

> I think it’s reasonable to have a first milestone without recutils
> output.

OK.

> Not sure what you mean by “two record sets”.

“You can have two record sets: one for generations, one for
packages.” [1]

> I see two use cases: one where you just want human-friendly output, for
> when one is glancing at the available generations, and one that is more
> amenable to Unix pipelines for post-processing.  Recutils output is for
> the latter case.

Right.

>> I still think that someone may benefit from the recutils format.  So
>> let’s allow the ‘recutils’ argument that would list all generations in
>> that format [1] and use the following format [2] for everything else:
>>
>>   generation 1     Dec 16 2013
>>     guile    2.0.7 out,debug    gnu/packages/guile.scm
>>     hello    2.8   out          gnu/packages/base.scm
>>
>>   generation 2     May 7 2013
>>     guile    2.0.9 out          gnu/packages/guile.scm
>>
>> Is it OK?

> Yes.

>> Should it point to the store instead of (gnu packages …)?

> Yes, I think so.

Done.

>> Why do you suggest to put ‘string->duration’ into (guix ui)?

> Because it’s a user-interface function.

Done.  However, I think it would be better to write more generic
procedures if we want to place them in separate modules, so they can be
reused.  (I can replace the current version with a more generic one if
you want.)

>> I installed Nix 1.5.3. and ran the command:
>>
>> error: setting synchronous mode: unable to open database file

> Problem with permissions on the SQLite database, I guess.

I “fixed” it by deleting the store and reinstalling Guix.

I’m attaching the patch.  Please don’t push it yet.  I’ve just found a
bug.  On my machine, ‘guix package -p test -l 2d’ and ‘guix package -p
test -l’ should return the same set of generations, but the fourth
generation is shown twice in the former case.

Other issues:

1. ‘false-if-exception’ in ‘generation-ctime’.

2. A race condition (marked with XXX).

3. ‘guix package -l -p test’ returns ‘guix package: error: test:
   extraneous argument’.  (However, the same happens with ‘-I’.)

4. There must be a better way to write the test in
   ‘tests/guix-package.sh’.

[1] https://lists.gnu.org/archive/html/guix-devel/2013-08/msg00173.html


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

From 27e73d3d86ca7abfbc470f3561c059d730314821 Mon Sep 17 00:00:00 2001
From: Nikita Karetnikov <nikita@karetnikov.org>
Date: Tue, 17 Sep 2013 23:56:10 +0000
Subject: [PATCH] guix package: Add '--list-generations'.

* guix/scripts/package.scm: Import (srfi srfi-19).
  (generation-ctime, matching-generations): New functions.
  (show-help): Add '--list-generations'.
  (%options): Likewise.
  (guix-package)[process-query]: Add support for '--list-generations'.
* guix/ui.scm: Import (srfi srfi-19) and (ice-9 regex).
  (string->generations, string->duration): New functions.
* tests/guix-package.sh: Test '--list-generations'.
* tests/ui.scm: Import (srfi srfi-19).
  Test 'string->generations' and 'string->duration'.
* doc/guix.texi (Invoking guix-package): Document '--list-generations'.
---
 doc/guix.texi            |   36 +++++++++++++++++
 guix/scripts/package.scm |  100 ++++++++++++++++++++++++++++++++++++++++++++++
 guix/ui.scm              |   68 +++++++++++++++++++++++++++++++
 tests/guix-package.sh    |    4 ++
 tests/ui.scm             |   85 +++++++++++++++++++++++++++++++++++++++
 5 files changed, 293 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 5d1b780..ebf80b4 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -606,6 +606,42 @@ library are installed in the profile, then @code{--search-paths} will
 suggest setting these variables to @code{@var{profile}/include} and
 @code{@var{profile}/lib}, respectively.
 
+@item --list-generations[=@var{regexp}]
+@itemx -l [@var{regexp}]
+Return a list of generations along with their creation dates.
+
+For each installed package, print the following items, separated by
+tabs: the name of a package, its version string, the part of the package
+that is installed (@pxref{Packages with Multiple Outputs}), and the
+location of this package in the store.
+
+When @var{regexp} is used, the command returns only matching
+generations.  Valid patterns include:
+
+@itemize
+@item @emph{Integers and comma-separated integers}.  Both patterns will simply
+return the corresponding generations.  For instance,
+@code{--list-generations=1} will return the first one.
+
+If you pass @code{--list-generations=1,8,2}, the command will return
+three generations in the specified order.  Neither spaces nor trailing
+commas are allowed.
+
+@item @emph{Ranges}.  @code{--list-generations=2..9} will print the
+specified generations and everything in between.  Note that the
+start of a range must be lesser than its end.
+
+It is also possible to omit the endpoint.  For example,
+@code{--list-generations=2..}, will output all generations starting from
+the second one.
+
+@item @emph{Durations}.  You can also get the last @emph{N}@tie{}days, weeks,
+or months by passing an integer along with the first letter of the
+duration, e.g., @code{--list-generations=20d}.
+
+@end itemize
+
+
 @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 1393ca3..0d3cc05 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,66 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
              (switch-link)))
           (else (switch-link)))))                 ; anything else
 
+(define (generation-ctime profile number)
+  "Return the creation date of a generation or #f if it does not exist."
+  (false-if-exception
+   (stat:ctime (stat (format #f "~a-~a-link" profile number)))))
+
+(define* (matching-generations str #:optional (profile %current-profile))
+  "Return the list of available generations matching a pattern in STR.  See
+'string->generations' and 'string->duration' for the 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 the alist of dates and generations.
+      (map (lambda (number)
+             (cons (generation-ctime profile number)
+                   number))
+           (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 +502,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 +564,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 +947,38 @@ 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\t~a~%" number
+                     (date->string
+                      (time-utc->date
+                       (make-time time-utc 0
+                                  (generation-ctime profile number)))
+                      "~b ~d ~Y"))
+             (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))))
+             (newline)))
+
+         (cond ((not (file-exists? profile)) ; XXX: race condition
+                (leave (_ "profile '~a' does not exist~%")
+                       profile))
+               ((string-null? regexp)
+                (for-each list-generation
+                          (generation-numbers profile)))
+               ((matching-generations regexp profile)
+                =>
+                (cut for-each list-generation <>))
+               (else
+                (leave (_ "invalid syntax: ~a~%")
+                       regexp)))
+         #t)
+
         (('list-installed regexp)
          (let* ((regexp    (and regexp (make-regexp regexp)))
                 (manifest  (profile-manifest profile))
diff --git a/guix/ui.scm b/guix/ui.scm
index 720d01b..a3289b4 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -28,12 +28,14 @@
   #:use-module ((guix licenses) #:select (license? license-name))
   #: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)
   #:autoload   (ice-9 ftw)  (scandir)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 regex)
   #:export (_
             N_
             leave
@@ -50,6 +52,8 @@
             fill-paragraph
             string->recutils
             package->recutils
+            string->generations
+            string->duration
             args-fold*
             run-guix-command
             program-name
@@ -404,6 +408,70 @@ WIDTH columns."
           (and=> (package-description p) description->recutils))
   (newline port))
 
+(define (string->generations str)
+  "Return the 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
+                     (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 the 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 (args-fold* options unrecognized-option-proc operand-proc . seeds)
   "A wrapper on top of `args-fold' that does proper user-facing error
 reporting."
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index ee186ea..f8596fa 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -81,6 +81,10 @@ then
         "name: hello"
     test "`guix package -s "n0t4r341p4ck4g3"`" = ""
 
+    # List generations.
+    test "`guix package -p "$profile" -l | cut -f1 | grep guile | head -n1`" \
+        = "  guile-bootstrap"
+
     # Remove a package.
     guix package --bootstrap -p "$profile" -r "guile-bootstrap"
     test -L "$profile-3-link"
diff --git a/tests/ui.scm b/tests/ui.scm
index 0b6f3c5..adba9f9 100644
--- a/tests/ui.scm
+++ b/tests/ui.scm
@@ -20,6 +20,7 @@
 (define-module (test-ui)
   #:use-module (guix ui)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-64))
 
 ;; Test the (guix ui) module.
@@ -64,6 +65,90 @@ interface, and powerful string processing.")
                    10)
    #\newline))
 
+(test-equal "integer"
+  '(1)
+  (string->generations "1"))
+
+(test-equal "comma-separated integers"
+  '(3 7 1 4 6)
+  (string->generations "3,7,1,4,6"))
+
+(test-equal "closed range"
+  '(4 5 6 7 8 9 10 11 12)
+  (string->generations "4..12"))
+
+(test-equal "closed range, equal endpoints"
+  '(3)
+  (string->generations "3..3"))
+
+(test-equal "infinite end range"
+  '(>= 7)
+  (string->generations "7.."))
+
+(test-equal "infinite start range"
+  '(<= 42)
+  (string->generations "..42"))
+
+(test-equal "integer, char"
+  #f
+  (string->generations "a"))
+
+(test-equal "comma-separated integers, consecutive comma"
+  #f
+  (string->generations "1,,2"))
+
+(test-equal "comma-separated integers, trailing comma"
+  #f
+  (string->generations "1,2,"))
+
+(test-equal "comma-separated integers, chars"
+  #f
+  (string->generations "a,b"))
+
+(test-equal "closed range, start > end"
+  #f
+  (string->generations "9..2"))
+
+(test-equal "closed range, chars"
+  #f
+  (string->generations "a..b"))
+
+(test-equal "infinite end range, char"
+  #f
+  (string->generations "a.."))
+
+(test-equal "infinite start range, char"
+  #f
+  (string->generations "..a"))
+
+(test-equal "duration, 1 day"
+  (make-time time-duration 0 (* 3600 24))
+  (string->duration "1d"))
+
+(test-equal "duration, 1 week"
+  (make-time time-duration 0 (* 3600 24 7))
+  (string->duration "1w"))
+
+(test-equal "duration, 1 month"
+  (make-time time-duration 0 (* 3600 24 30))
+  (string->duration "1m"))
+
+(test-equal "duration, 1 week == 7 days"
+  (string->duration "1w")
+  (string->duration "7d"))
+
+(test-equal "duration, 1 month == 30 days"
+  (string->duration "1m")
+  (string->duration "30d"))
+
+(test-equal "duration, integer"
+  #f
+  (string->duration "1"))
+
+(test-equal "duration, char"
+  #f
+  (string->duration "d"))
+
 (test-end "ui")
 
 \f
-- 
1.7.9.5


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