projects/guix·blob java-team · refs

1493 lines · 59.8 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(define-module (gnu services)
30 #:use-module (guix derivations)
31 #:use-module (guix gexp)
32 #:use-module (guix monads)
33 #:use-module (guix store)
34 #:use-module (guix records)
35 #:use-module (guix profiles)
36 #:use-module (guix discovery)
37 #:use-module (guix combinators)
38 #:use-module (guix channels)
39 #:use-module (guix describe)
40 #:use-module (guix sets)
41 #:use-module (guix ui)
42 #:use-module (guix diagnostics)
43 #:autoload (guix openpgp) (openpgp-format-fingerprint)
44 #:use-module (guix modules)
45 #:use-module (guix packages)
46 #:use-module (guix utils)
47 #:use-module (guix deprecation)
48 #:use-module (gnu packages base)
49 #:use-module (gnu packages bash)
50 #:use-module (gnu packages gnome)
51 #:use-module (gnu packages hurd)
52 #:use-module (gnu packages linux)
53 #:use-module (gnu system privilege)
54 #:use-module (srfi srfi-1)
55 #:use-module (srfi srfi-9)
56 #:use-module (srfi srfi-9 gnu)
57 #:use-module (srfi srfi-26)
58 #:use-module (srfi srfi-34)
59 #:use-module (srfi srfi-35)
60 #:use-module (srfi srfi-71)
61 #:use-module (ice-9 vlist)
62 #:use-module (ice-9 match)
63 #:autoload (ice-9 pretty-print) (pretty-print)
64 #:export (service-extension
65 service-extension?
66 service-extension-target
67 service-extension-compute
68
69 service-type
70 service-type?
71 service-type-name
72 service-type-extensions
73 service-type-compose
74 service-type-extend
75 service-type-default-value
76 service-type-description
77 service-type-location
78
79 %service-type-path
80 fold-service-types
81 lookup-service-types
82
83 service
84 service?
85 service-kind
86 service-value
87 service-parameters ;deprecated
88
89 simple-service
90 modify-services
91 service-back-edges
92 instantiate-missing-services
93 fold-services
94
95 remove-service-extensions
96 for-home
97 for-home?
98
99 validate-service-list
100
101 service-error?
102 missing-value-service-error?
103 missing-value-service-error-type
104 missing-value-service-error-location
105 missing-target-service-error?
106 missing-target-service-error-service
107 missing-target-service-error-target-type
108 ambiguous-target-service-error?
109 ambiguous-target-service-error-service
110 ambiguous-target-service-error-target-type
111
112 system-service-type
113 provenance-service-type
114 sexp->system-provenance
115 system-provenance
116 boot-service-type
117 cleanup-service-type
118 activation-service-type
119 activation-service->script
120 %linux-bare-metal-service
121 %hurd-rc-script
122 %hurd-startup-service
123 special-files-service-type
124 extra-special-file
125 etc-service-type
126 etc-profile-d-service-type
127 etc-bashrc-d-service-type
128 %default-etc-bashrc-d-files
129 %default-bash-aliases
130 etc-directory
131 privileged-program-service-type
132 setuid-program-service-type ; deprecated
133 profile-service-type
134 firmware-service-type
135 gc-root-service-type
136 linux-builder-service-type
137 linux-builder-configuration
138 linux-builder-configuration?
139 linux-builder-configuration-kernel
140 linux-builder-configuration-modules
141 linux-loadable-module-service-type
142 vte-integration-service-type
143
144 %boot-service
145 %activation-service
146 etc-service) ; deprecated
147 #:re-export (;; Note: Re-export 'delete' to allow for proper syntax matching
148 ;; in 'modify-services' forms. See
149 ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26805#16>.
150 delete))
151
152;;; Comment:
153;;;
154;;; This module defines a broad notion of "service types" and "services."
155;;;
156;;; A service type describe how its instances extend instances of other
157;;; service types. For instance, some services extend the instance of
158;;; ACCOUNT-SERVICE-TYPE by providing it with accounts and groups to create;
159;;; others extend SHEPHERD-ROOT-SERVICE-TYPE by passing it instances of
160;;; <shepherd-service>.
161;;;
162;;; When applicable, the service type defines how it can itself be extended,
163;;; by providing one procedure to compose extensions, and one procedure to
164;;; extend itself.
165;;;
166;;; A notable service type is SYSTEM-SERVICE-TYPE, which has a single
167;;; instance, which is the root of the service DAG. Its value is the
168;;; derivation that produces the 'system' directory as returned by
169;;; 'operating-system-derivation'.
170;;;
171;;; The 'fold-services' procedure can be passed a list of procedures, which it
172;;; "folds" by propagating extensions down the graph; it returns the root
173;;; service after the applying all its extensions.
174;;;
175;;; Code:
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 (if (and (string-suffix? "-gnu" %host-type)
758 (not (string-contains %host-type "linux")))
759 (close-port (open-file "/var/run/utmp" "a0"))
760 (close-port (open-file "/var/run/utmpx" "a0")))
761
762
763 ;; Same for 'wtmp', which is populated by mingetty et
764 ;; al.
765 (mkdir-p "/var/log")
766 (close-port (open-file "/var/log/wtmp" "a0"))
767
768 ;; Set up /run/current-system. Among other things this
769 ;; sets up locales, which the activation snippets
770 ;; executed below may expect.
771 (activate-current-system)
772
773 ;; Run the services' activation snippets.
774 ;; TODO: Use 'load-compiled'.
775 (for-each (lambda (action)
776 ;; Don't block activation process when one
777 ;; action fails.
778 (guard (condition
779 (else
780 (format (current-error-port) "~a~%"
781 condition)
782 (warning
783 (G_ "failed to activate '~a'~%")
784 action)))
785 (save-module-excursion
786 (lambda ()
787 (set-current-module
788 (make-fresh-user-module))
789 (primitive-load action)))))
790 '#$actions)))))
791
792(define (gexps->activation-gexp gexps)
793 "Return a gexp that runs the activation script containing GEXPS."
794 #~(primitive-load #$(activation-script gexps)))
795
796(define (activation-profile-entry gexps)
797 "Return, as a monadic value, an entry for the activation script in the
798system directory."
799 (mlet %store-monad ((activate (lower-object (activation-script gexps))))
800 (return `(("activate" ,activate)))))
801
802(define (second-argument a b) b)
803
804(define activation-service-type
805 (service-type (name 'activate)
806 (extensions
807 (list (service-extension boot-service-type
808 gexps->activation-gexp)
809 (service-extension system-service-type
810 activation-profile-entry)))
811 (compose identity)
812 (extend second-argument)
813 (default-value #f)
814 (description
815 "Run @dfn{activation} code at boot time and upon
816@command{guix system reconfigure} completion.")))
817
818(define %activation-service
819 ;; The activation service produces the activation script from the gexps it
820 ;; receives.
821 (service activation-service-type #t))
822
823(define %modprobe-wrapper
824 ;; Wrapper for the 'modprobe' command that knows where modules live.
825 ;;
826 ;; This wrapper is typically invoked by the Linux kernel ('call_modprobe',
827 ;; in kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY'
828 ;; environment variable is not set---hence the need for this wrapper.
829 (let ((modprobe "/run/current-system/profile/bin/modprobe"))
830 (program-file "modprobe"
831 #~(begin
832 (setenv "LINUX_MODULE_DIRECTORY"
833 "/run/booted-system/kernel/lib/modules")
834 ;; FIXME: Remove this crutch when the patch #40422,
835 ;; updating to kmod 27 is merged.
836 (setenv "MODPROBE_OPTIONS"
837 "-C /etc/modprobe.d")
838 (apply execl #$modprobe
839 (cons #$modprobe (cdr (command-line))))))))
840
841(define %linux-kernel-activation
842 ;; Activation of the Linux kernel running on the bare metal (as opposed to
843 ;; running in a container.)
844 #~(begin
845 ;; Tell the kernel to use our 'modprobe' command.
846 (activate-modprobe #$%modprobe-wrapper)
847
848 ;; Let users debug their own processes!
849 (activate-ptrace-attach)))
850
851(define %linux-bare-metal-service
852 ;; The service that does things that are needed on the "bare metal", but not
853 ;; necessary or impossible in a container.
854 (simple-service 'linux-bare-metal
855 activation-service-type
856 %linux-kernel-activation))
857
858(define %hurd-rc-script
859 ;; The RC script to be started upon boot.
860 (program-file "rc"
861 (with-imported-modules (source-module-closure
862 '((guix build utils)
863 (gnu build hurd-boot)
864 (guix build syscalls)))
865 #~(begin
866 (use-modules (guix build utils)
867 (gnu build hurd-boot)
868 (guix build syscalls)
869 (ice-9 match)
870 (system repl repl)
871 (srfi srfi-1)
872 (srfi srfi-26))
873 (boot-hurd-system)))))
874
875(define (hurd-rc-entry rc)
876 "Return, as a monadic value, an entry for the RC script in the system
877directory."
878 (mlet %store-monad ((rc (lower-object rc)))
879 (return `(("rc" ,rc)))))
880
881(define hurd-startup-service-type
882 ;; The service that creates the initial SYSTEM/rc startup file.
883 (service-type (name 'startup)
884 (extensions
885 (list (service-extension system-service-type hurd-rc-entry)))
886 (default-value %hurd-rc-script)
887 (description "This service creates an @file{rc} script in the
888system; that script is responsible for booting the Hurd.")))
889
890(define %hurd-startup-service
891 ;; The service that produces the RC script.
892 (service hurd-startup-service-type %hurd-rc-script))
893
894(define special-files-service-type
895 ;; Service to install "special files" such as /bin/sh and /usr/bin/env.
896 (service-type
897 (name 'special-files)
898 (extensions
899 (list (service-extension activation-service-type
900 (lambda (files)
901 #~(activate-special-files '#$files)))))
902 (compose concatenate)
903 (extend append)
904 (description
905 "Add special files to the root file system---e.g.,
906@file{/usr/bin/env}.")))
907
908(define (extra-special-file file target)
909 "Use TARGET as the \"special file\" FILE. For example, TARGET might be
910 (file-append coreutils \"/bin/env\")
911and FILE could be \"/usr/bin/env\"."
912 (simple-service (string->symbol (string-append "special-file-" file))
913 special-files-service-type
914 `((,file ,target))))
915
916(define (etc-directory service)
917 "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE."
918 (files->etc-directory (service-value service)))
919
920(define (files->etc-directory files)
921 (define (assert-no-duplicates files)
922 (let loop ((files files)
923 (seen (set)))
924 (match files
925 (() #t)
926 (((file _) rest ...)
927 (when (set-contains? seen file)
928 (raise (formatted-message (G_ "duplicate '~a' entry for /etc")
929 file)))
930 (loop rest (set-insert file seen))))))
931
932 ;; Detect duplicates early instead of letting them through, eventually
933 ;; leading to a build failure of "etc.drv".
934 (assert-no-duplicates files)
935
936 (file-union "etc" files))
937
938(define (etc-entry files)
939 "Return an entry for the /etc directory consisting of FILES in the system
940directory."
941 (with-monad %store-monad
942 (return `(("etc" ,(files->etc-directory files))))))
943
944(define etc-service-type
945 (service-type (name 'etc)
946 (extensions
947 (list
948 (service-extension activation-service-type
949 (lambda (files)
950 (let ((etc
951 (files->etc-directory files)))
952 #~(activate-etc #$etc))))
953 (service-extension system-service-type etc-entry)))
954 (compose concatenate)
955 (extend append)
956 (default-value '())
957 (description "Populate the @file{/etc} directory.")))
958
959(define-deprecated (etc-service files)
960 etc-service-type
961 "Return a new service of ETC-SERVICE-TYPE that populates /etc with FILES.
962FILES must be a list of name/file-like object pairs."
963 (service etc-service-type files))
964
965(define (make-files->etc-directory name)
966 "Return a procedure that accept a list of FILES and compute a directory named NAME.
967The returned procedure FILES argument can be packages containing
968@file{etc/@var{name}.d/@var{x}.sh} scripts or single file-like objects of the
969@file{.sh} file extension. The constructed procedure returns a list of
970two-elements list suitable for extending `etc-service-type'."
971 (lambda (files)
972 `((,name
973 ,(computed-file name
974 ;; This is specialized variant of `file-union'.
975 (with-imported-modules '((guix build utils))
976 #~(begin
977 (use-modules (guix build utils)
978 (ice-9 ftw)
979 (ice-9 match)
980 (srfi srfi-1)
981 (srfi srfi-26))
982
983 (define sh-files
984 (append-map
985 (lambda (f)
986 (let* ((dir (format #f "~a/etc/~a" f #$name)))
987 `(,@(if (file-exists? dir)
988 (map (lambda (x)
989 (list x (string-append dir "/" x)))
990 (scandir dir
991 (cut string-suffix? ".sh" <>)))
992 (if (string-suffix? ".sh" f)
993 (list (list (basename
994 (strip-store-file-name f)) f))
995 '())))))
996 (list #$@files)))
997
998 (mkdir #$output)
999 (chdir #$output)
1000
1001 (map (match-lambda ;XXX: adapted from file-union
1002 ((target source)
1003 ;; Stat the source to abort early if it does not exist.
1004 (stat source)
1005 (mkdir-p (dirname target))
1006 (symlink source target)))
1007 sh-files))))))))
1008
1009(define files->profile-d-directory
1010 (make-files->etc-directory "profile.d"))
1011
1012(define etc-profile-d-service-type
1013 (service-type
1014 (name 'etc-profile-d)
1015 (extensions (list (service-extension etc-service-type
1016 files->profile-d-directory)))
1017 (compose concatenate)
1018 (extend append)
1019 (default-value '())
1020 (description "A service for populating @file{/etc/profile.d/} with POSIX
1021scripts having the @file{.sh} file extension, to be sourced when users
1022log in.")))
1023
1024(define files->bashrc-d-directory
1025 (make-files->etc-directory "bashrc.d"))
1026
1027;;; Use an alist to be compatible with <home-bash-configuration>.
1028(define %default-bash-aliases
1029 '(("ls" . "ls -p --color=auto")
1030 ("ll" . "ls -l")
1031 ("grep" . "grep --color=auto")
1032 ("ip" . "ip -color=auto")))
1033
1034;;; ... but avoid the full blown bash-serialize-aliases, which depends on
1035;;; other 'guix home' definitions such as `shell-double-quote'.
1036(define %default-bashrc-d-aliases
1037 (plain-file "aliases.sh"
1038 (string-join
1039 (map (match-lambda
1040 ((alias . value)
1041 (format #f "alias ~a=~s~%" alias value)))
1042 %default-bash-aliases)
1043 "")))
1044
1045(define %default-etc-bashrc-d-files
1046 (list (file-append bash-completion "/etc/profile.d/bash_completion.sh")
1047 %default-bashrc-d-aliases))
1048
1049(define etc-bashrc-d-service-type
1050 (service-type
1051 (inherit etc-profile-d-service-type)
1052 (name 'etc-bashrc-d)
1053 (extensions (list (service-extension etc-service-type
1054 files->bashrc-d-directory)))
1055 (description "A service for populating @file{/etc/bashrc.d/} with Bash
1056scripts having the @file{.sh} file extension, to be sourced by interactive
1057Bash shells.")
1058 (default-value %default-etc-bashrc-d-files)))
1059
1060(define vte-integration-service-type
1061 (service-type
1062 (name 'vte-integration)
1063 (extensions
1064 (list (service-extension etc-bashrc-d-service-type
1065 (lambda (vte)
1066 (list (file-append
1067 vte "/etc/profile.d/vte.sh"))))))
1068 (default-value vte) ;the vte package to use
1069 (description "A service for adding the @file{/etc/bashrc.d/vte.sh} script
1070to your system, which improves the Bash and Zsh experience when using
1071VTE-powered terminal emulators.")))
1072
1073(define (privileged-program->activation-gexp programs)
1074 "Return an activation gexp for privileged-program from PROGRAMS."
1075 (let ((programs
1076 (map (lambda (program)
1077 ;; FIXME This is really ugly, I didn't manage to use "inherit".
1078 (let ((program-name (privileged-program-program program))
1079 (setuid? (privileged-program-setuid? program))
1080 (setgid? (privileged-program-setgid? program))
1081 (user (privileged-program-user program))
1082 (group (privileged-program-group program))
1083 (capabilities (privileged-program-capabilities program)))
1084 (unless (or setuid? setgid? capabilities)
1085 (warning
1086 (G_ "so-called privileged-program ~s lacks any privilege~%")
1087 program-name))
1088 #~(privileged-program (setuid? #$setuid?)
1089 (setgid? #$setgid?)
1090 (user #$user)
1091 (group #$group)
1092 (capabilities #$capabilities)
1093 (program #$program-name))))
1094 programs)))
1095 (with-imported-modules (source-module-closure
1096 '((gnu system privilege)))
1097 #~(begin
1098 (use-modules (gnu system privilege))
1099
1100 (let ((libcap #$(let-system (system target)
1101 ;; When cross-compiling, assume libcap is
1102 ;; available on GNU/Linux only.
1103 (and (if target
1104 (string-suffix? "linux-gnu" target)
1105 (supported-package? libcap system))
1106 libcap))))
1107 (activate-privileged-programs (list #$@programs) libcap))))))
1108
1109(define privileged-program-service-type
1110 (service-type (name 'privileged-program)
1111 (extensions
1112 (list (service-extension activation-service-type
1113 privileged-program->activation-gexp)))
1114 (compose concatenate)
1115 (extend (lambda (config extensions)
1116 (append config extensions)))
1117 (description
1118 "Copy the specified executables to @file{/run/privileged/bin}
1119and apply special privileges like setuid and/or setgid.
1120
1121The deprecated @file{/run/setuid-programs} directory is also populated with
1122symbolic links to their @file{/run/privileged/bin} counterpart. It will be
1123removed in a future Guix release.")))
1124
1125(define-deprecated/alias setuid-program-service-type
1126 ;; Deprecated alias to ease transition. Will be removed!
1127 privileged-program-service-type)
1128
1129(define (packages->profile-entry packages)
1130 "Return a system entry for the profile containing PACKAGES."
1131 ;; XXX: 'mlet' is needed here for one reason: to get the proper
1132 ;; '%current-target' and '%current-target-system' bindings when
1133 ;; 'packages->manifest' is called, and thus when the 'package-inputs'
1134 ;; etc. procedures are called on PACKAGES. That way, conditionals in those
1135 ;; inputs see the "correct" value of these two parameters. See
1136 ;; <https://issues.guix.gnu.org/44952>.
1137 (mlet %store-monad ((_ (current-target-system)))
1138 (return `(("profile" ,(profile
1139 (content (packages->manifest
1140 (delete-duplicates packages eq?)))))))))
1141
1142(define profile-service-type
1143 ;; The service that populates the system's profile---i.e.,
1144 ;; /run/current-system/profile. It is extended by package lists.
1145 (service-type (name 'profile)
1146 (extensions
1147 (list (service-extension system-service-type
1148 packages->profile-entry)))
1149 (compose concatenate)
1150 (extend append)
1151 (default-value '())
1152 (description
1153 "This is the @dfn{system profile}, available as
1154@file{/run/current-system/profile}. It contains packages that the sysadmin
1155wants to be globally available to all the system users.")))
1156
1157(define (firmware->activation-gexp firmware)
1158 "Return a gexp to make the packages listed in FIRMWARE loadable by the
1159kernel."
1160 (let ((directory (directory-union "firmware" firmware)))
1161 ;; Tell the kernel where firmware is.
1162 #~(activate-firmware (string-append #$directory "/lib/firmware"))))
1163
1164(define firmware-service-type
1165 ;; The service that collects firmware.
1166 (service-type (name 'firmware)
1167 (extensions
1168 (list (service-extension activation-service-type
1169 firmware->activation-gexp)))
1170 (compose concatenate)
1171 (extend append)
1172 (description
1173 "Make ``firmware'' files loadable by the operating system
1174kernel. Firmware may then be uploaded to some of the machine's devices, such
1175as Wifi cards.")))
1176
1177(define (gc-roots->system-entry roots)
1178 "Return an entry in the system's output containing symlinks to ROOTS."
1179 (mlet %store-monad ((entry (gexp->derivation
1180 "gc-roots"
1181 #~(let ((roots '#$roots))
1182 (mkdir #$output)
1183 (chdir #$output)
1184 (for-each symlink
1185 roots
1186 (map number->string
1187 (iota (length roots))))))))
1188 (return (if (null? roots)
1189 '()
1190 `(("gc-roots" ,entry))))))
1191
1192(define gc-root-service-type
1193 ;; A service to associate extra garbage-collector roots to the system. This
1194 ;; is a simple hack that guarantees that the system retains references to
1195 ;; the given list of roots. Roots must be "lowerable" objects like
1196 ;; packages, or derivations.
1197 (service-type (name 'gc-roots)
1198 (extensions
1199 (list (service-extension system-service-type
1200 gc-roots->system-entry)))
1201 (compose concatenate)
1202 (extend append)
1203 (description
1204 "Register garbage-collector roots---i.e., store items that
1205will not be reclaimed by the garbage collector.")
1206 (default-value '())))
1207
1208;; Configuration for the Linux kernel builder.
1209(define-record-type* <linux-builder-configuration>
1210 linux-builder-configuration
1211 make-linux-builder-configuration
1212 linux-builder-configuration?
1213 this-linux-builder-configuration
1214
1215 (kernel linux-builder-configuration-kernel) ; package
1216 (modules linux-builder-configuration-modules (default '()))) ; list of packages
1217
1218(define (package-for-kernel target-kernel module-package)
1219 "Return a package like MODULE-PACKAGE, adapted for TARGET-KERNEL, if
1220possible (that is if there's a LINUX keyword argument in the build system)."
1221 (package
1222 (inherit module-package)
1223 (arguments
1224 (substitute-keyword-arguments (package-arguments module-package)
1225 ((#:linux kernel #f)
1226 target-kernel)))))
1227
1228(define (linux-builder-configuration->system-entry config)
1229 "Return the kernel entry of the 'system' directory."
1230 (let* ((kernel (linux-builder-configuration-kernel config))
1231 (modules (linux-builder-configuration-modules config))
1232 (kernel (profile
1233 (content (packages->manifest
1234 (cons kernel
1235 (map (lambda (module)
1236 (cond
1237 ((package? module)
1238 (package-for-kernel kernel module))
1239 ;; support (,package "kernel-module-output")
1240 ((and (list? module) (package? (car module)))
1241 (cons (package-for-kernel kernel
1242 (car module))
1243 (cdr module)))
1244 (else
1245 module)))
1246 modules))))
1247 (hooks (list linux-module-database)))))
1248 (with-monad %store-monad
1249 (return `(("kernel" ,kernel))))))
1250
1251(define linux-builder-service-type
1252 (service-type (name 'linux-builder)
1253 (extensions
1254 (list (service-extension system-service-type
1255 linux-builder-configuration->system-entry)))
1256 (default-value '())
1257 (compose identity)
1258 (extend (lambda (config modifiers)
1259 (if (null? modifiers)
1260 config
1261 ((apply compose modifiers) config))))
1262 (description "Builds the linux-libre kernel profile, containing
1263the kernel itself and any linux-loadable kernel modules. This can be extended
1264with a function that accepts the current configuration and returns a new
1265configuration.")))
1266
1267(define (linux-loadable-module-builder-modifier modules)
1268 "Extends linux-builder-service-type by appending the given MODULES to the
1269configuration of linux-builder-service-type."
1270 (lambda (config)
1271 (linux-builder-configuration
1272 (inherit config)
1273 (modules (append (linux-builder-configuration-modules config)
1274 modules)))))
1275
1276(define linux-loadable-module-service-type
1277 (service-type (name 'linux-loadable-modules)
1278 (extensions
1279 (list (service-extension linux-builder-service-type
1280 linux-loadable-module-builder-modifier)))
1281 (default-value '())
1282 (compose concatenate)
1283 (extend append)
1284 (description "Adds packages and package outputs as modules
1285included in the booted linux-libre profile. Other services can extend this
1286service type to add particular modules to the set of linux-loadable modules.")))
1287
1288
1289
1290;;;
1291;;; Service folding.
1292;;;
1293
1294(define-condition-type &missing-target-service-error &service-error
1295 missing-target-service-error?
1296 (service missing-target-service-error-service)
1297 (target-type missing-target-service-error-target-type))
1298
1299(define-condition-type &ambiguous-target-service-error &service-error
1300 ambiguous-target-service-error?
1301 (service ambiguous-target-service-error-service)
1302 (target-type ambiguous-target-service-error-target-type))
1303
1304(define (missing-target-error service target-type)
1305 (raise
1306 (condition (&missing-target-service-error
1307 (service service)
1308 (target-type target-type))
1309 (&message
1310 (message
1311 (format #f (G_ "no target of type '~a' for service '~a'")
1312 (service-type-name target-type)
1313 (service-type-name
1314 (service-kind service))))))))
1315
1316(define (service-back-edges services)
1317 "Return a procedure that, when passed a <service>, returns the list of
1318<service> objects that depend on it."
1319 (define (add-edges service edges)
1320 (define (add-edge extension edges)
1321 (let ((target-type (service-extension-target extension)))
1322 (match (filter (lambda (service)
1323 (eq? (service-kind service) target-type))
1324 services)
1325 ((target)
1326 (vhash-consq target service edges))
1327 (()
1328 (missing-target-error service target-type))
1329 (x
1330 (raise
1331 (condition (&ambiguous-target-service-error
1332 (service service)
1333 (target-type target-type))
1334 (&message
1335 (message
1336 (format #f
1337 (G_ "more than one target service of type '~a'")
1338 (service-type-name target-type))))))))))
1339
1340 (fold add-edge edges (service-type-extensions (service-kind service))))
1341
1342 (let ((edges (fold add-edges vlist-null services)))
1343 (lambda (node)
1344 (reverse (vhash-foldq* cons '() node edges)))))
1345
1346(define (instantiate-missing-services services)
1347 "Return SERVICES, a list, augmented with any services targeted by extensions
1348and missing from SERVICES. Only service types with a default value can be
1349instantiated; other missing services lead to a
1350'&missing-target-service-error'."
1351 (define (adjust-service-list svc result instances)
1352 (fold2 (lambda (extension result instances)
1353 (define target-type
1354 (service-extension-target extension))
1355
1356 (match (vhash-assq target-type instances)
1357 (#f
1358 (let ((default (service-type-default-value target-type)))
1359 (if (eq? &no-default-value default)
1360 (missing-target-error svc target-type)
1361 (let ((new (service target-type)))
1362 (values (cons new result)
1363 (vhash-consq target-type new instances))))))
1364 (_
1365 (values result instances))))
1366 result
1367 instances
1368 (service-type-extensions (service-kind svc))))
1369
1370 (let loop ((services services))
1371 (define instances
1372 (fold (lambda (service result)
1373 (vhash-consq (service-kind service) service
1374 result))
1375 vlist-null services))
1376
1377 (define adjusted
1378 (fold2 adjust-service-list
1379 services instances
1380 services))
1381
1382 ;; If we instantiated services, they might in turn depend on missing
1383 ;; services. Loop until we've reached fixed point.
1384 (if (= (length adjusted) (vlist-length instances))
1385 adjusted
1386 (loop adjusted))))
1387
1388(define* (fold-services services
1389 #:key (target-type system-service-type))
1390 "Fold SERVICES by propagating their extensions down to the root of type
1391TARGET-TYPE; return the root service adjusted accordingly."
1392 (define dependents
1393 (service-back-edges services))
1394
1395 (define (matching-extension target)
1396 (let ((target (service-kind target)))
1397 (match-lambda
1398 (($ <service-extension> type)
1399 (eq? type target)))))
1400
1401 (define (apply-extension target)
1402 (lambda (service)
1403 (match (find (matching-extension target)
1404 (service-type-extensions (service-kind service)))
1405 (($ <service-extension> _ compute)
1406 (compute (service-value service))))))
1407
1408 (match (filter (lambda (service)
1409 (eq? (service-kind service) target-type))
1410 services)
1411 ((sink)
1412 ;; Use the state monad to keep track of already-visited services in the
1413 ;; graph and to memoize their value once folded.
1414 (run-with-state
1415 (let loop ((sink sink))
1416 (mlet %state-monad ((visited (current-state)))
1417 (match (vhash-assq sink visited)
1418 (#f
1419 (mlet* %state-monad
1420 ((dependents (mapm %state-monad loop (dependents sink)))
1421 (visited (current-state))
1422 (extensions -> (map (apply-extension sink) dependents))
1423 (extend -> (service-type-extend (service-kind sink)))
1424 (compose -> (service-type-compose (service-kind sink)))
1425 (params -> (service-value sink))
1426 (service
1427 ->
1428 ;; Distinguish COMPOSE and EXTEND because PARAMS typically
1429 ;; has a different type than the elements of EXTENSIONS.
1430 (if extend
1431 (service (service-kind sink)
1432 (extend params (compose extensions)))
1433 sink)))
1434 (mbegin %state-monad
1435 (set-current-state (vhash-consq sink service visited))
1436 (return service))))
1437 ((_ . service) ;SINK was already visited
1438 (return service)))))
1439 vlist-null))
1440 (()
1441 (raise
1442 (make-compound-condition
1443 (condition (&missing-target-service-error
1444 (service #f)
1445 (target-type target-type)))
1446 (formatted-message (G_ "service of type '~a' not found")
1447 (service-type-name target-type)))))
1448 (x
1449 (raise
1450 (condition (&ambiguous-target-service-error
1451 (service #f)
1452 (target-type target-type))
1453 (&message
1454 (message
1455 (format #f
1456 (G_ "more than one target service of type '~a'")
1457 (service-type-name target-type)))))))))
1458
1459(define (remove-service-extensions type lst)
1460 "Return TYPE, a service type, without any of the service extensions
1461targeting one of the types in LST."
1462 (service-type
1463 (inherit type)
1464 (extensions (remove (lambda (extension)
1465 (memq (service-extension-target extension) lst))
1466 (service-type-extensions type)))))
1467
1468(define-syntax-parameter for-home?
1469 ;; Whether the configuration being defined is for a Home service.
1470 (identifier-syntax #f))
1471
1472(define-syntax-rule (for-home exp ...)
1473 "Mark EXP, which typically defines a service configuration, as targeting a
1474Home service rather than a System service."
1475 (syntax-parameterize ((for-home? (identifier-syntax #t)))
1476 exp ...))
1477
1478(define-with-syntax-properties (validate-service-list (value properties))
1479 (%validate-service-list value properties))
1480
1481(define (%validate-service-list value properties)
1482 (match value
1483 (((? service?) ...) value)
1484 (_
1485 (raise
1486 (make-compound-condition
1487 (condition
1488 (&error-location
1489 (location (source-properties->location properties))))
1490 (formatted-message
1491 (G_ "'services' field must contain a list of services")))))))
1492
1493;;; services.scm ends here.