projects/guix·blob ruby-team · refs

1470 lines · 58.9 KiB

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