[bug#45919] [PATCH 8/8] guix package: Add '--export-channels'.

[Ludovic Courtès]

* guix/channels.scm (sexp->channel): Export.
* guix/describe.scm: Use (guix channels).
(manifest-entry-provenance): New procedure.
* guix/scripts/package.scm (channel=?, export-channels): New
procedures.
(show-help, %options): Add '--export-channels'.
(process-query): Honor it.
* build-aux/build-self.scm (build-program)[select?]: Exclude (guix
channels) to account for the (guix describe) change above.
* doc/guix.texi (Invoking guix package): Document it.
---
 build-aux/build-self.scm |  3 ++
 doc/guix.texi            | 24 ++++++++++++++++
 guix/channels.scm        |  1 +
 guix/describe.scm        | 34 ++++++++++++++++++++--
 guix/scripts/package.scm | 61 ++++++++++++++++++++++++++++++++++++++++
 5 files changed, 121 insertions(+), 2 deletions(-)

diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index 4b6e2bfae5..d5bc5fb46e 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -245,8 +245,11 @@ interface (FFI) of Guile.")
   "Return a program that computes the derivation to build Guix from SOURCE."
   (define select?
     ;; Select every module but (guix config) and non-Guix modules.
+    ;; Also exclude (guix channels): it is autoloaded by (guix describe), but
+    ;; only for peripheral functionality.
     (match-lambda
       (('guix 'config) #f)
+      (('guix 'channels) #f)
       (('guix _ ...)   #t)
       (('gnu _ ...)    #t)
       (_               #f)))
diff --git a/doc/guix.texi b/doc/guix.texi
index e524464e9f..cfb2f8a296 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3591,7 +3591,31 @@ exactly what you specified.
 
 Keep in mind that a manifest is purely symbolic: it only contains
 package names and possibly versions, and their meaning varies over time.
+If you wish to ``pin'' channels to the revisions that were used to build
+the profile(s), see @option{--export-channels} below.
 
+@cindex pinning, channel revisions of a profile
+@item --export-channels
+Write to standard output the list of channels used by the chosen
+profile(s), in a format suitable for @command{guix pull --channels} or
+@command{guix time-machine --channels} (@pxref{Channels}).
+
+Together with @option{--export-manifest}, this option provides
+information allowing you to replicate the current profile
+(@pxref{Replicating Guix}).
+
+However, note that the output of this command @emph{approximates} what
+was actually used to build this profile.  In particular, a single
+profile might have been built from several different revisions of the
+same channel.  In that case, @option{--export-manifest} chooses the last
+one and writes the list of other revisions in a comment.  If you really
+need to pick packages from different channel revisions, you can use
+inferiors in your manifest to do so (@pxref{Inferiors}).
+
+Together with @option{--export-manifest}, this is a good starting point
+if you are willing to migrate from the ``imperative'' model to the fully
+declarative model consisting of a manifest file along with a channels
+file pinning the exact channel revision(s) you want.
 @end table
 
 Finally, since @command{guix package} may actually start build
diff --git a/guix/channels.scm b/guix/channels.scm
index cdef77637d..e7e1eb6fd0 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -92,6 +92,7 @@
 
             profile-channels
             manifest-entry-channel
+            sexp->channel
             channel->code
 
             channel-news-entry?
diff --git a/guix/describe.scm b/guix/describe.scm
index 05bf99eb58..ac89fc0d7c 100644
--- a/guix/describe.scm
+++ b/guix/describe.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,6 +23,7 @@
   #:use-module ((guix utils) #:select (location-file))
   #:use-module ((guix store) #:select (%store-prefix store-path?))
   #:use-module ((guix config) #:select (%state-directory))
+  #:autoload   (guix channels) (sexp->channel)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:export (current-profile
@@ -31,7 +32,8 @@
             package-path-entries
 
             package-provenance
-            manifest-entry-with-provenance))
+            manifest-entry-with-provenance
+            manifest-entry-provenance))
 
 ;;; Commentary:
 ;;;
@@ -166,3 +168,31 @@ there."
                (#f   properties)
                (sexp `((provenance ,@sexp)
                        ,@properties)))))))))
+
+(define (manifest-entry-provenance entry)
+  "Return the list of channels ENTRY comes from.  Return the empty list if
+that information is missing."
+  (match (assq-ref (manifest-entry-properties entry) 'provenance)
+    ((main extras ...)
+     ;; XXX: Until recently, channel sexps lacked the channel name.  For
+     ;; entries created by 'manifest-entry-with-provenance', the first sexp
+     ;; is known to be the 'guix channel, and for the other ones, invent a
+     ;; fallback name (it's OK as the name is just a "pet name").
+     (match (sexp->channel main 'guix)
+       (#f '())
+       (channel
+        (let loop ((extras   extras)
+                   (counter  1)
+                   (channels (list channel)))
+          (match extras
+            (()
+             (reverse channels))
+            ((head . tail)
+             (let* ((name  (string->symbol
+                            (format #f "channel~a" counter)))
+                    (extra (sexp->channel head name)))
+               (if extra
+                   (loop tail (+ 1 counter) (cons extra channels))
+                   (loop tail counter channels)))))))))
+    (_
+     '())))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 2b52016c67..8234a1703d 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -43,6 +43,7 @@
   #:use-module (guix scripts build)
   #:use-module (guix transformations)
   #:use-module (guix describe)
+  #:autoload   (guix channels) (channel-name channel-commit channel->code)
   #:autoload   (guix store roots) (gc-roots user-owned?)
   #:use-module ((guix build utils)
                 #:select (directory-exists? mkdir-p))
@@ -363,6 +364,54 @@ Alternately, see @command{guix package --search-paths -p 
~s}.")
                  (pretty-print exp port))
                exp))))
 
+(define (channel=? a b)
+  (and (channel-commit a) (channel-commit b)
+       (string=? (channel-commit a) (channel-commit b))))
+
+(define* (export-channels manifest
+                          #:optional (port (current-output-port)))
+  (define channels
+    (delete-duplicates
+     (append-map manifest-entry-provenance (manifest-entries manifest))
+     channel=?))
+
+  (define channel-names
+    (delete-duplicates (map channel-name channels)))
+
+  (define table
+    (fold (lambda (channel table)
+            (vhash-consq (channel-name channel) channel table))
+          vlist-null
+          channels))
+
+  (when (null? channels)
+    (leave (G_ "no provenance information for this profile~%")))
+
+  (format port (G_ "\
+;; This channel file can be passed to 'guix pull -C' or to
+;; 'guix time-machine -C' to obtain the Guix revision that was
+;; used to populate this profile.\n"))
+  (newline port)
+  (display "(list\n" port)
+  (for-each (lambda (name)
+              (define indent "     ")
+              (match (vhash-foldq* cons '() name table)
+                ((channel extra ...)
+                 (unless (null? extra)
+                   (display indent port)
+                   (format port (G_ "\
+;; Note: these other commits were also used to install \
+some of the packages in this profile:~%"))
+                   (for-each (lambda (channel)
+                               (format port "~a;;   ~s~%"
+                                       indent (channel-commit channel)))
+                             extra))
+                 (pretty-print (channel->code channel) port
+                               #:per-line-prefix indent))))
+            channel-names)
+  (display ")\n" port)
+  #t)
+
 
 ;;;
 ;;; Command-line options.
@@ -418,6 +467,8 @@ Install, remove, or upgrade packages in a single 
transaction.\n"))
                          switch to a generation matching PATTERN"))
   (display (G_ "
       --export-manifest  print a manifest for the chosen profile"))
+  (display (G_ "
+      --export-channels  print channels for the chosen profile"))
   (display (G_ "
   -p, --profile=PROFILE  use PROFILE instead of the user's default profile"))
   (display (G_ "
@@ -556,6 +607,10 @@ kind of search path~%")
                  (lambda (opt name arg result arg-handler)
                    (values (cons `(query export-manifest) result)
                            #f)))
+         (option '("export-channels") #f #f
+                 (lambda (opt name arg result arg-handler)
+                   (values (cons `(query export-channels) result)
+                           #f)))
          (option '(#\p "profile") #t #f
                  (lambda (opt name arg result arg-handler)
                    (values (alist-cons 'profile (canonicalize-profile arg)
@@ -882,6 +937,12 @@ processed, #f otherwise."
          (export-manifest manifest (current-output-port))
          #t))
 
+      (('export-channels)
+       (let ((manifest (concatenate-manifests
+                        (map profile-manifest profiles))))
+         (export-channels manifest (current-output-port))
+         #t))
+
       (_ #f))))
 
 
-- 
2.30.0