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.
This commit is contained in:
parent
0a72157271
commit
b91a73a6a4
@ -89,6 +89,7 @@
|
|||||||
|
|
||||||
system-service-type
|
system-service-type
|
||||||
provenance-service-type
|
provenance-service-type
|
||||||
|
system-provenance
|
||||||
boot-service-type
|
boot-service-type
|
||||||
cleanup-service-type
|
cleanup-service-type
|
||||||
activation-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))
|
(branch ,(channel-branch channel))
|
||||||
(commit ,(channel-commit 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)
|
(define (provenance-file channels config-file)
|
||||||
"Return a 'provenance' file describing CHANNELS, a list of channels, and
|
"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
|
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
|
itself: the channels used when building the system, and its configuration
|
||||||
file, when available.")))
|
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.
|
;;; Cleanup.
|
||||||
|
@ -446,19 +446,6 @@ list of services."
|
|||||||
;;; Generations.
|
;;; 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
|
(define* (display-system-generation number
|
||||||
#:optional (profile %system-profile))
|
#:optional (profile %system-profile))
|
||||||
"Display a summary of system generation NUMBER in a human-readable format."
|
"Display a summary of system generation NUMBER in a human-readable format."
|
||||||
@ -482,13 +469,10 @@ list of services."
|
|||||||
(uuid->string root)
|
(uuid->string root)
|
||||||
root))
|
root))
|
||||||
(kernel (boot-parameters-kernel params))
|
(kernel (boot-parameters-kernel params))
|
||||||
(multiboot-modules (boot-parameters-multiboot-modules params))
|
(multiboot-modules (boot-parameters-multiboot-modules params)))
|
||||||
(provenance (catch 'system-error
|
(define-values (channels config-file)
|
||||||
(lambda ()
|
(system-provenance generation))
|
||||||
(call-with-input-file
|
|
||||||
(string-append generation "/provenance")
|
|
||||||
read))
|
|
||||||
(const #f))))
|
|
||||||
(display-generation profile number)
|
(display-generation profile number)
|
||||||
(format #t (G_ " file name: ~a~%") generation)
|
(format #t (G_ " file name: ~a~%") generation)
|
||||||
(format #t (G_ " canonical file name: ~a~%") (readlink* generation))
|
(format #t (G_ " canonical file name: ~a~%") (readlink* generation))
|
||||||
@ -518,21 +502,16 @@ list of services."
|
|||||||
(format #t (G_ " multiboot: ~a~%")
|
(format #t (G_ " multiboot: ~a~%")
|
||||||
(string-join modules "\n "))))
|
(string-join modules "\n "))))
|
||||||
|
|
||||||
(match provenance
|
(unless (null? channels)
|
||||||
(#f #t)
|
;; TRANSLATORS: Here "channel" is the same terminology as used in
|
||||||
(('provenance ('version 0)
|
;; "guix describe" and "guix pull --channels".
|
||||||
('channels channels ...)
|
(format #t (G_ " channels:~%"))
|
||||||
('configuration-file config-file))
|
(for-each display-channel channels))
|
||||||
(unless (null? channels)
|
(when config-file
|
||||||
;; TRANSLATORS: Here "channel" is the same terminology as used in
|
(format #t (G_ " configuration file: ~a~%")
|
||||||
;; "guix describe" and "guix pull --channels".
|
(if (supports-hyperlinks?)
|
||||||
(format #t (G_ " channels:~%"))
|
(file-hyperlink config-file)
|
||||||
(for-each display-channel (map sexp->channel channels)))
|
config-file))))))
|
||||||
(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))
|
(define* (list-generations pattern #:optional (profile %system-profile))
|
||||||
"Display in a human-readable format all the system generations matching
|
"Display in a human-readable format all the system generations matching
|
||||||
|
Loading…
Reference in New Issue
Block a user