X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/27783023993f9272ce422868d14529159c4a5218..252a1926bc7d7aa0b39d89a484c0c1b82e945fcd:/gnu/services.scm diff --git a/gnu/services.scm b/gnu/services.scm index 832d6984d8..6509a9014e 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2016 Chris Marusich +;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,9 +31,11 @@ #: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) + #:use-module (gnu packages hurd) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) @@ -86,11 +89,14 @@ system-service-type provenance-service-type + 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 @@ -318,11 +324,10 @@ This is a shorthand for (map (lambda (svc) ...) %base-services)." ;;; 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" @@ -389,19 +394,49 @@ 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)) (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 @@ -453,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. @@ -604,6 +657,39 @@ ACTIVATION-SCRIPT-TYPE." 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. @@ -632,6 +718,23 @@ and FILE could be \"/usr/bin/env\"." (files->etc-directory (service-value service))) (define (files->etc-directory files) + (define (assert-no-duplicates files) + (let loop ((files files) + (seen (set))) + (match files + (() #t) + (((file _) rest ...) + (when (set-contains? seen file) + (raise (condition + (&message + (message (format #f (G_ "duplicate '~a' entry for /etc") + file)))))) + (loop rest (set-insert file seen)))))) + + ;; Detect duplicates early instead of letting them through, eventually + ;; leading to a build failure of "etc.drv". + (assert-no-duplicates files) + (file-union "etc" files)) (define (etc-entry files) @@ -674,10 +777,10 @@ executables, making them setuid-root."))) (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.,