From eb5cf39e66a51eb357ca0c08f4409d00ec3b24a9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 25 Jun 2020 17:54:55 +0200 Subject: services: provenance: Save channel introductions. * gnu/services.scm (channel->code): Include CHANNEL's introduction, if any, unless CHANNEL is the singleton %DEFAULT-CHANNELS. (channel->sexp): Add comment. * guix/scripts/system.scm (sexp->channel): Change pattern to allow for extensibility. --- gnu/services.scm | 26 ++++++++++++++++++++++---- 1 file changed, 22 insertions(+), 4 deletions(-) (limited to 'gnu/services.scm') diff --git a/gnu/services.scm b/gnu/services.scm index 27e55582310..f6dc56d9405 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -31,6 +31,7 @@ #:use-module (guix sets) #:use-module (guix ui) #:use-module ((guix utils) #:select (source-properties->location)) + #:autoload (guix openpgp) (openpgp-format-fingerprint) #:use-module (guix modules) #:use-module (gnu packages base) #:use-module (gnu packages bash) @@ -392,14 +393,31 @@ by the initrd once the root file system is mounted."))) (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)))) + ;; Since the 'introduction' field is backward-incompatible, and since it's + ;; optional when using the "official" 'guix channel, include it if and only + ;; if we're referring to a different channel. + (let ((intro (and (not (equal? (list channel) %default-channels)) + (channel-introduction channel)))) + `(channel (name ',(channel-name channel)) + (url ,(channel-url channel)) + (branch ,(channel-branch channel)) + (commit ,(channel-commit channel)) + ,@(if intro + `((introduction + (make-channel-introduction + ,(channel-introduction-first-signed-commit intro) + (openpgp-fingerprint + ,(openpgp-format-fingerprint + (channel-introduction-first-commit-signer + intro)))))) + '())))) (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." + ;; TODO: Add CHANNEL's introduction. Currently we can't do that because + ;; older 'guix system describe' expect exactly name/url/branch/commit + ;; without any additional fields. `(channel (name ,(channel-name channel)) (url ,(channel-url channel)) (branch ,(channel-branch channel)) -- cgit v1.3 From b91a73a6a4a419ffd53c41916d8acf3232b10eea Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 14 Jul 2020 15:50:38 +0200 Subject: 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(-) (limited to 'gnu/services.scm') diff --git a/gnu/services.scm b/gnu/services.scm index f6dc56d9405..6509a9014e4 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 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 61eeec622bc..f2b43670941 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 -- cgit v1.3