projects/guix·blob hurl · refs

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