01/05: services: Add 'system-provenance' procedure.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit b91a73a6a4a419ffd53c41916d8acf3232b10eea
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Jul 14 15:50:38 2020 +0200

    services: Add 'system-provenance' procedure.
    
    * gnu/services.scm (sexp->channel, system-provenance): New procedures.
    * guix/scripts/system.scm (sexp->channel): Remove.
    (display-system-generation): Use 'system-provenance' instead of parsing
    the "provenance" file right here.
---
 gnu/services.scm        | 32 ++++++++++++++++++++++++++++++++
 guix/scripts/system.scm | 49 ++++++++++++++-----------------------------------
 2 files changed, 46 insertions(+), 35 deletions(-)

diff --git a/gnu/services.scm b/gnu/services.scm
index f6dc56d..6509a90 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -89,6 +89,7 @@
 
             system-service-type
             provenance-service-type
+            system-provenance
             boot-service-type
             cleanup-service-type
             activation-service-type
@@ -423,6 +424,19 @@ be parsed by tools; it's potentially more future-proof 
than code."
             (branch ,(channel-branch channel))
             (commit ,(channel-commit channel))))
 
+(define (sexp->channel sexp)
+  "Return the channel corresponding to SEXP, an sexp as found in the
+\"provenance\" file produced by 'provenance-service-type'."
+  (match sexp
+    (('channel ('name name)
+               ('url url)
+               ('branch branch)
+               ('commit commit)
+               rest ...)
+     ;; XXX: In the future REST may include a channel introduction.
+     (channel (name name) (url url)
+              (branch branch) (commit commit)))))
+
 (define (provenance-file channels config-file)
   "Return a 'provenance' file describing CHANNELS, a list of channels, and
 CONFIG-FILE, which can be either #f or a <local-file> containing the OS
@@ -474,6 +488,24 @@ channels in use and CONFIG-FILE, if it is true."
 itself: the channels used when building the system, and its configuration
 file, when available.")))
 
+(define (system-provenance system)
+  "Given SYSTEM, the file name of a system generation, return two values: the
+list of channels SYSTEM is built from, and its configuration file.  If that
+information is missing, return the empty list (for channels) and possibly
+#false (for the configuration file)."
+  (catch 'system-error
+    (lambda ()
+      (match (call-with-input-file (string-append system "/provenance")
+               read)
+        (('provenance ('version 0)
+                      ('channels channels ...)
+                      ('configuration-file config-file))
+         (values (map sexp->channel channels)
+                 config-file))
+        (_
+         (values '() #f))))
+    (lambda _
+      (values '() #f))))
 
 ;;;
 ;;; Cleanup.
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 61eeec6..f2b4367 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -446,19 +446,6 @@ list of services."
 ;;; Generations.
 ;;;
 
-(define (sexp->channel sexp)
-  "Return the channel corresponding to SEXP, an sexp as found in the
-\"provenance\" file produced by 'provenance-service-type'."
-  (match sexp
-    (('channel ('name name)
-               ('url url)
-               ('branch branch)
-               ('commit commit)
-               rest ...)
-     ;; XXX: In the future REST may include a channel introduction.
-     (channel (name name) (url url)
-              (branch branch) (commit commit)))))
-
 (define* (display-system-generation number
                                     #:optional (profile %system-profile))
   "Display a summary of system generation NUMBER in a human-readable format."
@@ -482,13 +469,10 @@ list of services."
                             (uuid->string root)
                             root))
            (kernel      (boot-parameters-kernel params))
-           (multiboot-modules (boot-parameters-multiboot-modules params))
-           (provenance  (catch 'system-error
-                          (lambda ()
-                            (call-with-input-file
-                                (string-append generation "/provenance")
-                              read))
-                          (const #f))))
+           (multiboot-modules (boot-parameters-multiboot-modules params)))
+      (define-values (channels config-file)
+        (system-provenance generation))
+
       (display-generation profile number)
       (format #t (G_ "  file name: ~a~%") generation)
       (format #t (G_ "  canonical file name: ~a~%") (readlink* generation))
@@ -518,21 +502,16 @@ list of services."
          (format #t (G_ "  multiboot: ~a~%")
                  (string-join modules "\n    "))))
 
-      (match provenance
-        (#f #t)
-        (('provenance ('version 0)
-                      ('channels channels ...)
-                      ('configuration-file config-file))
-         (unless (null? channels)
-           ;; TRANSLATORS: Here "channel" is the same terminology as used in
-           ;; "guix describe" and "guix pull --channels".
-           (format #t (G_ "  channels:~%"))
-           (for-each display-channel (map sexp->channel channels)))
-         (when config-file
-           (format #t (G_ "  configuration file: ~a~%")
-                   (if (supports-hyperlinks?)
-                       (file-hyperlink config-file)
-                       config-file))))))))
+      (unless (null? channels)
+        ;; TRANSLATORS: Here "channel" is the same terminology as used in
+        ;; "guix describe" and "guix pull --channels".
+        (format #t (G_ "  channels:~%"))
+        (for-each display-channel channels))
+      (when config-file
+        (format #t (G_ "  configuration file: ~a~%")
+                (if (supports-hyperlinks?)
+                    (file-hyperlink config-file)
+                    config-file))))))
 
 (define* (list-generations pattern #:optional (profile %system-profile))
   "Display in a human-readable format all the system generations matching