<
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework@protonmail.com>
;;; Copyright © 2020 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;; Copyright © 2020, 2021 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2022 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2023 Brian Cully <bjc@spork.org>
;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu services)
#:use-module (guix gexp)
#:use-module (guix monads)
#:use-module (guix store)
#:use-module (guix records)
#: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 diagnostics)
#:autoload (guix openpgp) (openpgp-format-fingerprint)
#:use-module (guix modules)
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (guix deprecation)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#:use-module (gnu packages hurd)
#:use-module (gnu packages linux)
#:use-module (gnu system privilege)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-71)
#: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
service-extension-compute
service-type
service-type?
service-type-name
service-type-extensions
service-type-compose
service-type-extend
service-type-default-value
service-type-description
service-type-location
%service-type-path
fold-service-types
lookup-service-types
service
service?
service-kind
service-value
service-parameters ;deprecated
simple-service
modify-services
service-back-edges
instantiate-missing-services
fold-services
remove-service-extensions
for-home
for-home?
validate-service-list
service-error?
missing-value-service-error?
missing-value-service-error-type
missing-value-service-error-location
missing-target-service-error?
missing-target-service-error-service
missing-target-service-error-target-type
ambiguous-target-service-error?
ambiguous-target-service-error-service
ambiguous-target-service-error-target-type
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
etc-directory
privileged-program-service-type
setuid-program-service-type ; deprecated
profile-service-type
firmware-service-type
gc-root-service-type
linux-builder-service-type
linux-builder-configuration
linux-builder-configuration?
linux-builder-configuration-kernel
linux-builder-configuration-modules
linux-loadable-module-service-type
%boot-service
%activation-service
etc-service) ; deprecated
#:re-export (;; Note: Re-export 'delete' to allow for proper syntax matching
;; in 'modify-services' forms. See
;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26805#16>.
delete))
;;; Comment:
;;;
;;; This module defines a broad notion of "service types" and "services."
;;;
;;; A service type describe how its instances extend instances of other
;;; service types. For instance, some services extend the instance of
;;; ACCOUNT-SERVICE-TYPE by providing it with accounts and groups to create;
;;; others extend SHEPHERD-ROOT-SERVICE-TYPE by passing it instances of
;;; <shepherd-service>.
;;;
;;; When applicable, the service type defines how it can itself be extended,
;;; by providing one procedure to compose extensions, and one procedure to
;;; extend itself.
;;;
;;; A notable service type is SYSTEM-SERVICE-TYPE, which has a single
;;; instance, which is the root of the service DAG. Its value is the
;;; derivation that produces the 'system' directory as returned by
;;; 'operating-system-derivation'.
;;;
;;; The 'fold-services' procedure can be passed a list of procedures, which it
;;; "folds" by propagating extensions down the graph; it returns the root
;;; service after the applying all its extensions.
;;;
;;; Code:
(define-record-type <service-extension>
(service-extension target compute)
service-extension?
(target service-extension-target) ;<service-type>
(compute service-extension-compute)) ;params -> params
(define &no-default-value
;; Value used to denote service types that have no associated default value.
'(no default value))
(define-record-type* <service-type> service-type make-service-type
service-type?
(name service-type-name) ;symbol (for debugging)
;; Things extended by services of this type.
(extensions service-type-extensions) ;list of <service-extensions>
;; Given a list of extensions, "compose" them.
(compose service-type-compose ;list of Any -> Any
(default #f))
;; Extend the services' own parameters with the extension composition.
(extend service-type-extend ;list of Any -> parameters
(default #f))
;; Optional default value for instances of this type.
(default-value service-type-default-value ;Any
(default &no-default-value))
;; Meta-data.
(description service-type-description) ;string
(location service-type-location ;<location>
(default (and=> (current-source-location)
source-properties->location))
(innate)))
(define (write-service-type type port)
(format port "#<service-type ~a ~a>"
(service-type-name type)
(number->string (object-address type) 16)))
(set-record-type-printer! <service-type> write-service-type)
(define %distro-root-directory
;; Absolute file name of the module hierarchy.
(dirname (search-path %load-path "guix.scm")))
(define %service-type-path
;; Search path for service types.
(make-parameter `((,%distro-root-directory . "gnu/services")
(,%distro-root-directory . "gnu/system"))))
(define (all-service-modules)
"Return the default set of service modules."
(cons (resolve-interface '(gnu services))
(all-modules (%service-type-path)
#:warn warn-about-load-error)))
(define* (fold-service-types proc seed
#:optional
(modules (all-service-modules)))
"For each service type exported by one of MODULES, call (PROC RESULT). SEED
is used as the initial value of RESULT."
(fold-module-public-variables (lambda (object result)
(if (service-type? object)
(proc object result)
result))
seed
modules))
(define lookup-service-types
(let ((table
(delay (fold-service-types (lambda (type result)
(vhash-consq (service-type-name type)
type result))
vlist-null))))
(lambda (name)
"Return the list of services with the given NAME (a symbol)."
(vhash-foldq* cons '() name (force table)))))
;; Services of a given type.
(define-record-type <service>
(make-service type value)
service?
(type service-kind)
(value service-value))
(define-syntax service
(syntax-rules ()
"Return a service instance of TYPE. The service value is VALUE or, if
omitted, TYPE's default value."
((_ type value)
(make-service type value))
((_ type)
(%service-with-default-value (current-source-location)
type))))
(define (%service-with-default-value location type)
"Return a instance of service type TYPE with its default value, if any. If
TYPE does not have a default value, an error is raised."
;; TODO: Currently this is a run-time error but with a little bit macrology
;; we could turn it into an expansion-time error.
(let ((default (service-type-default-value type)))
(if (eq? default &no-default-value)
(let ((location (source-properties->location location)))
(raise
(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)))))
(service type default))))
(define-condition-type &service-error &error
service-error?)
(define-condition-type &missing-value-service-error &service-error
missing-value-service-error?
(type missing-value-service-error-type)
(location missing-value-service-error-location))
;;;
;;; Helpers.
;;;
(define service-parameters
;; Deprecated alias.
service-value)
(define (simple-service name target value)
"Return a service that extends TARGET with VALUE. This works by creating a
singleton service type NAME, of which the returned service is an instance."
(let* ((extension (service-extension target identity))
(type (service-type (name name)
(extensions (list extension))
(description "This is a simple service."))))
(service type value)))
(define-syntax clause-alist
(syntax-rules (=> delete)
"Build an alist of clauses. Each element has the form (KIND PROC LOC)
where PROC is the service transformation procedure to apply for KIND, and LOC
is the source location information."
((_ (delete kind) rest ...)
(cons (list kind
(lambda (service)
#f)
(current-source-location))
(clause-alist rest ...)))
((_ (kind param => exp ...) rest ...)
(cons (list kind
(lambda (svc)
(let ((param (service-value svc)))
(service (service-kind svc)
(begin exp ...))))
(current-source-location))
(clause-alist rest ...)))
((_)
'())))
(define (apply-clauses clauses service deleted-services)
"Apply CLAUSES, an alist as returned by 'clause-alist', to SERVICE. An
exception is raised if a clause attempts to modify a service
present in DELETED-SERVICES."
(define (raise-if-deleted kind properties)
(match (find (match-lambda
((deleted-kind _)
(eq? kind deleted-kind)))
deleted-services)
((_ deleted-properties)
(raise (make-compound-condition
(condition
(&error-location
(location (source-properties->location properties))))
(formatted-message
(G_ "modify-services: service '~a' was deleted here: ~a")
(service-type-name kind)
(source-properties->location deleted-properties)))))
(_ #t)))
(match clauses
(((kind proc properties) . rest)
(raise-if-deleted kind properties)
(if (eq? (and service (service-kind service)) kind)
(let ((new-service (proc service)))
(apply-clauses rest new-service
(if new-service
deleted-services
(cons (list kind properties)
deleted-services))))
(apply-clauses rest service deleted-services)))
(()
service)))
(define (%modify-services services clauses)
"Apply CLAUSES, an alist as returned by 'clause-alist', to SERVICES. An
exception is raised if a clause attempts to modify a missing service."
(define (raise-if-not-found clause)
(match clause
((kind _ properties)
(unless (find (lambda (service)
(eq? kind (service-kind service)))
services)
(raise (make-compound-condition
(condition
(&error-location
(location (source-properties->location properties))))
(formatted-message
(G_ "modify-services: service '~a' not found in service list")
(service-type-name kind))))))))
(for-each raise-if-not-found clauses)
(reverse (filter-map identity
(fold (lambda (service services)
(cons (apply-clauses clauses service '())
services))
'()
services))))
(define-syntax modify-services
(syntax-rules ()
"Modify the services listed in SERVICES according to CLAUSES and return
the resulting list of services. Each clause must have the form:
(TYPE VARIABLE => BODY)
where TYPE is a service type, such as 'guix-service-type', and VARIABLE is an
identifier that is bound within BODY to the value of the service of that
TYPE.
Clauses can also remove services of a given type:
(delete TYPE)
Consider this example:
(modify-services %base-services
(guix-service-type config =>
(guix-configuration
(inherit config)
(use-substitutes? #f)
(extra-options '(\"--gc-keep-derivations\"))))
(mingetty-service-type config =>
(mingetty-configuration
(inherit config)
(motd (plain-file \"motd\" \"Hi there!\"))))
(delete udev-service-type))
It changes the configuration of the GUIX-SERVICE-TYPE instance, and that of
all the MINGETTY-SERVICE-TYPE instances, and it deletes instances of the
UDEV-SERVICE-TYPE."
((_ services clauses ...)
(%modify-services services (clause-alist clauses ...)))))
;;;
;;; Core services.
;;;
(define (system-derivation entries mextensions)
"Return as a monadic value the derivation of the 'system' directory
containing the given entries."
(mlet %store-monad ((extensions (mapm/accumulate-builds identity
mextensions)))
(lower-object
(file-union "system"
(append entries (concatenate extensions))))))
(define system-service-type
;; This is the ultimate service type, the root of the service DAG. The
;; service of this type is extended by monadic name/item pairs. These items
;; end up in the "system directory" as returned by
;; 'operating-system-derivation'.
(service-type (name 'system)
(extensions '())
(compose identity)
(extend system-derivation)
(description
"Build the operating system top-level directory, which in
turn refers to everything the operating system needs: its kernel, initrd,
system profile, boot script, and so on.")))
(define (compute-boot-script _ gexps)
;; Reverse GEXPS so that extensions appear in the boot script in the right
;; order. That is, user extensions would come first, and extensions added
;; by 'essential-services' (e.g., running shepherd) are guaranteed to come
;; last.
(gexp->file "boot"
;; Clean up and activate the system, then spawn shepherd.
#~(begin #$@(reverse gexps))))
(define (boot-script-entry mboot)
"Return, as a monadic value, an entry for the boot script in the system
directory."
(mlet %store-monad ((boot mboot))
(return `(("boot" ,boot)))))
(define boot-service-type
;; The service of this type is extended by being passed gexps. It
;; aggregates them in a single script, as a monadic value, which becomes its
;; value.
(service-type (name 'boot)
(extensions
(list (service-extension system-service-type
boot-script-entry)))
(compose identity)
(extend compute-boot-script)
(default-value #f)
(description
"Produce the operating system's boot script, which is spawned
by the initrd once the root file system is mounted.")))
(define %boot-service
;; 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."
;; 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))
(ur
