X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/154d97abdd16674fdebc763351f661bbcdc869a4..8f929fdf0b82b591878d277a57e54288026180e9:/gnu/services.scm diff --git a/gnu/services.scm b/gnu/services.scm index 394470ba7d..2e4648bf78 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2016 Chris Marusich ;;; ;;; This file is part of GNU Guix. @@ -25,6 +25,8 @@ #: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)) @@ -39,6 +41,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,6 +85,7 @@ ambiguous-target-service-error-target-type system-service-type + provenance-service-type boot-service-type cleanup-service-type activation-service-type @@ -314,11 +318,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 +374,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)) @@ -492,6 +579,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)))))))) @@ -540,6 +631,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 +690,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.,