pull: Add '--list-generations'.

* guix/scripts/pull.scm (show-help, %options): Add '--list-generations'.
(display-profile-content, process-query): New procedures.
(guix-pull): Honor '--list-generations'.

2 files changed, 144 insertions, 49 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index e734147681..4871bbcfe4 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2756,25 +2756,40 @@ export PATH="$HOME/.config/guix/current/bin:$PATH"
 export INFOPATH="$HOME/.config/guix/current/share/info:$INFOPATH"
 @end example
 
+The @code{--list-generations} or @code{-l} option lists past generations
+produced by @command{guix pull}, along with details about their provenance:
+
+@example
+$ guix pull -l
+Generation 1	Jun 10 2018 00:18:18
+  guix 65956ad
+    repository URL: https://git.savannah.gnu.org/git/guix.git
+    branch: origin/master
+    commit: 65956ad3526ba09e1f7a40722c96c6ef7c0936fe
+
+Generation 2	Jun 11 2018 11:02:49
+  guix e0cc7f6
+    repository URL: https://git.savannah.gnu.org/git/guix.git
+    branch: origin/master
+    commit: e0cc7f669bec22c37481dd03a7941c7d11a64f1d
+
+Generation 3	Jun 13 2018 23:31:07	(current)
+  guix 844cc1c
+    repository URL: https://git.savannah.gnu.org/git/guix.git
+    branch: origin/master
+    commit: 844cc1c8f394f03b404c5bb3aee086922373490c
+@end example
+
 This @code{~/.config/guix/current} profile works like any other profile
 created by @command{guix package} (@pxref{Invoking guix package}).  That
 is, you can list generations, roll back to the previous
 generation---i.e., the previous Guix---and so on:
 
 @example
-$ guix package -p ~/.config/guix/current -l
-Generation 1	May 25 2018 10:06:41
-  guix	221951a	out	/gnu/store/i4dfk7vw5k112s49jrhl6hwsfnh6wr7l-guix-221951af4
-
-Generation 2	May 27 2018 19:07:47
- + guix	2fbae00	out	/gnu/store/44cv9hyvxg34xf5kblf5dz57hc52y4bm-guix-2fbae006f
- - guix	221951a	out	/gnu/store/i4dfk7vw5k112s49jrhl6hwsfnh6wr7l-guix-221951af4
-
-Generation 3	May 30 2018 16:11:39	(current)
- + guix	a076f19	out	/gnu/store/332czkicwwg6lc3x4aqbw5q2mq12s7fj-guix-a076f1990
- - guix	2fbae00	out	/gnu/store/44cv9hyvxg34xf5kblf5dz57hc52y4bm-guix-2fbae006f
 $ guix package -p ~/.config/guix/current --roll-back
 switched from generation 3 to 2
+$ guix package -p ~/.config/guix/current --delete-generations=1
+deleting /home/charlie/.config/guix/current-1-link
 @end example
 
 The @command{guix pull} command is usually invoked with no arguments,
@@ -2800,6 +2815,13 @@ string.
 Deploy the tip of @var{branch}, the name of a Git branch available on
 the repository at @var{url}.
 
+@item --list-generations[=@var{pattern}]
+@itemx -l [@var{pattern}]
+List all the generations of @file{~/.config/guix/current} or, if @var{pattern}
+is provided, the subset of generations that match @var{pattern}.
+The syntax of @var{pattern} is the same as with @code{guix package
+--list-generations} (@pxref{Invoking guix package}).
+
 @item --bootstrap
 Use the bootstrap Guile to build the latest Guix.  This option is only
 useful to Guix developers.
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 499de0ec45..7202e3cc16 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -45,6 +45,7 @@
   #:use-module ((gnu packages certs) #:select (le-certs))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:export (guix-pull))
@@ -110,6 +111,9 @@ Download and deploy the latest version of Guix.\n"))
   (display (G_ "
       --branch=BRANCH    download the tip of the specified BRANCH"))
   (display (G_ "
+  -l, --list-generations[=PATTERN]
+                         list generations matching PATTERN"))
+  (display (G_ "
       --bootstrap        use the bootstrap Guile to build the new Guix"))
   (newline)
   (show-build-options-help)
@@ -125,6 +129,10 @@ Download and deploy the latest version of Guix.\n"))
   (cons* (option '("verbose") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'verbose? #t result)))
+         (option '(#\l "list-generations") #f #t
+                 (lambda (opt name arg result)
+                   (cons `(query list-generations ,(or arg ""))
+                         result)))
          (option '("url") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'repository-url arg
@@ -274,6 +282,66 @@ certificates~%"))
       (report-git-error err))))
 
 
+;;;
+;;; Queries.
+;;;
+
+(define (display-profile-content profile number)
+  "Display the packages in PROFILE, generation NUMBER, in a human-readable
+way and displaying details about the channel's source code."
+  (for-each (lambda (entry)
+              (format #t "  ~a ~a~%"
+                      (manifest-entry-name entry)
+                      (manifest-entry-version entry))
+              (match (assq 'source (manifest-entry-properties entry))
+                (('source ('repository ('version 0)
+                                       ('url url)
+                                       ('branch branch)
+                                       ('commit commit)
+                                       _ ...))
+                 (format #t (G_ "    repository URL: ~a~%") url)
+                 (when branch
+                   (format #t (G_ "    branch: ~a~%") branch))
+                 (format #t (G_ "    commit: ~a~%") commit))
+                (_ #f)))
+
+            ;; Show most recently installed packages last.
+            (reverse
+             (manifest-entries
+              (profile-manifest (generation-file-name profile number))))))
+
+(define (process-query opts)
+  "Process any query specified by OPTS."
+  (define profile
+    (string-append (config-directory) "/current"))
+
+  (match (assoc-ref opts 'query)
+    (('list-generations pattern)
+     (define (list-generation display-function number)
+       (unless (zero? number)
+         (display-generation profile number)
+         (display-function profile number)
+         (newline)))
+
+     (leave-on-EPIPE
+      (cond ((not (file-exists? profile))         ; XXX: race condition
+             (raise (condition (&profile-not-found-error
+                                (profile profile)))))
+            ((string-null? pattern)
+             (for-each (lambda (generation)
+                         (list-generation display-profile-content generation))
+                       (profile-generations profile)))
+            ((matching-generations pattern profile)
+             =>
+             (match-lambda
+               (()
+                (exit 1))
+               ((numbers ...)
+                (for-each (lambda (generation)
+                            (list-generation display-profile-content generation))
+                          numbers)))))))))
+
+
 (define (guix-pull . args)
   (define (use-le-certs? url)
     (string-prefix? "https://git.savannah.gnu.org/" url))
@@ -287,43 +355,48 @@ certificates~%"))
             (cache (string-append (cache-directory) "/pull")))
        (ensure-guile-git!)
 
-       (unless (assoc-ref opts 'dry-run?)         ;XXX: not very useful
-         (with-store store
-           (parameterize ((%graft? (assoc-ref opts 'graft?)))
-             (set-build-options-from-command-line store opts)
-
-             ;; For reproducibility, always refer to the LE certificates when we
-             ;; know we're talking to Savannah.
-             (when (use-le-certs? url)
-               (honor-lets-encrypt-certificates! store))
-
-             (format (current-error-port)
-                     (G_ "Updating from Git repository at '~a'...~%")
-                     url)
-
-             (let-values (((checkout commit)
-                           (latest-repository-commit store url
-                                                     #:ref ref
-                                                     #:cache-directory cache)))
-
-               (format (current-error-port)
-                       (G_ "Building from Git commit ~a...~%")
-                       commit)
-               (parameterize ((%guile-for-build
-                               (package-derivation
-                                store
-                                (if (assoc-ref opts 'bootstrap?)
-                                    %bootstrap-guile
-                                    (canonical-package guile-2.2)))))
-                 (run-with-store store
-                   (build-and-install checkout (config-directory)
-                                      #:url url
-                                      #:branch (match ref
-                                                 (('branch . branch)
-                                                  branch)
-                                                 (_ #f))
-                                      #:commit commit
-                                      #:verbose?
-                                      (assoc-ref opts 'verbose?))))))))))))
+       (cond ((assoc-ref opts 'query)
+              (process-query opts))
+             ((assoc-ref opts 'dry-run?)
+              #t)                                 ;XXX: not very useful
+             (else
+              (with-store store
+                (parameterize ((%graft? (assoc-ref opts 'graft?)))
+                  (set-build-options-from-command-line store opts)
+
+                  ;; For reproducibility, always refer to the LE certificates
+                  ;; when we know we're talking to Savannah.
+                  (when (use-le-certs? url)
+                    (honor-lets-encrypt-certificates! store))
+
+                  (format (current-error-port)
+                          (G_ "Updating from Git repository at '~a'...~%")
+                          url)
+
+                  (let-values (((checkout commit)
+                                (latest-repository-commit store url
+                                                          #:ref ref
+                                                          #:cache-directory
+                                                          cache)))
+
+                    (format (current-error-port)
+                            (G_ "Building from Git commit ~a...~%")
+                            commit)
+                    (parameterize ((%guile-for-build
+                                    (package-derivation
+                                     store
+                                     (if (assoc-ref opts 'bootstrap?)
+                                         %bootstrap-guile
+                                         (canonical-package guile-2.2)))))
+                      (run-with-store store
+                        (build-and-install checkout (config-directory)
+                                           #:url url
+                                           #:branch (match ref
+                                                      (('branch . branch)
+                                                       branch)
+                                                      (_ #f))
+                                           #:commit commit
+                                           #:verbose?
+                                           (assoc-ref opts 'verbose?)))))))))))))
 
 ;;; pull.scm ends here