summaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-11-30 18:05:07 +0100
committerLudovic Courtès <ludo@gnu.org>2019-12-07 00:59:56 +0100
commit33b7cb7a595aa33051648039d417338110e5a45e (patch)
tree8df25d15565b5180b4bc17af7d9eeeb3101c3d10 /gnu
parent362bcdb1b076c8c46f71781add56dfbe532736dc (diff)
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'.
Diffstat (limited to 'gnu')
-rw-r--r--gnu/services.scm87
-rw-r--r--gnu/system.scm10
2 files changed, 97 insertions, 0 deletions
diff --git a/gnu/services.scm b/gnu/services.scm
index 394470ba7d..e7a3a95e43 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 96c2b5aad3..abdbb081e6 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.