projects/guix·blob master · refs

1496 lines · 60.0 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2015-2024, 2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2016 Chris Marusich <[email protected]>
4;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <[email protected]>
5;;; Copyright © 2020, 2021 Ricardo Wurmus <[email protected]>
6;;; Copyright © 2021 raid5atemyhomework <[email protected]>
7;;; Copyright © 2020 Christine Lemmer-Webber <[email protected]>
8;;; Copyright © 2020, 2021 Brice Waegeneire <[email protected]>
9;;; Copyright © 2022 Tobias Geerinckx-Rice <[email protected]>
10;;; Copyright © 2023 Brian Cully <[email protected]>
11;;; Copyright © 2024 Nicolas Graves <[email protected]>
12;;; Copyright © 2025 Maxim Cournoyer <[email protected]>
13;;;
14;;; This file is part of GNU Guix.
15;;;
16;;; GNU Guix is free software; you can redistribute it and/or modify it
17;;; under the terms of the GNU General Public License as published by
18;;; the Free Software Foundation; either version 3 of the License, or (at
19;;; your option) any later version.
20;;;
21;;; GNU Guix is distributed in the hope that it will be useful, but
22;;; WITHOUT ANY WARRANTY; without even the implied warranty of
23;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24;;; GNU General Public License for more details.
25;;;
26;;; You should have received a copy of the GNU General Public License
27;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
28
29;;; Commentary:
30;;;
31;;; This module defines a broad notion of "service types" and "services."
32;;;
33;;; A service type describe how its instances extend instances of other
34;;; service types. For instance, some services extend the instance of
35;;; ACCOUNT-SERVICE-TYPE by providing it with accounts and groups to create;
36;;; others extend SHEPHERD-ROOT-SERVICE-TYPE by passing it instances of
37;;; <shepherd-service>.
38;;;
39;;; When applicable, the service type defines how it can itself be extended,
40;;; by providing one procedure to compose extensions, and one procedure to
41;;; extend itself.
42;;;
43;;; A notable service type is SYSTEM-SERVICE-TYPE, which has a single
44;;; instance, which is the root of the service DAG. Its value is the
45;;; derivation that produces the 'system' directory as returned by
46;;; 'operating-system-derivation'.
47;;;
48;;; The 'fold-services' procedure can be passed a list of procedures, which it
49;;; "folds" by propagating extensions down the graph; it returns the root
50;;; service after the applying all its extensions.
51;;;
52;;; Code:
53
54(define-module (gnu services)
55 #:use-module (guix derivations)
56 #:use-module (guix gexp)
57 #:use-module (guix monads)
58 #:use-module (guix store)
59 #:use-module (guix records)
60 #:use-module (guix profiles)
61 #:use-module (guix discovery)
62 #:use-module (guix combinators)
63 #:use-module (guix channels)
64 #:use-module (guix describe)
65 #:use-module (guix sets)
66 #:use-module (guix ui)
67 #:use-module (guix diagnostics)
68 #:autoload (guix openpgp) (openpgp-format-fingerprint)
69 #:use-module (guix modules)
70 #:use-module (guix packages)
71 #:use-module (guix utils)
72 #:use-module (guix deprecation)
73 #:use-module (gnu packages base)
74 #:use-module (gnu packages bash)
75 #:use-module (gnu packages gnome)
76 #:use-module (gnu packages hurd)
77 #:use-module (gnu packages linux)
78 #:use-module (gnu system privilege)
79 #:use-module (srfi srfi-1)
80 #:use-module (srfi srfi-9)
81 #:use-module (srfi srfi-9 gnu)
82 #:use-module (srfi srfi-26)
83 #:use-module (srfi srfi-34)
84 #:use-module (srfi srfi-35)
85 #:use-module (srfi srfi-71)
86 #:use-module (ice-9 vlist)
87 #:use-module (ice-9 match)
88 #:autoload (ice-9 pretty-print) (pretty-print)
89 #:export (service-extension
90 service-extension?
91 service-extension-target
92 service-extension-compute
93
94 service-type
95 service-type?
96 service-type-name
97 service-type-extensions
98 service-type-compose
99 service-type-extend
100 service-type-default-value
101 service-type-description
102 service-type-location
103
104 %service-type-path
105 fold-service-types
106 lookup-service-types
107
108 service
109 service?
110 service-kind
111 service-value
112 service-parameters ;deprecated
113
114 simple-service
115 modify-services
116 service-back-edges
117 instantiate-missing-services
118 fold-services
119
120 remove-service-extensions
121 for-home
122 for-home?
123
124 validate-service-list
125
126 service-error?
127 missing-value-service-error?
128 missing-value-service-error-type
129 missing-value-service-error-location
130 missing-target-service-error?
131 missing-target-service-error-service
132 missing-target-service-error-target-type
133 ambiguous-target-service-error?
134 ambiguous-target-service-error-service
135 ambiguous-target-service-error-target-type
136
137 system-service-type
138 provenance-service-type
139 sexp->system-provenance
140 system-provenance
141 boot-service-type
142 cleanup-service-type
143 activation-service-type
144 activation-service->script
145 %linux-bare-metal-service
146 %hurd-rc-script
147 %hurd-startup-service
148 special-files-service-type
149 extra-special-file
150 etc-service-type
151 etc-profile-d-service-type
152 etc-bashrc-d-service-type
153 %default-etc-bashrc-d-files
154 %default-bash-aliases
155 etc-directory
156 privileged-program-service-type
157 setuid-program-service-type ; deprecated
158 profile-service-type
159 firmware-service-type
160 gc-root-service-type
161 linux-builder-service-type
162 linux-builder-configuration
163 linux-builder-configuration?
164 linux-builder-configuration-kernel
165 linux-builder-configuration-modules
166 linux-loadable-module-service-type
167 vte-integration-service-type
168
169 %boot-service
170 %activation-service
171 etc-service) ; deprecated
172 #:re-export (;; Note: Re-export 'delete' to allow for proper syntax matching
173 ;; in 'modify-services' forms. See
174 ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26805#16>.
175 delete))
176
177(define-record-type <service-extension>
178 (service-extension target compute)
179 service-extension?
180 (target service-extension-target) ;<service-type>
181 (compute service-extension-compute)) ;params -> params
182
183(define &no-default-value
184 ;; Value used to denote service types that have no associated default value.
185 '(no default value))
186
187(define-record-type* <service-type> service-type make-service-type
188 service-type?
189 (name service-type-name) ;symbol (for debugging)
190
191 ;; Things extended by services of this type.
192 (extensions service-type-extensions) ;list of <service-extensions>
193
194 ;; Given a list of extensions, "compose" them.
195 (compose service-type-compose ;list of Any -> Any
196 (default #f))
197
198 ;; Extend the services' own parameters with the extension composition.
199 (extend service-type-extend ;list of Any -> parameters
200 (default #f))
201
202 ;; Optional default value for instances of this type.
203 (default-value service-type-default-value ;Any
204 (default &no-default-value))
205
206 ;; Meta-data.
207 (description service-type-description) ;string
208 (location service-type-location ;<location>
209 (default (and=> (current-source-location)
210 source-properties->location))
211 (innate)))
212
213(define (write-service-type type port)
214 (format port "#<service-type ~a ~a>"
215 (service-type-name type)
216 (number->string (object-address type) 16)))
217
218(set-record-type-printer! <service-type> write-service-type)
219
220(define %distro-root-directory
221 ;; Absolute file name of the module hierarchy.
222 (dirname (search-path %load-path "guix.scm")))
223
224(define %service-type-path
225 ;; Search path for service types.
226 (make-parameter `((,%distro-root-directory . "gnu/services")
227 (,%distro-root-directory . "gnu/system"))))
228
229(define (all-service-modules)
230 "Return the default set of service modules."
231 (cons (resolve-interface '(gnu services))
232 (all-modules (%service-type-path)
233 #:warn warn-about-load-error)))
234
235(define* (fold-service-types proc seed
236 #:optional
237 (modules (all-service-modules)))
238 "For each service type exported by one of MODULES, call (PROC RESULT). SEED
239is used as the initial value of RESULT."
240 (fold-module-public-variables (lambda (object result)
241 (if (service-type? object)
242 (proc object result)
243 result))
244 seed
245 modules))
246
247(define lookup-service-types
248 (let ((table
249 (delay (fold-service-types (lambda (type result)
250 (vhash-consq (service-type-name type)
251 type result))
252 vlist-null))))
253 (lambda (name)
254 "Return the list of services with the given NAME (a symbol)."
255 (vhash-foldq* cons '() name (force table)))))
256
257(define (%validate-service-type obj properties)
258 (unless (service-type? obj)
259 (raise
260 (apply make-compound-condition
261 (make-exception-from-throw 'wrong-type-arg
262 `("service"
263 "Wrong type of argument for \
264service type: ~S"
265 (,obj)))
266 (condition
267 (&error-location
268 (location (source-properties->location properties))))
269 (formatted-message
270 (G_ "first argument to 'service' (~s) is not a service type")
271 obj)
272 '())))
273 obj)
274
275(define-syntax-rule (validate-service-type obj)
276 "Return OBJ if and only if it is a service type. Otherwise raise an error."
277 (%validate-service-type obj (current-source-location)))
278
279;; Services of a given type.
280(define-record-type <service>
281 (make-service type value)
282 service?
283 (type service-kind)
284 (value service-value))
285
286(define-syntax service
287 (syntax-rules ()
288 "Return a service instance of TYPE. The service value is VALUE or, if
289omitted, TYPE's default value."
290 ((_ type value)
291 (make-service (validate-service-type type) value))
292 ((_ type)
293 (%service-with-default-value (current-source-location)
294 (validate-service-type type)))))
295
296(define (%service-with-default-value location type)
297 "Return a instance of service type TYPE with its default value, if any. If
298TYPE does not have a default value, an error is raised."
299 ;; TODO: Currently this is a run-time error but with a little bit macrology
300 ;; we could turn it into an expansion-time error.
301 (let ((default (service-type-default-value type)))
302 (if (eq? default &no-default-value)
303 (let ((location (source-properties->location location)))
304 (raise
305 (make-compound-condition
306 (condition
307 (&missing-value-service-error (type type) (location location)))
308 (condition
309 (&error-location (location location)))
310 (formatted-message (G_ "no value specified \
311for service of type '~a'")
312 (service-type-name type)))))
313 (service type default))))
314
315(define-condition-type &service-error &error
316 service-error?)
317
318(define-condition-type &missing-value-service-error &service-error
319 missing-value-service-error?
320 (type missing-value-service-error-type)
321 (location missing-value-service-error-location))
322
323
324
325;;;
326;;; Helpers.
327;;;
328
329(define service-parameters
330 ;; Deprecated alias.
331 service-value)
332
333(define (simple-service name target value)
334 "Return a service that extends TARGET with VALUE. This works by creating a
335singleton service type NAME, of which the returned service is an instance."
336 (let* ((extension (service-extension target identity))
337 (type (service-type (name name)
338 (extensions (list extension))
339 (description "This is a simple service."))))
340 (service type value)))
341
342(define-syntax clause-alist
343 (syntax-rules (=> delete)
344 "Build an alist of clauses. Each element has the form (KIND PROC LOC)
345where PROC is the service transformation procedure to apply for KIND, and LOC
346is the source location information."
347 ((_ (delete kind) rest ...)
348 (cons (list kind
349 (lambda (service)
350 #f)
351 (current-source-location))
352 (clause-alist rest ...)))
353 ((_ (kind param => exp ...) rest ...)
354 (cons (list kind
355 (lambda (svc)
356 (let ((param (service-value svc)))
357 (service (service-kind svc)
358 (begin exp ...))))
359 (current-source-location))
360 (clause-alist rest ...)))
361 ((_)
362 '())))
363
364(define (apply-clauses clauses service deleted-services)
365 "Apply CLAUSES, an alist as returned by 'clause-alist', to SERVICE. An
366exception is raised if a clause attempts to modify a service
367present in DELETED-SERVICES."
368 (define (raise-if-deleted kind properties)
369 (match (find (match-lambda
370 ((deleted-kind _)
371 (eq? kind deleted-kind)))
372 deleted-services)
373 ((_ deleted-properties)
374 (raise (make-compound-condition
375 (condition
376 (&error-location
377 (location (source-properties->location properties))))
378 (formatted-message
379 (G_ "modify-services: service '~a' was deleted here: ~a")
380 (service-type-name kind)
381 (source-properties->location deleted-properties)))))
382 (_ #t)))
383
384 (match clauses
385 (((kind proc properties) . rest)
386 (raise-if-deleted kind properties)
387 (if (eq? (and service (service-kind service)) kind)
388 (let ((new-service (proc service)))
389 (apply-clauses rest new-service
390 (if new-service
391 deleted-services
392 (cons (list kind properties)
393 deleted-services))))
394 (apply-clauses rest service deleted-services)))
395 (()
396 service)))
397
398(define (%modify-services services clauses)
399 "Apply CLAUSES, an alist as returned by 'clause-alist', to SERVICES. An
400exception is raised if a clause attempts to modify a missing service."
401 (define (raise-if-not-found clause)
402 (match clause
403 ((kind _ properties)
404 (unless (find (lambda (service)
405 (eq? kind (service-kind service)))
406 services)
407 (raise (make-compound-condition
408 (condition
409 (&error-location
410 (location (source-properties->location properties))))
411 (formatted-message
412 (G_ "modify-services: service '~a' not found in service list")
413 (service-type-name kind))))))))
414
415 (for-each raise-if-not-found clauses)
416 (reverse (filter-map identity
417 (fold (lambda (service services)
418 (cons (apply-clauses clauses service '())
419 services))
420 '()
421 services))))
422
423(define-syntax modify-services
424 (syntax-rules ()
425 "Modify the services listed in SERVICES according to CLAUSES and return
426the resulting list of services. Each clause must have the form:
427
428 (TYPE VARIABLE => BODY)
429
430where TYPE is a service type, such as 'guix-service-type', and VARIABLE is an
431identifier that is bound within BODY to the value of the service of that
432TYPE.
433
434Clauses can also remove services of a given type:
435
436 (delete TYPE)
437
438Consider this example:
439
440 (modify-services %base-services
441 (guix-service-type config =>
442 (guix-configuration
443 (inherit config)
444 (use-substitutes? #f)
445 (extra-options '(\"--gc-keep-derivations\"))))
446 (mingetty-service-type config =>
447 (mingetty-configuration
448 (inherit config)
449 (motd (plain-file \"motd\" \"Hi there!\"))))
450 (delete udev-service-type))
451
452It changes the configuration of the GUIX-SERVICE-TYPE instance, and that of
453all the MINGETTY-SERVICE-TYPE instances, and it deletes instances of the
454UDEV-SERVICE-TYPE."
455 ((_ services clauses ...)
456 (%modify-services services (clause-alist clauses ...)))))
457
458
459;;;
460;;; Core services.
461;;;
462
463(define (system-derivation entries mextensions)
464 "Return as a monadic value the derivation of the 'system' directory
465containing the given entries."
466 (mlet %store-monad ((extensions (mapm/accumulate-builds identity
467 mextensions)))
468 (lower-object
469 (file-union "system"
470 (append entries (concatenate extensions))))))
471
472(define system-service-type
473 ;; This is the ultimate service type, the root of the service DAG. The
474 ;; service of this type is extended by monadic name/item pairs. These items
475 ;; end up in the "system directory" as returned by
476 ;; 'operating-system-derivation'.
477 (service-type (name 'system)
478 (extensions '())
479 (compose identity)
480 (extend system-derivation)
481 (description
482 "Build the operating system top-level directory, which in
483turn refers to everything the operating system needs: its kernel, initrd,
484system profile, boot script, and so on.")))
485
486(define (compute-boot-script _ gexps)
487 ;; Reverse GEXPS so that extensions appear in the boot script in the right
488 ;; order. That is, user extensions would come first, and extensions added
489 ;; by 'essential-services' (e.g., running shepherd) are guaranteed to come
490 ;; last.
491 (gexp->file "boot"
492 ;; Clean up and activate the system, then spawn shepherd.
493 #~(begin #$@(reverse gexps))))
494
495(define (boot-script-entry mboot)
496 "Return, as a monadic value, an entry for the boot script in the system
497directory."
498 (mlet %store-monad ((boot mboot))
499 (return `(("boot" ,boot)))))
500
501(define boot-service-type
502 ;; The service of this type is extended by being passed gexps. It
503 ;; aggregates them in a single script, as a monadic value, which becomes its
504 ;; value.
505 (service-type (name 'boot)
506 (extensions
507 (list (service-extension system-service-type
508 boot-script-entry)))
509 (compose identity)
510 (extend compute-boot-script)
511 (default-value #f)
512 (description
513 "Produce the operating system's boot script, which is spawned
514by the initrd once the root file system is mounted.")))
515
516(define %boot-service
517 ;; The service that produces the boot script.
518 (service boot-service-type #t))
519
520
521;;;
522;;; Provenance tracking.
523;;;
524
525(define (object->pretty-string obj)
526 "Like 'object->string', but using 'pretty-print'."
527 (call-with-output-string
528 (lambda (port)
529 (pretty-print obj port))))
530
531(define (channel->code channel)
532 "Return code to build CHANNEL, ready to be dropped in a 'channels.scm'
533file."
534 ;; Since the 'introduction' field is backward-incompatible, and since it's
535 ;; optional when using the "official" 'guix channel, include it if and only
536 ;; if we're referring to a different channel.
537 (let ((intro (and (not (equal? (list channel) %default-channels))
538 (channel-introduction channel))))
539 `(channel (name ',(channel-name channel))
540 (url ,(channel-url channel))
541 (branch ,(channel-branch channel))
542 (commit ,(channel-commit channel))
543 ,@(if intro
544 `((introduction
545 (make-channel-introduction
546 ,(channel-introduction-first-signed-commit intro)
547 (openpgp-fingerprint
548 ,(openpgp-format-fingerprint
549 (channel-introduction-first-commit-signer
550 intro))))))
551 '()))))
552
553(define (channel->sexp channel)
554 "Return an sexp describing CHANNEL. The sexp is _not_ code and is meant to
555be parsed by tools; it's potentially more future-proof than code."
556 ;; TODO: Add CHANNEL's introduction. Currently we can't do that because
557 ;; older 'guix system describe' expect exactly name/url/branch/commit
558 ;; without any additional fields.
559 `(channel (name ,(channel-name channel))
560 (url ,(channel-url channel))
561 (branch ,(channel-branch channel))
562 (commit ,(channel-commit channel))))
563
564(define (sexp->channel sexp)
565 "Return the channel corresponding to SEXP, an sexp as found in the
566\"provenance\" file produced by 'provenance-service-type'."
567 (match sexp
568 (('channel ('name name)
569 ('url url)
570 ('branch branch)
571 ('commit commit)
572 rest ...)
573 ;; XXX: In the future REST may include a channel introduction.
574 (channel (name name) (url url)
575 (branch branch) (commit commit)))))
576
577(define (provenance-file channels config-file)
578 "Return a 'provenance' file describing CHANNELS, a list of channels, and
579CONFIG-FILE, which can be either #f or a <local-file> containing the OS
580configuration being used."
581 (scheme-file "provenance"
582 #~(provenance
583 (version 0)
584 (channels #+@(if channels
585 (map channel->sexp channels)
586 '()))
587 (configuration-file #+config-file))))
588
589(define (provenance-entry config-file)
590 "Return system entries describing the operating system provenance: the
591channels in use and CONFIG-FILE, if it is true."
592 (define channels
593 (current-channels))
594
595 (mbegin %store-monad
596 (let ((config-file (cond ((string? config-file)
597 ;; CONFIG-FILE has been passed typically via
598 ;; 'guix system reconfigure CONFIG-FILE' so we
599 ;; can assume it's valid: tell 'local-file' to
600 ;; not emit a warning.
601 (local-file (assume-valid-file-name config-file)
602 "configuration.scm"))
603 ((not config-file)
604 #f)
605 (else
606 config-file))))
607 (return `(("provenance" ,(provenance-file channels config-file))
608 ,@(if channels
609 `(("channels.scm"
610 ,(plain-file "channels.scm"
611 (object->pretty-string
612 `(list
613 ,@(map channel->code channels))))))
614 '())
615 ,@(if config-file
616 `(("configuration.scm" ,config-file))
617 '()))))))
618
619(define provenance-service-type
620 (service-type (name 'provenance)
621 (extensions
622 (list (service-extension system-service-type
623 provenance-entry)))
624 (default-value #f) ;the OS config file
625 (description
626 "Store provenance information about the system in the system
627itself: the channels used when building the system, and its configuration
628file, when available.")))
629
630(define (sexp->system-provenance sexp)
631 "Parse SEXP, an s-expression read from /run/current-system/provenance or
632similar, and return two values: the list of channels listed therein, and the
633OS configuration file or #f."
634 (match sexp
635 (('provenance ('version 0)
636 ('channels channels ...)
637 ('configuration-file config-file))
638 (values (map sexp->channel channels)
639 config-file))
640 (_
641 (values '() #f))))
642
643(define (system-provenance system)
644 "Given SYSTEM, the file name of a system generation, return two values: the
645list of channels SYSTEM is built from, and its configuration file. If that
646information is missing, return the empty list (for channels) and possibly
647#false (for the configuration file)."
648 (catch 'system-error
649 (lambda ()
650 (sexp->system-provenance
651 (call-with-input-file (string-append system "/provenance")
652 read)))
653 (lambda _
654 (values '() #f))))
655
656;;;
657;;; Cleanup.
658;;;
659
660(define (cleanup-gexp _)
661 "Return a gexp to clean up /tmp and similar places upon boot."
662 (with-imported-modules '((guix build utils))
663 #~(begin
664 (use-modules (guix build utils))
665
666 ;; Clean out /tmp, /var/run, and /run.
667 ;;
668 ;; XXX This needs to happen before service activations, so it
669 ;; has to be here, but this also implicitly assumes that /tmp
670 ;; and /var/run are on the root partition.
671 (letrec-syntax ((fail-safe (syntax-rules ()
672 ((_ exp rest ...)
673 (begin
674 (catch 'system-error
675 (lambda () exp)
676 (const #f))
677 (fail-safe rest ...)))
678 ((_)
679 #t))))
680 ;; Ignore I/O errors so the system can boot.
681 (fail-safe
682 ;; Remove stale Shadow lock files as they would lead to
683 ;; failures of 'useradd' & co.
684 (delete-file "/etc/group.lock")
685 (delete-file "/etc/passwd.lock")
686 (delete-file "/etc/.pwd.lock") ;from 'lckpwdf'
687
688 ;; Force file names to be decoded as UTF-8. See
689 ;; <https://bugs.gnu.org/26353>.
690 (setenv "GUIX_LOCPATH"
691 #+(file-append
692 (libc-utf8-locales-for-target (%current-system))
693 "/lib/locale"))
694 (setlocale LC_CTYPE "en_US.utf8")
695 (delete-file-recursively "/tmp")
696 (delete-file-recursively "/var/run")
697 (delete-file-recursively "/run")
698
699 ;; Note: The second argument to 'mkdir' is and'ed with umask,
700 ;; hence the 'chmod' calls.
701 (mkdir "/tmp" #o1777)
702 (chmod "/tmp" #o1777)
703 (mkdir "/var/run" #o755)
704 (chmod "/var/run" #o755)
705 (mkdir "/run" #o755)
706 (chmod "/var/run" #o755))))))
707
708(define cleanup-service-type
709 ;; Service that cleans things up in /tmp and similar.
710 (service-type (name 'cleanup)
711 (extensions
712 (list (service-extension boot-service-type
713 cleanup-gexp)))
714 (description
715 "Delete files from @file{/tmp}, @file{/var/run}, and other
716temporary locations at boot time.")))
717
718(define* (activation-service->script service)
719 "Return as a monadic value the activation script for SERVICE, a service of
720ACTIVATION-SCRIPT-TYPE."
721 (activation-script (service-value service)))
722
723(define (activation-script gexps)
724 "Return the system's activation script, which evaluates GEXPS."
725 (define actions
726 ;; TODO: Instead of importing modules here, let users of activation service
727 ;; add them explicitly. See <https://issues.guix.gnu.org/76698>.
728 (map (lambda (action)
729 (program-file "activate-service.scm"
730 (with-imported-modules (source-module-closure
731 '((gnu build activation)
732 (guix build utils)))
733 #~(begin
734 (use-modules (gnu build activation)
735 (guix build utils))
736 #$action))))
737 gexps))
738
739 (program-file "activate.scm"
740 (with-imported-modules (source-module-closure
741 '((gnu build activation)
742 (guix build utils)
743 (guix diagnostics)
744 (guix i18n)))
745 #~(begin
746 (use-modules (gnu build activation)
747 (guix build utils)
748 (guix diagnostics)
749 (guix i18n)
750 (srfi srfi-34))
751
752 (mkdir-p "/var/run")
753 ;; Make sure the user accounting database exists. If it
754 ;; does not exist, 'setutxent' does not create it and
755 ;; thus there is no accounting at all.
756 ;; On GNU/Hurd use utmp instead of utmpx
757 (let ((file (if (and (string-suffix? "-gnu" %host-type)
758 (not (string-contains %host-type "linux")))
759 "/var/run/utmp"
760 "/var/run/utmpx")))
761 (close-port (open file (logior O_WRONLY O_CREAT O_APPEND)
762 #o644)))
763
764 ;; Same for 'wtmp', which is populated by mingetty et
765 ;; al.
766 (mkdir-p "/var/log")
767 (close-port (open "/var/log/wtmp"
768 (logior O_WRONLY O_CREAT O_APPEND)
769 #o644))
770
771 ;; Set up /run/current-system. Among other things this
772 ;; sets up locales, which the activation snippets
773 ;; executed below may expect.
774 (activate-current-system)
775
776 ;; Run the services' activation snippets.
777 ;; TODO: Use 'load-compiled'.
778 (for-each (lambda (action)
779 ;; Don't block activation process when one
780 ;; action fails.
781 (guard (condition
782 (else
783 (format (current-error-port) "~a~%"
784 condition)
785 (warning
786 (G_ "failed to activate '~a'~%")
787 action)))
788 (save-module-excursion
789 (lambda ()
790 (set-current-module
791 (make-fresh-user-module))
792 (primitive-load action)))))
793 '#$actions)))))
794
795(define (gexps->activation-gexp gexps)
796 "Return a gexp that runs the activation script containing GEXPS."
797 #~(primitive-load #$(activation-script gexps)))
798
799(define (activation-profile-entry gexps)
800 "Return, as a monadic value, an entry for the activation script in the
801system directory."
802 (mlet %store-monad ((activate (lower-object (activation-script gexps))))
803 (return `(("activate" ,activate)))))
804
805(define (second-argument a b) b)
806
807(define activation-service-type
808 (service-type (name 'activate)
809 (extensions
810 (list (service-extension boot-service-type
811 gexps->activation-gexp)
812 (service-extension system-service-type
813 activation-profile-entry)))
814 (compose identity)
815 (extend second-argument)
816 (default-value #f)
817 (description
818 "Run @dfn{activation} code at boot time and upon
819@command{guix system reconfigure} completion.")))
820
821(define %activation-service
822 ;; The activation service produces the activation script from the gexps it
823 ;; receives.
824 (service activation-service-type #t))
825
826(define %modprobe-wrapper
827 ;; Wrapper for the 'modprobe' command that knows where modules live.
828 ;;
829 ;; This wrapper is typically invoked by the Linux kernel ('call_modprobe',
830 ;; in kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY'
831 ;; environment variable is not set---hence the need for this wrapper.
832 (let ((modprobe "/run/current-system/profile/bin/modprobe"))
833 (program-file "modprobe"
834 #~(begin
835 (setenv "LINUX_MODULE_DIRECTORY"
836 "/run/booted-system/kernel/lib/modules")
837 ;; FIXME: Remove this crutch when the patch #40422,
838 ;; updating to kmod 27 is merged.
839 (setenv "MODPROBE_OPTIONS"
840 "-C /etc/modprobe.d")
841 (apply execl #$modprobe
842 (cons #$modprobe (cdr (command-line))))))))
843
844(define %linux-kernel-activation
845 ;; Activation of the Linux kernel running on the bare metal (as opposed to
846 ;; running in a container.)
847 #~(begin
848 ;; Tell the kernel to use our 'modprobe' command.
849 (activate-modprobe #$%modprobe-wrapper)
850
851 ;; Let users debug their own processes!
852 (activate-ptrace-attach)))
853
854(define %linux-bare-metal-service
855 ;; The service that does things that are needed on the "bare metal", but not
856 ;; necessary or impossible in a container.
857 (simple-service 'linux-bare-metal
858 activation-service-type
859 %linux-kernel-activation))
860
861(define %hurd-rc-script
862 ;; The RC script to be started upon boot.
863 (program-file "rc"
864 (with-imported-modules (source-module-closure
865 '((guix build utils)
866 (gnu build hurd-boot)
867 (guix build syscalls)))
868 #~(begin
869 (use-modules (guix build utils)
870 (gnu build hurd-boot)
871 (guix build syscalls)
872 (ice-9 match)
873 (system repl repl)
874 (srfi srfi-1)
875 (srfi srfi-26))
876 (boot-hurd-system)))))
877
878(define (hurd-rc-entry rc)
879 "Return, as a monadic value, an entry for the RC script in the system
880directory."
881 (mlet %store-monad ((rc (lower-object rc)))
882 (return `(("rc" ,rc)))))
883
884(define hurd-startup-service-type
885 ;; The service that creates the initial SYSTEM/rc startup file.
886 (service-type (name 'startup)
887 (extensions
888 (list (service-extension system-service-type hurd-rc-entry)))
889 (default-value %hurd-rc-script)
890 (description "This service creates an @file{rc} script in the
891system; that script is responsible for booting the Hurd.")))
892
893(define %hurd-startup-service
894 ;; The service that produces the RC script.
895 (service hurd-startup-service-type %hurd-rc-script))
896
897(define special-files-service-type
898 ;; Service to install "special files" such as /bin/sh and /usr/bin/env.
899 (service-type
900 (name 'special-files)
901 (extensions
902 (list (service-extension activation-service-type
903 (lambda (files)
904 #~(activate-special-files '#$files)))))
905 (compose concatenate)
906 (extend append)
907 (description
908 "Add special files to the root file system---e.g.,
909@file{/usr/bin/env}.")))
910
911(define (extra-special-file file target)
912 "Use TARGET as the \"special file\" FILE. For example, TARGET might be
913 (file-append coreutils \"/bin/env\")
914and FILE could be \"/usr/bin/env\"."
915 (simple-service (string->symbol (string-append "special-file-" file))
916 special-files-service-type
917 `((,file ,target))))
918
919(define (etc-directory service)
920 "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE."
921 (files->etc-directory (service-value service)))
922
923(define (files->etc-directory files)
924 (define (assert-no-duplicates files)
925 (let loop ((files files)
926 (seen (set)))
927 (match files
928 (() #t)
929 (((file _) rest ...)
930 (when (set-contains? seen file)
931 (raise (formatted-message (G_ "duplicate '~a' entry for /etc")
932 file)))
933 (loop rest (set-insert file seen))))))
934
935 ;; Detect duplicates early instead of letting them through, eventually
936 ;; leading to a build failure of "etc.drv".
937 (assert-no-duplicates files)
938
939 (file-union "etc" files))
940
941(define (etc-entry files)
942 "Return an entry for the /etc directory consisting of FILES in the system
943directory."
944 (with-monad %store-monad
945 (return `(("etc" ,(files->etc-directory files))))))
946
947(define etc-service-type
948 (service-type (name 'etc)
949 (extensions
950 (list
951 (service-extension activation-service-type
952 (lambda (files)
953 (let ((etc
954 (files->etc-directory files)))
955 #~(activate-etc #$etc))))
956 (service-extension system-service-type etc-entry)))
957 (compose concatenate)
958 (extend append)
959 (default-value '())
960 (description "Populate the @file{/etc} directory.")))
961
962(define-deprecated (etc-service files)
963 etc-service-type
964 "Return a new service of ETC-SERVICE-TYPE that populates /etc with FILES.
965FILES must be a list of name/file-like object pairs."
966 (service etc-service-type files))
967
968(define (make-files->etc-directory name)
969 "Return a procedure that accept a list of FILES and compute a directory named NAME.
970The returned procedure FILES argument can be packages containing
971@file{etc/@var{name}.d/@var{x}.sh} scripts or single file-like objects of the
972@file{.sh} file extension. The constructed procedure returns a list of
973two-elements list suitable for extending `etc-service-type'."
974 (lambda (files)
975 `((,name
976 ,(computed-file name
977 ;; This is specialized variant of `file-union'.
978 (with-imported-modules '((guix build utils))
979 #~(begin
980 (use-modules (guix build utils)
981 (ice-9 ftw)
982 (ice-9 match)
983 (srfi srfi-1)
984 (srfi srfi-26))
985
986 (define sh-files
987 (append-map
988 (lambda (f)
989 (let* ((dir (format #f "~a/etc/~a" f #$name)))
990 `(,@(if (file-exists? dir)
991 (map (lambda (x)
992 (list x (string-append dir "/" x)))
993 (scandir dir
994 (cut string-suffix? ".sh" <>)))
995 (if (string-suffix? ".sh" f)
996 (list (list (basename
997 (strip-store-file-name f)) f))
998 '())))))
999 (list #$@files)))
1000
1001 (mkdir #$output)
1002 (chdir #$output)
1003
1004 (map (match-lambda ;XXX: adapted from file-union
1005 ((target source)
1006 ;; Stat the source to abort early if it does not exist.
1007 (stat source)
1008 (mkdir-p (dirname target))
1009 (symlink source target)))
1010 sh-files))))))))
1011
1012(define files->profile-d-directory
1013 (make-files->etc-directory "profile.d"))
1014
1015(define etc-profile-d-service-type
1016 (service-type
1017 (name 'etc-profile-d)
1018 (extensions (list (service-extension etc-service-type
1019 files->profile-d-directory)))
1020 (compose concatenate)
1021 (extend append)
1022 (default-value '())
1023 (description "A service for populating @file{/etc/profile.d/} with POSIX
1024scripts having the @file{.sh} file extension, to be sourced when users
1025log in.")))
1026
1027(define files->bashrc-d-directory
1028 (make-files->etc-directory "bashrc.d"))
1029
1030;;; Use an alist to be compatible with <home-bash-configuration>.
1031(define %default-bash-aliases
1032 '(("ls" . "ls -p --color=auto")
1033 ("ll" . "ls -l")
1034 ("grep" . "grep --color=auto")
1035 ("ip" . "ip -color=auto")))
1036
1037;;; ... but avoid the full blown bash-serialize-aliases, which depends on
1038;;; other 'guix home' definitions such as `shell-double-quote'.
1039(define %default-bashrc-d-aliases
1040 (plain-file "aliases.sh"
1041 (string-join
1042 (map (match-lambda
1043 ((alias . value)
1044 (format #f "alias ~a=~s~%" alias value)))
1045 %default-bash-aliases)
1046 "")))
1047
1048(define %default-etc-bashrc-d-files
1049 (list (file-append bash-completion "/etc/profile.d/bash_completion.sh")
1050 %default-bashrc-d-aliases))
1051
1052(define etc-bashrc-d-service-type
1053 (service-type
1054 (inherit etc-profile-d-service-type)
1055 (name 'etc-bashrc-d)
1056 (extensions (list (service-extension etc-service-type
1057 files->bashrc-d-directory)))
1058 (description "A service for populating @file{/etc/bashrc.d/} with Bash
1059scripts having the @file{.sh} file extension, to be sourced by interactive
1060Bash shells.")
1061 (default-value %default-etc-bashrc-d-files)))
1062
1063(define vte-integration-service-type
1064 (service-type
1065 (name 'vte-integration)
1066 (extensions
1067 (list (service-extension etc-bashrc-d-service-type
1068 (lambda (vte)
1069 (list (file-append
1070 vte "/etc/profile.d/vte.sh"))))))
1071 (default-value vte) ;the vte package to use
1072 (description "A service for adding the @file{/etc/bashrc.d/vte.sh} script
1073to your system, which improves the Bash and Zsh experience when using
1074VTE-powered terminal emulators.")))
1075
1076(define (privileged-program->activation-gexp programs)
1077 "Return an activation gexp for privileged-program from PROGRAMS."
1078 (let ((programs
1079 (map (lambda (program)
1080 ;; FIXME This is really ugly, I didn't manage to use "inherit".
1081 (let ((program-name (privileged-program-program program))
1082 (setuid? (privileged-program-setuid? program))
1083 (setgid? (privileged-program-setgid? program))
1084 (user (privileged-program-user program))
1085 (group (privileged-program-group program))
1086 (capabilities (privileged-program-capabilities program)))
1087 (unless (or setuid? setgid? capabilities)
1088 (warning
1089 (G_ "so-called privileged-program ~s lacks any privilege~%")
1090 program-name))
1091 #~(privileged-program (setuid? #$setuid?)
1092 (setgid? #$setgid?)
1093 (user #$user)
1094 (group #$group)
1095 (capabilities #$capabilities)
1096 (program #$program-name))))
1097 programs)))
1098 (with-imported-modules (source-module-closure
1099 '((gnu system privilege)))
1100 #~(begin
1101 (use-modules (gnu system privilege))
1102
1103 (let ((libcap #$(let-system (system target)
1104 ;; When cross-compiling, assume libcap is
1105 ;; available on GNU/Linux only.
1106 (and (if target
1107 (string-suffix? "linux-gnu" target)
1108 (supported-package? libcap system))
1109 libcap))))
1110 (activate-privileged-programs (list #$@programs) libcap))))))
1111
1112(define privileged-program-service-type
1113 (service-type (name 'privileged-program)
1114 (extensions
1115 (list (service-extension activation-service-type
1116 privileged-program->activation-gexp)))
1117 (compose concatenate)
1118 (extend (lambda (config extensions)
1119 (append config extensions)))
1120 (description
1121 "Copy the specified executables to @file{/run/privileged/bin}
1122and apply special privileges like setuid and/or setgid.
1123
1124The deprecated @file{/run/setuid-programs} directory is also populated with
1125symbolic links to their @file{/run/privileged/bin} counterpart. It will be
1126removed in a future Guix release.")))
1127
1128(define-deprecated/alias setuid-program-service-type
1129 ;; Deprecated alias to ease transition. Will be removed!
1130 privileged-program-service-type)
1131
1132(define (packages->profile-entry packages)
1133 "Return a system entry for the profile containing PACKAGES."
1134 ;; XXX: 'mlet' is needed here for one reason: to get the proper
1135 ;; '%current-target' and '%current-target-system' bindings when
1136 ;; 'packages->manifest' is called, and thus when the 'package-inputs'
1137 ;; etc. procedures are called on PACKAGES. That way, conditionals in those
1138 ;; inputs see the "correct" value of these two parameters. See
1139 ;; <https://issues.guix.gnu.org/44952>.
1140 (mlet %store-monad ((_ (current-target-system)))
1141 (return `(("profile" ,(profile
1142 (content (packages->manifest
1143 (delete-duplicates packages eq?)))))))))
1144
1145(define profile-service-type
1146 ;; The service that populates the system's profile---i.e.,
1147 ;; /run/current-system/profile. It is extended by package lists.
1148 (service-type (name 'profile)
1149 (extensions
1150 (list (service-extension system-service-type
1151 packages->profile-entry)))
1152 (compose concatenate)
1153 (extend append)
1154 (default-value '())
1155 (description
1156 "This is the @dfn{system profile}, available as
1157@file{/run/current-system/profile}. It contains packages that the sysadmin
1158wants to be globally available to all the system users.")))
1159
1160(define (firmware->activation-gexp firmware)
1161 "Return a gexp to make the packages listed in FIRMWARE loadable by the
1162kernel."
1163 (let ((directory (directory-union "firmware" firmware)))
1164 ;; Tell the kernel where firmware is.
1165 #~(activate-firmware (string-append #$directory "/lib/firmware"))))
1166
1167(define firmware-service-type
1168 ;; The service that collects firmware.
1169 (service-type (name 'firmware)
1170 (extensions
1171 (list (service-extension activation-service-type
1172 firmware->activation-gexp)))
1173 (compose concatenate)
1174 (extend append)
1175 (description
1176 "Make ``firmware'' files loadable by the operating system
1177kernel. Firmware may then be uploaded to some of the machine's devices, such
1178as Wifi cards.")))
1179
1180(define (gc-roots->system-entry roots)
1181 "Return an entry in the system's output containing symlinks to ROOTS."
1182 (mlet %store-monad ((entry (gexp->derivation
1183 "gc-roots"
1184 #~(let ((roots '#$roots))
1185 (mkdir #$output)
1186 (chdir #$output)
1187 (for-each symlink
1188 roots
1189 (map number->string
1190 (iota (length roots))))))))
1191 (return (if (null? roots)
1192 '()
1193 `(("gc-roots" ,entry))))))
1194
1195(define gc-root-service-type
1196 ;; A service to associate extra garbage-collector roots to the system. This
1197 ;; is a simple hack that guarantees that the system retains references to
1198 ;; the given list of roots. Roots must be "lowerable" objects like
1199 ;; packages, or derivations.
1200 (service-type (name 'gc-roots)
1201 (extensions
1202 (list (service-extension system-service-type
1203 gc-roots->system-entry)))
1204 (compose concatenate)
1205 (extend append)
1206 (description
1207 "Register garbage-collector roots---i.e., store items that
1208will not be reclaimed by the garbage collector.")
1209 (default-value '())))
1210
1211;; Configuration for the Linux kernel builder.
1212(define-record-type* <linux-builder-configuration>
1213 linux-builder-configuration
1214 make-linux-builder-configuration
1215 linux-builder-configuration?
1216 this-linux-builder-configuration
1217
1218 (kernel linux-builder-configuration-kernel) ; package
1219 (modules linux-builder-configuration-modules (default '()))) ; list of packages
1220
1221(define (package-for-kernel target-kernel module-package)
1222 "Return a package like MODULE-PACKAGE, adapted for TARGET-KERNEL, if
1223possible (that is if there's a LINUX keyword argument in the build system)."
1224 (package
1225 (inherit module-package)
1226 (arguments
1227 (substitute-keyword-arguments (package-arguments module-package)
1228 ((#:linux kernel #f)
1229 target-kernel)))))
1230
1231(define (linux-builder-configuration->system-entry config)
1232 "Return the kernel entry of the 'system' directory."
1233 (let* ((kernel (linux-builder-configuration-kernel config))
1234 (modules (linux-builder-configuration-modules config))
1235 (kernel (profile
1236 (content (packages->manifest
1237 (cons kernel
1238 (map (lambda (module)
1239 (cond
1240 ((package? module)
1241 (package-for-kernel kernel module))
1242 ;; support (,package "kernel-module-output")
1243 ((and (list? module) (package? (car module)))
1244 (cons (package-for-kernel kernel
1245 (car module))
1246 (cdr module)))
1247 (else
1248 module)))
1249 modules))))
1250 (hooks (list linux-module-database)))))
1251 (with-monad %store-monad
1252 (return `(("kernel" ,kernel))))))
1253
1254(define linux-builder-service-type
1255 (service-type (name 'linux-builder)
1256 (extensions
1257 (list (service-extension system-service-type
1258 linux-builder-configuration->system-entry)))
1259 (default-value '())
1260 (compose identity)
1261 (extend (lambda (config modifiers)
1262 (if (null? modifiers)
1263 config
1264 ((apply compose modifiers) config))))
1265 (description "Builds the linux-libre kernel profile, containing
1266the kernel itself and any linux-loadable kernel modules. This can be extended
1267with a function that accepts the current configuration and returns a new
1268configuration.")))
1269
1270(define (linux-loadable-module-builder-modifier modules)
1271 "Extends linux-builder-service-type by appending the given MODULES to the
1272configuration of linux-builder-service-type."
1273 (lambda (config)
1274 (linux-builder-configuration
1275 (inherit config)
1276 (modules (append (linux-builder-configuration-modules config)
1277 modules)))))
1278
1279(define linux-loadable-module-service-type
1280 (service-type (name 'linux-loadable-modules)
1281 (extensions
1282 (list (service-extension linux-builder-service-type
1283 linux-loadable-module-builder-modifier)))
1284 (default-value '())
1285 (compose concatenate)
1286 (extend append)
1287 (description "Adds packages and package outputs as modules
1288included in the booted linux-libre profile. Other services can extend this
1289service type to add particular modules to the set of linux-loadable modules.")))
1290
1291
1292
1293;;;
1294;;; Service folding.
1295;;;
1296
1297(define-condition-type &missing-target-service-error &service-error
1298 missing-target-service-error?
1299 (service missing-target-service-error-service)
1300 (target-type missing-target-service-error-target-type))
1301
1302(define-condition-type &ambiguous-target-service-error &service-error
1303 ambiguous-target-service-error?
1304 (service ambiguous-target-service-error-service)
1305 (target-type ambiguous-target-service-error-target-type))
1306
1307(define (missing-target-error service target-type)
1308 (raise
1309 (condition (&missing-target-service-error
1310 (service service)
1311 (target-type target-type))
1312 (&message
1313 (message
1314 (format #f (G_ "no target of type '~a' for service '~a'")
1315 (service-type-name target-type)
1316 (service-type-name
1317 (service-kind service))))))))
1318
1319(define (service-back-edges services)
1320 "Return a procedure that, when passed a <service>, returns the list of
1321<service> objects that depend on it."
1322 (define (add-edges service edges)
1323 (define (add-edge extension edges)
1324 (let ((target-type (service-extension-target extension)))
1325 (match (filter (lambda (service)
1326 (eq? (service-kind service) target-type))
1327 services)
1328 ((target)
1329 (vhash-consq target service edges))
1330 (()
1331 (missing-target-error service target-type))
1332 (x
1333 (raise
1334 (condition (&ambiguous-target-service-error
1335 (service service)
1336 (target-type target-type))
1337 (&message
1338 (message
1339 (format #f
1340 (G_ "more than one target service of type '~a'")
1341 (service-type-name target-type))))))))))
1342
1343 (fold add-edge edges (service-type-extensions (service-kind service))))
1344
1345 (let ((edges (fold add-edges vlist-null services)))
1346 (lambda (node)
1347 (reverse (vhash-foldq* cons '() node edges)))))
1348
1349(define (instantiate-missing-services services)
1350 "Return SERVICES, a list, augmented with any services targeted by extensions
1351and missing from SERVICES. Only service types with a default value can be
1352instantiated; other missing services lead to a
1353'&missing-target-service-error'."
1354 (define (adjust-service-list svc result instances)
1355 (fold2 (lambda (extension result instances)
1356 (define target-type
1357 (service-extension-target extension))
1358
1359 (match (vhash-assq target-type instances)
1360 (#f
1361 (let ((default (service-type-default-value target-type)))
1362 (if (eq? &no-default-value default)
1363 (missing-target-error svc target-type)
1364 (let ((new (service target-type)))
1365 (values (cons new result)
1366 (vhash-consq target-type new instances))))))
1367 (_
1368 (values result instances))))
1369 result
1370 instances
1371 (service-type-extensions (service-kind svc))))
1372
1373 (let loop ((services services))
1374 (define instances
1375 (fold (lambda (service result)
1376 (vhash-consq (service-kind service) service
1377 result))
1378 vlist-null services))
1379
1380 (define adjusted
1381 (fold2 adjust-service-list
1382 services instances
1383 services))
1384
1385 ;; If we instantiated services, they might in turn depend on missing
1386 ;; services. Loop until we've reached fixed point.
1387 (if (= (length adjusted) (vlist-length instances))
1388 adjusted
1389 (loop adjusted))))
1390
1391(define* (fold-services services
1392 #:key (target-type system-service-type))
1393 "Fold SERVICES by propagating their extensions down to the root of type
1394TARGET-TYPE; return the root service adjusted accordingly."
1395 (define dependents
1396 (service-back-edges services))
1397
1398 (define (matching-extension target)
1399 (let ((target (service-kind target)))
1400 (match-lambda
1401 (($ <service-extension> type)
1402 (eq? type target)))))
1403
1404 (define (apply-extension target)
1405 (lambda (service)
1406 (match (find (matching-extension target)
1407 (service-type-extensions (service-kind service)))
1408 (($ <service-extension> _ compute)
1409 (compute (service-value service))))))
1410
1411 (match (filter (lambda (service)
1412 (eq? (service-kind service) target-type))
1413 services)
1414 ((sink)
1415 ;; Use the state monad to keep track of already-visited services in the
1416 ;; graph and to memoize their value once folded.
1417 (run-with-state
1418 (let loop ((sink sink))
1419 (mlet %state-monad ((visited (current-state)))
1420 (match (vhash-assq sink visited)
1421 (#f
1422 (mlet* %state-monad
1423 ((dependents (mapm %state-monad loop (dependents sink)))
1424 (visited (current-state))
1425 (extensions -> (map (apply-extension sink) dependents))
1426 (extend -> (service-type-extend (service-kind sink)))
1427 (compose -> (service-type-compose (service-kind sink)))
1428 (params -> (service-value sink))
1429 (service
1430 ->
1431 ;; Distinguish COMPOSE and EXTEND because PARAMS typically
1432 ;; has a different type than the elements of EXTENSIONS.
1433 (if extend
1434 (service (service-kind sink)
1435 (extend params (compose extensions)))
1436 sink)))
1437 (mbegin %state-monad
1438 (set-current-state (vhash-consq sink service visited))
1439 (return service))))
1440 ((_ . service) ;SINK was already visited
1441 (return service)))))
1442 vlist-null))
1443 (()
1444 (raise
1445 (make-compound-condition
1446 (condition (&missing-target-service-error
1447 (service #f)
1448 (target-type target-type)))
1449 (formatted-message (G_ "service of type '~a' not found")
1450 (service-type-name target-type)))))
1451 (x
1452 (raise
1453 (condition (&ambiguous-target-service-error
1454 (service #f)
1455 (target-type target-type))
1456 (&message
1457 (message
1458 (format #f
1459 (G_ "more than one target service of type '~a'")
1460 (service-type-name target-type)))))))))
1461
1462(define (remove-service-extensions type lst)
1463 "Return TYPE, a service type, without any of the service extensions
1464targeting one of the types in LST."
1465 (service-type
1466 (inherit type)
1467 (extensions (remove (lambda (extension)
1468 (memq (service-extension-target extension) lst))
1469 (service-type-extensions type)))))
1470
1471(define-syntax-parameter for-home?
1472 ;; Whether the configuration being defined is for a Home service.
1473 (identifier-syntax #f))
1474
1475(define-syntax-rule (for-home exp ...)
1476 "Mark EXP, which typically defines a service configuration, as targeting a
1477Home service rather than a System service."
1478 (syntax-parameterize ((for-home? (identifier-syntax #t)))
1479 exp ...))
1480
1481(define-with-syntax-properties (validate-service-list (value properties))
1482 (%validate-service-list value properties))
1483
1484(define (%validate-service-list value properties)
1485 (match value
1486 (((? service?) ...) value)
1487 (_
1488 (raise
1489 (make-compound-condition
1490 (condition
1491 (&error-location
1492 (location (source-properties->location properties))))
1493 (formatted-message
1494 (G_ "'services' field must contain a list of services")))))))
1495
1496;;; services.scm ends here.