+\f
+;;;
+;;; 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."
+ ;; 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))
+ (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
+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.")))
+
+(define (sexp->system-provenance sexp)
+ "Parse SEXP, an s-expression read from /run/current-system/provenance or
+similar, and return two values: the list of channels listed therein, and the
+OS configuration file or #f."
+ (match sexp
+ (('provenance ('version 0)
+ ('channels channels ...)
+ ('configuration-file config-file))
+ (values (map sexp->channel channels)
+ config-file))
+ (_
+ (values '() #f))))
+
+(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 ()
+ (sexp->system-provenance
+ (call-with-input-file (string-append system "/provenance")
+ read)))
+ (lambda _
+ (values '() #f))))
+\f
+;;;
+;;; Cleanup.
+;;;
+