X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/378daa8cb677121e1893f9173af1db060720d6e4..24297a9a9cc36de88ed2a6d30ba2ed9acc34407b:/gnu/services.scm diff --git a/gnu/services.scm b/gnu/services.scm index 49cf01a4f8..27e5558231 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 Ludovic Courtès +;;; 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. ;;; @@ -25,12 +26,15 @@ #:use-module (guix profiles) #:use-module (guix discovery) #:use-module (guix combinators) + #:use-module (guix channels) + #:use-module (guix describe) #:use-module (guix sets) #:use-module (guix ui) #:use-module ((guix utils) #:select (source-properties->location)) #: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) @@ -39,6 +43,7 @@ #:use-module (srfi srfi-35) #:use-module (ice-9 vlist) #:use-module (ice-9 match) + #:autoload (ice-9 pretty-print) (pretty-print) #:export (service-extension service-extension? service-extension-target @@ -82,11 +87,14 @@ ambiguous-target-service-error-target-type system-service-type + provenance-service-type 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 @@ -314,11 +322,11 @@ 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 (sequence %store-monad mextensions))) + (mlet %store-monad ((extensions (mapm/accumulate-builds identity + mextensions))) (lower-object (file-union "system" (append entries (concatenate extensions)))))) @@ -370,6 +378,89 @@ by the initrd once the root file system is mounted."))) ;; The service that produces the boot script. (service boot-service-type #t)) + +;;; +;;; 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." + `(channel (name ',(channel-name channel)) + (url ,(channel-url channel)) + (branch ,(channel-branch channel)) + (commit ,(channel-commit channel)))) + +(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." + `(channel (name ,(channel-name channel)) + (url ,(channel-url channel)) + (branch ,(channel-branch channel)) + (commit ,(channel-commit channel)))) + +(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 +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."))) + + +;;; +;;; Cleanup. +;;; + (define (cleanup-gexp _) "Return a gexp to clean up /tmp and similar places upon boot." (with-imported-modules '((guix build utils)) @@ -430,34 +521,34 @@ ACTIVATION-SCRIPT-TYPE." (define (activation-script gexps) "Return the system's activation script, which evaluates GEXPS." (define actions - (map (cut scheme-file "activate-service" <>) gexps)) - - (scheme-file "activate" - (with-imported-modules (source-module-closure - '((gnu build activation) - (guix build utils))) - #~(begin - (use-modules (gnu build activation) - (guix build utils)) - - ;; Make sure the user accounting database exists. If it - ;; does not exist, 'setutxent' does not create it and - ;; thus there is no accounting at all. - (close-port (open-file "/var/run/utmpx" "a0")) - - ;; Same for 'wtmp', which is populated by mingetty et - ;; al. - (mkdir-p "/var/log") - (close-port (open-file "/var/log/wtmp" "a0")) - - ;; Set up /run/current-system. Among other things this - ;; sets up locales, which the activation snippets - ;; executed below may expect. - (activate-current-system) - - ;; Run the services' activation snippets. - ;; TODO: Use 'load-compiled'. - (for-each primitive-load '#$actions))))) + (map (cut program-file "activate-service.scm" <>) gexps)) + + (program-file "activate.scm" + (with-imported-modules (source-module-closure + '((gnu build activation) + (guix build utils))) + #~(begin + (use-modules (gnu build activation) + (guix build utils)) + + ;; Make sure the user accounting database exists. If it + ;; does not exist, 'setutxent' does not create it and + ;; thus there is no accounting at all. + (close-port (open-file "/var/run/utmpx" "a0")) + + ;; Same for 'wtmp', which is populated by mingetty et + ;; al. + (mkdir-p "/var/log") + (close-port (open-file "/var/log/wtmp" "a0")) + + ;; Set up /run/current-system. Among other things this + ;; sets up locales, which the activation snippets + ;; executed below may expect. + (activate-current-system) + + ;; Run the services' activation snippets. + ;; TODO: Use 'load-compiled'. + (for-each primitive-load '#$actions))))) (define (gexps->activation-gexp gexps) "Return a gexp that runs the activation script containing GEXPS." @@ -492,6 +583,10 @@ ACTIVATION-SCRIPT-TYPE." #~(begin (setenv "LINUX_MODULE_DIRECTORY" "/run/booted-system/kernel/lib/modules") + ;; FIXME: Remove this crutch when the patch #40422, + ;; updating to kmod 27 is merged. + (setenv "MODPROBE_OPTIONS" + "-C /etc/modprobe.d") (apply execl #$modprobe (cons #$modprobe (cdr (command-line)))))))) @@ -512,6 +607,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. @@ -540,6 +668,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) @@ -582,10 +727,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., @@ -649,7 +794,8 @@ as Wifi cards."))) (extend append) (description "Register garbage-collector roots---i.e., store items that -will not be reclaimed by the garbage collector."))) +will not be reclaimed by the garbage collector.") + (default-value '()))) ;;; @@ -732,13 +878,23 @@ instantiated; other missing services lead to a instances (service-type-extensions (service-kind svc)))) - (let ((instances (fold (lambda (service result) - (vhash-consq (service-kind service) service - result)) - vlist-null services))) - (fold2 adjust-service-list - services instances - services))) + (let loop ((services services)) + (define instances + (fold (lambda (service result) + (vhash-consq (service-kind service) service + result)) + vlist-null services)) + + (define adjusted + (fold2 adjust-service-list + services instances + services)) + + ;; If we instantiated services, they might in turn depend on missing + ;; services. Loop until we've reached fixed point. + (if (= (length adjusted) (vlist-length instances)) + adjusted + (loop adjusted)))) (define* (fold-services services #:key (target-type system-service-type)) @@ -764,18 +920,34 @@ TARGET-TYPE; return the root service adjusted accordingly." (eq? (service-kind service) target-type)) services) ((sink) - (let loop ((sink sink)) - (let* ((dependents (map loop (dependents sink))) - (extensions (map (apply-extension sink) dependents)) - (extend (service-type-extend (service-kind sink))) - (compose (service-type-compose (service-kind sink))) - (params (service-value sink))) - ;; We distinguish COMPOSE and EXTEND because PARAMS typically has a - ;; different type than the elements of EXTENSIONS. - (if extend - (service (service-kind sink) - (extend params (compose extensions))) - sink)))) + ;; Use the state monad to keep track of already-visited services in the + ;; graph and to memoize their value once folded. + (run-with-state + (let loop ((sink sink)) + (mlet %state-monad ((visited (current-state))) + (match (vhash-assq sink visited) + (#f + (mlet* %state-monad + ((dependents (mapm %state-monad loop (dependents sink))) + (visited (current-state)) + (extensions -> (map (apply-extension sink) dependents)) + (extend -> (service-type-extend (service-kind sink))) + (compose -> (service-type-compose (service-kind sink))) + (params -> (service-value sink)) + (service + -> + ;; Distinguish COMPOSE and EXTEND because PARAMS typically + ;; has a different type than the elements of EXTENSIONS. + (if extend + (service (service-kind sink) + (extend params (compose extensions))) + sink))) + (mbegin %state-monad + (set-current-state (vhash-consq sink service visited)) + (return service)))) + ((_ . service) ;SINK was already visited + (return service))))) + vlist-null)) (() (raise (condition (&missing-target-service-error