04/09: services: Add 'provenance-service-type'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 33b7cb7a595aa33051648039d417338110e5a45e
Author: Ludovic Courtès <address@hidden>
Date:   Sat Nov 30 18:05:07 2019 +0100

    services: Add 'provenance-service-type'.
    
    * gnu/services.scm (object->pretty-string)
    (channel->code, channel->sexp, provenance-file)
    (provenance-entry): New procedures.
    (provenance-service-type): New variable.
    * gnu/system.scm (operating-system-with-provenance): New procedure.
    * doc/guix.texi (Service Reference): Document 'provenance-service-type'.
---
 doc/guix.texi    | 44 ++++++++++++++++++++++++++++
 gnu/services.scm | 87 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 gnu/system.scm   | 10 +++++++
 3 files changed, 141 insertions(+)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7d50f31..33ee81b 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -27043,6 +27043,50 @@ programs under @file{/run/current-system/profile}.  
Other services can
 extend it by passing it lists of packages to add to the system profile.
 @end defvr
 
+@cindex provenance tracking, of the operating system
+@defvr {Scheme Variable} provenance-service-type
+This is the type of the service that records @dfn{provenance meta-data}
+in the system itself.  It creates several files under
+@file{/run/current-system}:
+
+@table @file
+@item channels.scm
+This is a ``channel file'' that can be passed to @command{guix pull -C}
+or @command{guix time-machine -C}, and which describes the channels used
+to build the system, if that information was available
+(@pxref{Channels}).
+
+@item configuration.scm
+This is the file that was passed as the value for this
+@code{provenance-service-type} service.  By default, @command{guix
+system reconfigure} automatically passes the OS configuration file it
+received on the command line.
+
+@item provenance
+This contains the same information as the two other files but in a
+format that is more readily processable.
+@end table
+
+In general, these two pieces of information (channels and configuration
+file) are enough to reproduce the operating system ``from source''.
+
+@quotation Caveats
+This information is necessary to rebuild your operating system, but it
+is not always sufficient.  In particular, @file{configuration.scm}
+itself is insufficient if it is not self-contained---if it refers to
+external Guile modules or to extra files.  If you want
+@file{configuration.scm} to be self-contained, we recommend that modules
+or files it refers to be part of a channel.
+
+Besides, provenance meta-data is ``silent'' in the sense that it does
+not change the bits contained in your system, @emph{except for the
+meta-data bits themselves}.  Two different OS configurations or sets of
+channels can lead to the same system, bit-for-bit; when
+@code{provenance-service-type} is used, these two systems will have
+different meta-data and thus different store file names, which makes
+comparison less trivial.
+@end quotation
+@end defvr
 
 @node Shepherd Services
 @subsection Shepherd Services
diff --git a/gnu/services.scm b/gnu/services.scm
index 394470b..e7a3a95 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -25,6 +25,8 @@
   #:use-module (guix profiles)
   #:use-module (guix discovery)
   #:use-module (guix combinators)
+  #:use-module (guix channels)
+  #:use-module (guix describe)
   #:use-module (guix sets)
   #:use-module (guix ui)
   #:use-module ((guix utils) #:select (source-properties->location))
@@ -39,6 +41,7 @@
   #:use-module (srfi srfi-35)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
+  #:autoload   (ice-9 pretty-print) (pretty-print)
   #:export (service-extension
             service-extension?
             service-extension-target
@@ -82,6 +85,7 @@
             ambiguous-target-service-error-target-type
 
             system-service-type
+            provenance-service-type
             boot-service-type
             cleanup-service-type
             activation-service-type
@@ -370,6 +374,89 @@ by the initrd once the root file system is mounted.")))
   ;; The service that produces the boot script.
   (service boot-service-type #t))
 
+
+;;;
+;;; Provenance tracking.
+;;;
+
+(define (object->pretty-string obj)
+  "Like 'object->string', but using 'pretty-print'."
+  (call-with-output-string
+    (lambda (port)
+      (pretty-print obj port))))
+
+(define (channel->code channel)
+  "Return code to build CHANNEL, ready to be dropped in a 'channels.scm'
+file."
+  `(channel (name ',(channel-name channel))
+            (url ,(channel-url channel))
+            (branch ,(channel-branch channel))
+            (commit ,(channel-commit channel))))
+
+(define (channel->sexp channel)
+  "Return an sexp describing CHANNEL.  The sexp is _not_ code and is meant to
+be parsed by tools; it's potentially more future-proof than code."
+  `(channel (name ,(channel-name channel))
+            (url ,(channel-url channel))
+            (branch ,(channel-branch channel))
+            (commit ,(channel-commit channel))))
+
+(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
+configuration being used."
+  (scheme-file "provenance"
+               #~(provenance
+                  (version 0)
+                  (channels #+@(if channels
+                                   (map channel->sexp channels)
+                                   '()))
+                  (configuration-file #+config-file))))
+
+(define (provenance-entry config-file)
+  "Return system entries describing the operating system provenance: the
+channels in use and CONFIG-FILE, if it is true."
+  (define profile
+    (current-profile))
+
+  (define channels
+    (and=> profile profile-channels))
+
+  (mbegin %store-monad
+    (let ((config-file (cond ((string? config-file)
+                              (local-file config-file "configuration.scm"))
+                             ((not config-file)
+                              #f)
+                             (else
+                              config-file))))
+      (return `(("provenance" ,(provenance-file channels config-file))
+                ,@(if channels
+                      `(("channels.scm"
+                         ,(plain-file "channels.scm"
+                                      (object->pretty-string
+                                       `(list
+                                         ,@(map channel->code channels))))))
+                      '())
+                ,@(if config-file
+                      `(("configuration.scm" ,config-file))
+                      '()))))))
+
+(define provenance-service-type
+  (service-type (name 'provenance)
+                (extensions
+                 (list (service-extension system-service-type
+                                          provenance-entry)))
+                (default-value #f)                ;the OS config file
+                (description
+                 "Store provenance information about the system in the system
+itself: the channels used when building the system, and its configuration
+file, when available.")))
+
+
+;;;
+;;; Cleanup.
+;;;
+
 (define (cleanup-gexp _)
   "Return a gexp to clean up /tmp and similar places upon boot."
   (with-imported-modules '((guix build utils))
diff --git a/gnu/system.scm b/gnu/system.scm
index 96c2b5a..abdbb08 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -110,6 +110,7 @@
 
             system-linux-image-file-name
             operating-system-with-gc-roots
+            operating-system-with-provenance
 
             boot-parameters
             boot-parameters?
@@ -540,6 +541,15 @@ bookkeeping."
                                     gc-root-service-type roots)
                     (operating-system-user-services os)))))
 
+(define* (operating-system-with-provenance os #:optional config-file)
+  "Return a variant of OS that stores its own provenance information,
+including CONFIG-FILE, if available.  This is achieved by adding an instance
+of PROVENANCE-SERVICE-TYPE to its services."
+  (operating-system
+    (inherit os)
+    (services (cons (service provenance-service-type config-file)
+                    (operating-system-user-services os)))))
+
 
 ;;;
 ;;; /etc.