;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix describe)
#:use-module (guix sets)
#:use-module (guix ui)
- #:use-module ((guix utils) #:select (source-properties->location))
+ #:use-module (guix diagnostics)
+ #:autoload (guix openpgp) (openpgp-format-fingerprint)
#:use-module (guix modules)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
+ #:use-module (gnu packages hurd)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
system-service-type
provenance-service-type
+ sexp->system-provenance
+ system-provenance
boot-service-type
cleanup-service-type
activation-service-type
activation-service->script
%linux-bare-metal-service
+ %hurd-rc-script
+ %hurd-startup-service
special-files-service-type
extra-special-file
etc-service-type
(if (eq? default &no-default-value)
(let ((location (source-properties->location location)))
(raise
- (condition
- (&missing-value-service-error (type type) (location location))
- (&message
- (message (format #f (G_ "~a: no value specified \
+ (make-compound-condition
+ (condition
+ (&missing-value-service-error (type type) (location location)))
+ (formatted-message (G_ "~a: no value specified \
for service of type '~a'")
- (location->string location)
- (service-type-name type)))))))
+ (location->string location)
+ (service-type-name type)))))
(service type default))))
(define-condition-type &service-error &error
;;; Core services.
;;;
-(define (system-derivation mentries mextensions)
+(define (system-derivation entries mextensions)
"Return as a monadic value the derivation of the 'system' directory
containing the given entries."
- (mlet %store-monad ((entries mentries)
- (extensions (mapm/accumulate-builds identity
+ (mlet %store-monad ((extensions (mapm/accumulate-builds identity
mextensions)))
(lower-object
(file-union "system"
(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))
(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
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.
activation-service-type
%linux-kernel-activation))
+(define %hurd-rc-script
+ ;; The RC script to be started upon boot.
+ (program-file "rc"
+ (with-imported-modules (source-module-closure
+ '((guix build utils)
+ (gnu build hurd-boot)
+ (guix build syscalls)))
+ #~(begin
+ (use-modules (guix build utils)
+ (gnu build hurd-boot)
+ (guix build syscalls)
+ (ice-9 match)
+ (system repl repl)
+ (srfi srfi-1)
+ (srfi srfi-26))
+ (boot-hurd-system)))))
+
+(define (hurd-rc-entry rc)
+ "Return, as a monadic value, an entry for the RC script in the system
+directory."
+ (mlet %store-monad ((rc (lower-object rc)))
+ (return `(("rc" ,rc)))))
+
+(define hurd-startup-service-type
+ ;; The service that creates the initial SYSTEM/rc startup file.
+ (service-type (name 'startup)
+ (extensions
+ (list (service-extension system-service-type hurd-rc-entry)))
+ (default-value %hurd-rc-script)))
+
+(define %hurd-startup-service
+ ;; The service that produces the RC script.
+ (service hurd-startup-service-type %hurd-rc-script))
(define special-files-service-type
;; Service to install "special files" such as /bin/sh and /usr/bin/env.
(() #t)
(((file _) rest ...)
(when (set-contains? seen file)
- (raise (condition
- (&message
- (message (format #f (G_ "duplicate '~a' entry for /etc")
- file))))))
+ (raise (formatted-message (G_ "duplicate '~a' entry for /etc")
+ file)))
(loop rest (set-insert file seen))))))
;; Detect duplicates early instead of letting them through, eventually
(define (packages->profile-entry packages)
"Return a system entry for the profile containing PACKAGES."
- (mlet %store-monad ((profile (profile-derivation
- (packages->manifest
- (delete-duplicates packages eq?)))))
- (return `(("profile" ,profile)))))
+ (with-monad %store-monad
+ (return `(("profile" ,(profile
+ (content (packages->manifest
+ (delete-duplicates packages eq?)))))))))
(define profile-service-type
;; The service that populates the system's profile---i.e.,
vlist-null))
(()
(raise
- (condition (&missing-target-service-error
- (service #f)
- (target-type target-type))
- (&message
- (message (format #f (G_ "service of type '~a' not found")
- (service-type-name target-type)))))))
+ (make-compound-condition
+ (condition (&missing-target-service-error
+ (service #f)
+ (target-type target-type)))
+ (formatted-message (G_ "service of type '~a' not found")
+ (service-type-name target-type)))))
(x
(raise
(condition (&ambiguous-target-service-error