1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
4 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
5 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
6 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
8 ;;; This file is part of GNU Guix.
10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
11 ;;; under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or (at
13 ;;; your option) any later version.
15 ;;; GNU Guix is distributed in the hope that it will be useful, but
16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
23 (define-module (gnu system)
24 #:use-module (guix store)
25 #:use-module (guix monads)
26 #:use-module (guix gexp)
27 #:use-module (guix records)
28 #:use-module (guix packages)
29 #:use-module (guix derivations)
30 #:use-module (guix profiles)
31 #:use-module (guix ui)
32 #:use-module (gnu packages base)
33 #:use-module (gnu packages bash)
34 #:use-module (gnu packages guile)
35 #:use-module (gnu packages admin)
36 #:use-module (gnu packages linux)
37 #:use-module (gnu packages pciutils)
38 #:use-module (gnu packages package-management)
39 #:use-module (gnu packages less)
40 #:use-module (gnu packages zile)
41 #:use-module (gnu packages nano)
42 #:use-module (gnu packages lsof)
43 #:use-module (gnu packages gawk)
44 #:use-module (gnu packages man)
45 #:use-module (gnu packages texinfo)
46 #:use-module (gnu packages compression)
47 #:use-module (gnu packages firmware)
48 #:use-module (gnu services)
49 #:use-module (gnu services shepherd)
50 #:use-module (gnu services base)
51 #:use-module (gnu bootloader)
52 #:use-module (gnu system shadow)
53 #:use-module (gnu system nss)
54 #:use-module (gnu system locale)
55 #:use-module (gnu system pam)
56 #:use-module (gnu system linux-initrd)
57 #:use-module (gnu system file-systems)
58 #:use-module (gnu system mapped-devices)
59 #:use-module (ice-9 match)
60 #:use-module (srfi srfi-1)
61 #:use-module (srfi srfi-26)
62 #:use-module (srfi srfi-34)
63 #:use-module (srfi srfi-35)
64 #:use-module (rnrs bytevectors)
65 #:export (operating-system
68 operating-system-bootloader
69 operating-system-services
70 operating-system-user-services
71 operating-system-packages
72 operating-system-host-name
73 operating-system-hosts-file
74 operating-system-kernel
75 operating-system-kernel-file
76 operating-system-kernel-arguments
77 operating-system-initrd
78 operating-system-users
79 operating-system-groups
80 operating-system-issue
81 operating-system-timezone
82 operating-system-locale
83 operating-system-locale-definitions
84 operating-system-locale-libcs
85 operating-system-mapped-devices
86 operating-system-file-systems
87 operating-system-store-file-system
88 operating-system-user-mapped-devices
89 operating-system-boot-mapped-devices
90 operating-system-activation-script
91 operating-system-user-accounts
92 operating-system-shepherd-service-names
94 operating-system-derivation
95 operating-system-profile
96 operating-system-bootcfg
97 operating-system-etc-directory
98 operating-system-locale-directory
99 operating-system-boot-script
101 system-linux-image-file-name
105 boot-parameters-label
106 boot-parameters-root-device
107 boot-parameters-boot-name
108 boot-parameters-store-device
109 boot-parameters-store-mount-point
110 boot-parameters-kernel
111 boot-parameters-kernel-arguments
112 boot-parameters-initrd
114 read-boot-parameters-file
123 ;;; This module supports whole-system configuration.
127 (define (bootable-kernel-arguments kernel-arguments system.drv root-device)
128 "Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be
129 booted from ROOT-DEVICE"
130 (cons* (string-append "--root=" root-device)
131 #~(string-append "--system=" #$system.drv)
132 #~(string-append "--load=" #$system.drv "/boot")
135 ;; System-wide configuration.
136 ;; TODO: Add per-field docstrings/stexi.
137 (define-record-type* <operating-system> operating-system
138 make-operating-system
140 (kernel operating-system-kernel ; package
141 (default linux-libre))
142 (kernel-arguments operating-system-user-kernel-arguments
143 (default '())) ; list of gexps/strings
144 (bootloader operating-system-bootloader) ; <bootloader-configuration>
146 (initrd operating-system-initrd ; (list fs) -> M derivation
147 (default base-initrd))
148 (firmware operating-system-firmware ; list of packages
149 (default %base-firmware))
151 (host-name operating-system-host-name) ; string
152 (hosts-file operating-system-hosts-file ; file-like | #f
155 (mapped-devices operating-system-mapped-devices ; list of <mapped-device>
157 (file-systems operating-system-file-systems) ; list of fs
158 (swap-devices operating-system-swap-devices ; list of strings
161 (users operating-system-users ; list of user accounts
162 (default %base-user-accounts))
163 (groups operating-system-groups ; list of user groups
164 (default %base-groups))
166 (skeletons operating-system-skeletons ; list of name/monadic value
167 (default (default-skeletons)))
168 (issue operating-system-issue ; string
169 (default %default-issue))
171 (packages operating-system-packages ; list of (PACKAGE OUTPUT...)
172 (default %base-packages)) ; or just PACKAGE
174 (timezone operating-system-timezone) ; string
175 (locale operating-system-locale ; string
176 (default "en_US.utf8"))
177 (locale-definitions operating-system-locale-definitions ; list of <locale-definition>
178 (default %default-locale-definitions))
179 (locale-libcs operating-system-locale-libcs ; list of <packages>
180 (default %default-locale-libcs))
181 (name-service-switch operating-system-name-service-switch ; <name-service-switch>
182 (default %default-nss))
184 (services operating-system-user-services ; list of monadic services
185 (default %base-services))
187 (pam-services operating-system-pam-services ; list of PAM services
188 (default (base-pam-services)))
189 (setuid-programs operating-system-setuid-programs
190 (default %setuid-programs)) ; list of string-valued gexps
192 (sudoers-file operating-system-sudoers-file ; file-like
193 (default %sudoers-specification)))
195 (define (operating-system-kernel-arguments os system.drv root-device)
196 "Return all the kernel arguments, including the ones not specified
197 directly by the user."
198 (bootable-kernel-arguments (operating-system-user-kernel-arguments os)
207 (define-record-type* <boot-parameters>
208 boot-parameters make-boot-parameters boot-parameters?
209 (label boot-parameters-label)
210 ;; Because we will use the 'store-device' to create the GRUB search command,
211 ;; the 'store-device' has slightly different semantics than 'root-device'.
212 ;; The 'store-device' can be a file system uuid, a file system label, or #f,
213 ;; but it cannot be a device path such as "/dev/sda3", since GRUB would not
214 ;; understand that. The 'root-device', on the other hand, corresponds
215 ;; exactly to the device field of the <file-system> object representing the
216 ;; OS's root file system, so it might be a device path like "/dev/sda3".
217 (root-device boot-parameters-root-device)
218 (boot-name boot-parameters-boot-name)
219 (store-device boot-parameters-store-device)
220 (store-mount-point boot-parameters-store-mount-point)
221 (kernel boot-parameters-kernel)
222 (kernel-arguments boot-parameters-kernel-arguments)
223 (initrd boot-parameters-initrd))
225 (define (read-boot-parameters port)
226 "Read boot parameters from PORT and return the corresponding
227 <boot-parameters> object or #f if the format is unrecognized."
229 (('boot-parameters ('version 0)
230 ('label label) ('root-device root)
238 (match (assq 'boot-name rest)
240 (#f 'grub))) ; for compatibility reasons.
242 ;; In the past, we would store the directory name of the kernel instead
243 ;; of the absolute file name of its image. Detect that and correct it.
244 (kernel (if (string=? linux (direct-store-path linux))
245 (string-append linux "/"
246 (system-linux-image-file-name))
250 (match (assq 'kernel-arguments rest)
252 (#f '()))) ;the old format
255 (match (assq 'initrd rest)
256 (('initrd ('string-append directory file)) ;the old format
257 (string-append directory file))
258 (('initrd (? string? file))
262 (match (assq 'store rest)
263 (('store ('device device) _ ...)
266 ;; Root might be a device path like "/dev/sda1", which is not a
267 ;; suitable GRUB device identifier.
268 (if (string-prefix? "/" root)
273 (match (assq 'store rest)
274 (('store ('device _) ('mount-point mount-point) _ ...)
278 (x ;unsupported format
279 (warning (G_ "unrecognized boot parameters for '~a'~%")
283 (define (read-boot-parameters-file system)
284 "Read boot parameters from SYSTEM's (system or generation) \"parameters\"
285 file and returns the corresponding <boot-parameters> object or #f if the
286 format is unrecognized.
287 The object has its kernel-arguments extended in order to make it bootable."
288 (let* ((file (string-append system "/parameters"))
289 (params (call-with-input-file file read-boot-parameters))
290 (root (boot-parameters-root-device params))
291 (root-device (if (bytevector? root)
294 (kernel-arguments (boot-parameters-kernel-arguments params)))
298 (kernel-arguments (bootable-kernel-arguments kernel-arguments
307 (define (non-boot-file-system-service os)
308 "Return the file system service for the file systems of OS that are not
309 marked as 'needed-for-boot'."
311 (remove file-system-needed-for-boot?
312 (operating-system-file-systems os)))
314 (define (device-mappings fs)
315 (let ((device (file-system-device fs)))
316 (if (string? device) ;title is 'device
318 (string=? (string-append "/dev/mapper/"
319 (mapped-device-target md))
321 (operating-system-mapped-devices os))
324 (define (add-dependencies fs)
325 ;; Add the dependencies due to device mappings to FS.
329 (delete-duplicates (append (device-mappings fs)
330 (file-system-dependencies fs))
333 (service file-system-service-type
334 (map add-dependencies file-systems)))
336 (define (mapped-device-user device file-systems)
337 "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
338 (let ((target (string-append "/dev/mapper/" (mapped-device-target device))))
340 (or (member device (file-system-dependencies fs))
341 (and (eq? 'device (file-system-title fs))
342 (string=? (file-system-device fs) target))))
345 (define (operating-system-user-mapped-devices os)
346 "Return the subset of mapped devices that can be installed in
347 user-land--i.e., those not needed during boot."
348 (let ((devices (operating-system-mapped-devices os))
349 (file-systems (operating-system-file-systems os)))
351 (let ((user (mapped-device-user md file-systems)))
353 (not (file-system-needed-for-boot? user)))))
356 (define (operating-system-boot-mapped-devices os)
357 "Return the subset of mapped devices that must be installed during boot,
359 (let ((devices (operating-system-mapped-devices os))
360 (file-systems (operating-system-file-systems os)))
362 (let ((user (mapped-device-user md file-systems)))
363 (and user (file-system-needed-for-boot? user))))
366 (define (device-mapping-services os)
367 "Return the list of device-mapping services for OS as a list."
368 (map device-mapping-service
369 (operating-system-user-mapped-devices os)))
371 (define (swap-services os)
372 "Return the list of swap services for OS."
373 (map swap-service (operating-system-swap-devices os)))
375 (define* (system-linux-image-file-name #:optional (system (%current-system)))
376 "Return the basename of the kernel image file for SYSTEM."
377 ;; FIXME: Evaluate the conditional based on the actual current system.
379 ((string-prefix? "arm" (%current-system)) "zImage")
380 ((string-prefix? "mips" (%current-system)) "vmlinuz")
383 (define (operating-system-kernel-file os)
384 "Return an object representing the absolute file name of the kernel image of
386 (file-append (operating-system-kernel os)
387 "/" (system-linux-image-file-name os)))
389 (define* (operating-system-directory-base-entries os #:key container?)
390 "Return the basic entries of the 'system' directory of OS for use as the
391 value of the SYSTEM-SERVICE-TYPE service."
392 (mlet %store-monad ((locale (operating-system-locale-directory os)))
394 (return `(("locale" ,locale)))
396 ((kernel -> (operating-system-kernel os))
397 (initrd (operating-system-initrd-file os))
398 (params (operating-system-boot-parameters-file os)))
399 (return `(("kernel" ,kernel)
400 ("parameters" ,params)
402 ("locale" ,locale))))))) ;used by libc
404 (define* (essential-services os #:key container?)
405 "Return the list of essential services for OS. These are special services
406 that implement part of what's declared in OS are responsible for low-level
407 bookkeeping. CONTAINER? determines whether to return the list of services for
408 a container or that of a \"bare metal\" system."
410 (map file-system-mount-point (operating-system-file-systems os)))
412 (let* ((mappings (device-mapping-services os))
413 (root-fs (root-file-system-service))
414 (other-fs (non-boot-file-system-service os))
415 (unmount (user-unmount-service known-fs))
416 (swaps (swap-services os))
417 (procs (user-processes-service))
418 (host-name (host-name-service (operating-system-host-name os)))
419 (entries (operating-system-directory-base-entries
420 os #:container? container?)))
421 (cons* (service system-service-type entries)
424 ;; %SHEPHERD-ROOT-SERVICE must come first so that the gexp that
425 ;; execs shepherd comes last in the boot script (XXX). Likewise,
426 ;; the cleanup service must come last so that its gexp runs before
428 %shepherd-root-service
430 (service cleanup-service-type #f)
432 (pam-root-service (operating-system-pam-services os))
433 (account-service (append (operating-system-accounts os)
434 (operating-system-groups os))
435 (operating-system-skeletons os))
436 (operating-system-etc-service os)
437 (service fstab-service-type '())
438 (session-environment-service
439 (operating-system-environment-variables os))
440 host-name procs root-fs unmount
441 (service setuid-program-service-type
442 (operating-system-setuid-programs os))
443 (service profile-service-type
444 (operating-system-packages os))
446 (append mappings swaps
448 ;; Add the firmware service, unless we are building for a
452 (list %linux-bare-metal-service
453 (service firmware-service-type
454 (operating-system-firmware os))))))))
456 (define* (operating-system-services os #:key container?)
457 "Return all the services of OS, including \"internal\" services that do not
458 explicitly appear in OS."
459 (append (operating-system-user-services os)
460 (essential-services os #:container? container?)))
467 (define %base-firmware
468 ;; Firmware usable by default.
469 (list ath9k-htc-firmware
472 (define %base-packages
473 ;; Default set of packages globally visible. It should include anything
474 ;; required for basic administrator tasks.
475 (cons* procps psmisc which less zile nano
476 lsof ;for Guix's 'list-runtime-roots'
478 util-linux inetutils isc-dhcp
480 ;; wireless-tools is deprecated in favor of iw, but it's still what
481 ;; many people are familiar with, so keep it around.
482 iw wireless-tools rfkill
485 net-tools ; XXX: remove when Inetutils suffices
487 info-reader ;the standalone Info reader (no Perl)
489 ;; The 'sudo' command is already in %SETUID-PROGRAMS, but we also
490 ;; want the other commands and the man pages (notably because
491 ;; auto-completion in Emacs shell relies on man pages.)
494 ;; Get 'insmod' & co. from kmod, not module-init-tools, since udev
495 ;; already depends on it anyway.
502 ;; The packages below are also in %FINAL-INPUTS, so take them from
503 ;; there to avoid duplication.
504 (map canonical-package
505 (list guile-2.0 bash coreutils-8.27 findutils grep sed
506 diffutils patch gawk tar gzip bzip2 xz lzip))))
508 (define %default-issue
509 ;; Default contents for /etc/issue.
511 This is the GNU system. Welcome.\n")
513 (define (local-host-aliases host-name)
514 "Return aliases for HOST-NAME, to be used in /etc/hosts."
515 (string-append "127.0.0.1 localhost " host-name "\n"
516 "::1 localhost " host-name "\n"))
518 (define (default-/etc/hosts host-name)
519 "Return the default /etc/hosts file."
520 (plain-file "hosts" (local-host-aliases host-name)))
522 (define* (operating-system-etc-service os)
523 "Return a <service> that builds containing the static part of the /etc
525 (let ((login.defs (plain-file "login.defs" "# Empty for now.\n"))
527 (issue (plain-file "issue" (operating-system-issue os)))
528 (nsswitch (plain-file "nsswitch.conf"
529 (name-service-switch->string
530 (operating-system-name-service-switch os))))
532 ;; Startup file for POSIX-compliant login shells, which set system-wide
533 ;; environment variables.
534 (profile (mixed-text-file "profile" "\
535 # Crucial variables that could be missing in the profiles' 'etc/profile'
536 # because they would require combining both profiles.
537 # FIXME: See <http://bugs.gnu.org/20255>.
538 export MANPATH=$HOME/.guix-profile/share/man:/run/current-system/profile/share/man
539 export INFOPATH=$HOME/.guix-profile/share/info:/run/current-system/profile/share/info
540 export XDG_DATA_DIRS=$HOME/.guix-profile/share:/run/current-system/profile/share
541 export XDG_CONFIG_DIRS=$HOME/.guix-profile/etc/xdg:/run/current-system/profile/etc/xdg
543 # Ignore the default value of 'PATH'.
546 # Load the system profile's settings.
547 GUIX_PROFILE=/run/current-system/profile \\
548 . /run/current-system/profile/etc/profile
550 # Prepend setuid programs.
551 export PATH=/run/setuid-programs:$PATH
553 # Since 'lshd' does not use pam_env, /etc/environment must be explicitly
554 # loaded when someone logs in via SSH. See <http://bugs.gnu.org/22175>.
555 # We need 'PATH' to be defined here, for 'cat' and 'cut'. Do this before
556 # reading the user's 'etc/profile' to allow variables to be overridden.
557 if [ -f /etc/environment -a -n \"$SSH_CLIENT\" \\
558 -a -z \"$LINUX_MODULE_DIRECTORY\" ]
561 export `cat /etc/environment | cut -d= -f1`
564 if [ -f \"$HOME/.guix-profile/etc/profile\" ]
566 # Load the user profile's settings.
567 GUIX_PROFILE=\"$HOME/.guix-profile\" \\
568 . \"$HOME/.guix-profile/etc/profile\"
570 # At least define this one so that basic things just work
571 # when the user installs their first package.
572 export PATH=\"$HOME/.guix-profile/bin:$PATH\"
575 # Set the umask, notably for users logging in via 'lsh'.
576 # See <http://bugs.gnu.org/22650>.
579 # Allow GStreamer-based applications to find plugins.
580 export GST_PLUGIN_PATH=\"$HOME/.guix-profile/lib/gstreamer-1.0\"
582 if [ -n \"$BASH_VERSION\" -a -f /etc/bashrc ]
584 # Load Bash-specific initialization code.
589 (bashrc (plain-file "bashrc" "\
590 # Bash-specific initialization.
592 # The 'bash-completion' package.
593 if [ -f /run/current-system/profile/etc/profile.d/bash_completion.sh ]
595 # Bash-completion sources ~/.bash_completion. It installs a dynamic
596 # completion loader that searches its own completion files as well
597 # as those in ~/.guix-profile and /run/current-system/profile.
598 source /run/current-system/profile/etc/profile.d/bash_completion.sh
601 `(("services" ,(file-append net-base "/etc/services"))
602 ("protocols" ,(file-append net-base "/etc/protocols"))
603 ("rpc" ,(file-append net-base "/etc/rpc"))
604 ("login.defs" ,#~#$login.defs)
606 ("nsswitch.conf" ,#~#$nsswitch)
607 ("profile" ,#~#$profile)
608 ("bashrc" ,#~#$bashrc)
609 ("hosts" ,#~#$(or (operating-system-hosts-file os)
610 (default-/etc/hosts (operating-system-host-name os))))
611 ("localtime" ,(file-append tzdata "/share/zoneinfo/"
612 (operating-system-timezone os)))
613 ("sudoers" ,(operating-system-sudoers-file os))))))
615 (define %root-account
616 ;; Default root account.
620 (uid 0) (group "root")
621 (comment "System administrator")
622 (home-directory "/root")))
624 (define (operating-system-accounts os)
625 "Return the user accounts for OS, including an obligatory 'root' account,
626 and excluding accounts requested by services."
627 ;; Make sure there's a root account.
628 (if (find (lambda (user)
629 (and=> (user-account-uid user) zero?))
630 (operating-system-users os))
631 (operating-system-users os)
632 (cons %root-account (operating-system-users os))))
634 (define (maybe-string->file file-name thing)
635 "If THING is a string, return a <plain-file> with THING as its content.
636 Otherwise just return THING.
638 This is for backward-compatibility of fields that used to be strings and are
639 now file-like objects.."
642 (warning (G_ "using a string for file '~a' is deprecated; \
643 use 'plain-file' instead~%")
645 (plain-file file-name thing))
649 (define (maybe-file->monadic file-name thing)
650 "If THING is a value in %STORE-MONAD, return it as is; otherwise return
651 THING in the %STORE-MONAD.
653 This is for backward-compatibility of fields that used to be monadic values
654 and are now file-like objects."
655 (with-monad %store-monad
658 (warning (G_ "using a monadic value for '~a' is deprecated; \
659 use 'plain-file' instead~%")
665 (define (operating-system-etc-directory os)
666 "Return that static part of the /etc directory of OS."
668 (fold-services (operating-system-services os)
669 #:target-type etc-service-type)))
671 (define (operating-system-environment-variables os)
672 "Return the environment variables of OS for
673 @var{session-environment-service-type}, to be used in @file{/etc/environment}."
674 `(("LANG" . ,(operating-system-locale os))
675 ("TZ" . ,(operating-system-timezone os))
676 ("TZDIR" . ,(file-append tzdata "/share/zoneinfo"))
677 ;; Tell 'modprobe' & co. where to look for modules.
678 ("LINUX_MODULE_DIRECTORY" . "/run/booted-system/kernel/lib/modules")
679 ;; These variables are honored by OpenSSL (libssl) and Git.
680 ("SSL_CERT_DIR" . "/etc/ssl/certs")
681 ("SSL_CERT_FILE" . "/etc/ssl/certs/ca-certificates.crt")
682 ("GIT_SSL_CAINFO" . "/etc/ssl/certs/ca-certificates.crt")
684 ;; 'GTK_DATA_PREFIX' must name one directory where GTK+ themes are
686 ("GTK_DATA_PREFIX" . "/run/current-system/profile")
688 ;; By default, applications that use D-Bus, such as Emacs, abort at startup
689 ;; when /etc/machine-id is missing. Make sure these warnings are non-fatal.
690 ("DBUS_FATAL_WARNINGS" . "0")
692 ;; XXX: Normally we wouldn't need to do this, but our glibc@2.23 package
693 ;; used to look things up in 'PREFIX/lib/locale' instead of
694 ;; '/run/current-system/locale' as was intended. Keep this hack around so
695 ;; that people who still have glibc@2.23-using packages in their profiles
696 ;; can use them correctly.
697 ;; TODO: Remove when glibc@2.23 is long gone.
698 ("GUIX_LOCPATH" . "/run/current-system/locale")))
700 (define %setuid-programs
701 ;; Default set of setuid-root programs.
702 (let ((shadow (@ (gnu packages admin) shadow)))
703 (list (file-append shadow "/bin/passwd")
704 (file-append shadow "/bin/su")
705 (file-append inetutils "/bin/ping")
706 (file-append inetutils "/bin/ping6")
707 (file-append sudo "/bin/sudo")
708 (file-append fuse "/bin/fusermount"))))
710 (define %sudoers-specification
711 ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
712 ;; group can do anything. See
713 ;; <http://www.sudo.ws/sudo/man/1.8.10/sudoers.man.html>.
714 ;; TODO: Add a declarative API.
715 (plain-file "sudoers" "\
717 %wheel ALL=(ALL) ALL\n"))
719 (define* (operating-system-activation-script os #:key container?)
720 "Return the activation script for OS---i.e., the code that \"activates\" the
721 stateful part of OS, including user accounts and groups, special directories,
723 (let* ((services (operating-system-services os #:container? container?))
724 (activation (fold-services services
725 #:target-type activation-service-type)))
726 (activation-service->script activation)))
728 (define* (operating-system-boot-script os #:key container?)
729 "Return the boot script for OS---i.e., the code started by the initrd once
730 we're running in the final root. When CONTAINER? is true, skip all
731 hardware-related operations as necessary when booting a Linux container."
732 (let* ((services (operating-system-services os #:container? container?))
733 (boot (fold-services services #:target-type boot-service-type)))
734 ;; BOOT is the script as a monadic value.
735 (service-value boot)))
737 (define (operating-system-user-accounts os)
738 "Return the list of user accounts of OS."
739 (let* ((services (operating-system-services os))
740 (account (fold-services services
741 #:target-type account-service-type)))
742 (filter user-account?
743 (service-value account))))
745 (define (operating-system-shepherd-service-names os)
746 "Return the list of Shepherd service names for OS."
747 (append-map shepherd-service-provision
749 (fold-services (operating-system-services os)
751 shepherd-root-service-type))))
753 (define* (operating-system-derivation os #:key container?)
754 "Return a derivation that builds OS."
755 (let* ((services (operating-system-services os #:container? container?))
756 (system (fold-services services)))
757 ;; SYSTEM contains the derivation as a monadic value.
758 (service-value system)))
760 (define* (operating-system-profile os #:key container?)
761 "Return a derivation that builds the system profile of OS."
763 ((services -> (operating-system-services os #:container? container?))
764 (profile (fold-services services
765 #:target-type profile-service-type)))
770 (define (operating-system-root-file-system os)
771 "Return the root file system of OS."
773 (($ <file-system> device title "/") #t)
775 (operating-system-file-systems os)))
777 (define (operating-system-initrd-file os)
778 "Return a gexp denoting the initrd file of OS."
779 (define boot-file-systems
780 (filter file-system-needed-for-boot?
781 (operating-system-file-systems os)))
783 (define mapped-devices
784 (operating-system-boot-mapped-devices os))
787 (operating-system-initrd os))
789 (mlet %store-monad ((initrd (make-initrd boot-file-systems
790 #:linux (operating-system-kernel os)
791 #:mapped-devices mapped-devices)))
792 (return (file-append initrd "/initrd"))))
794 (define (locale-name->definition* name)
795 "Variant of 'locale-name->definition' that raises an error upon failure."
796 (match (locale-name->definition name)
800 (message (format #f (G_ "~a: invalid locale name") name))))))
803 (define (operating-system-locale-directory os)
804 "Return the directory containing the locales compiled for the definitions
805 listed in OS. The C library expects to find it under
806 /run/current-system/locale."
808 (operating-system-locale os))
811 ;; While we're at it, check whether NAME is defined and add it if needed.
812 (if (member name (map locale-definition-name
813 (operating-system-locale-definitions os)))
814 (operating-system-locale-definitions os)
815 (cons (locale-name->definition* name)
816 (operating-system-locale-definitions os))))
818 (locale-directory definitions
819 #:libcs (operating-system-locale-libcs os)))
821 (define (kernel->boot-label kernel)
822 "Return a label for the bootloader menu entry that boots KERNEL."
823 (string-append "GNU with "
824 (string-titlecase (package-name kernel)) " "
825 (package-version kernel)
828 (define (store-file-system file-systems)
829 "Return the file system object among FILE-SYSTEMS that contains the store."
830 (match (filter (lambda (fs)
831 (and (file-system-mount? fs)
832 (not (memq 'bind-mount (file-system-flags fs)))
833 (string-prefix? (file-system-mount-point fs)
836 ((and candidates (head . tail))
837 (reduce (lambda (fs1 fs2)
838 (if (> (string-length (file-system-mount-point fs1))
839 (string-length (file-system-mount-point fs2)))
845 (define (operating-system-store-file-system os)
846 "Return the file system that contains the store of OS."
847 (store-file-system (operating-system-file-systems os)))
849 (define* (operating-system-bootcfg os #:optional (old-entries '()))
850 "Return the bootloader configuration file for OS. Use OLD-ENTRIES to
851 populate the \"old entries\" menu."
853 ((system (operating-system-derivation os))
854 (root-fs -> (operating-system-root-file-system os))
855 (root-device -> (if (eq? 'uuid (file-system-title root-fs))
856 (uuid->string (file-system-device root-fs))
857 (file-system-device root-fs)))
858 (entry (operating-system-boot-parameters os system root-device))
859 (bootloader-conf -> (operating-system-bootloader os)))
860 ((bootloader-configuration-file-generator
861 (bootloader-configuration-bootloader bootloader-conf))
862 bootloader-conf (list entry) #:old-entries old-entries)))
864 (define (fs->boot-device fs)
865 "Given FS, a <file-system> object, return a value suitable for use as the
866 device in a <menu-entry>."
867 (case (file-system-title fs)
868 ((uuid) (file-system-device fs))
869 ((label) (file-system-device fs))
872 (define (operating-system-boot-parameters os system.drv root-device)
873 "Return a monadic <boot-parameters> record that describes the boot parameters
874 of OS. SYSTEM.DRV is either a derivation or #f. If it's a derivation, adds
875 kernel arguments for that derivation to <boot-parameters>."
877 ((initrd (operating-system-initrd-file os))
878 (store -> (operating-system-store-file-system os))
879 (bootloader -> (bootloader-configuration-bootloader
880 (operating-system-bootloader os)))
881 (boot-name -> (bootloader-name bootloader))
882 (label -> (kernel->boot-label (operating-system-kernel os))))
883 (return (boot-parameters
885 (root-device root-device)
886 (kernel (operating-system-kernel-file os))
889 (operating-system-kernel-arguments os system.drv root-device)
890 (operating-system-user-kernel-arguments os)))
892 (boot-name boot-name)
893 (store-device (fs->boot-device store))
894 (store-mount-point (file-system-mount-point store))))))
896 (define* (operating-system-boot-parameters-file os #:optional (system.drv #f))
897 "Return a file that describes the boot parameters of OS. The primary use of
898 this file is the reconstruction of GRUB menu entries for old configurations.
899 SYSTEM.DRV is optional. If given, adds kernel arguments for that system to the
900 returned file (since the returned file is then usually stored into the
901 content-addressed \"system\" directory, it's usually not a good idea
902 to give it because the content hash would change by the content hash
903 being stored into the \"parameters\" file)."
904 (mlet* %store-monad ((root -> (operating-system-root-file-system os))
905 (device -> (file-system-device root))
906 (params (operating-system-boot-parameters os
909 (gexp->file "parameters"
912 (label #$(boot-parameters-label params))
913 (root-device #$(boot-parameters-root-device params))
914 (kernel #$(boot-parameters-kernel params))
916 #$(boot-parameters-kernel-arguments params))
917 (initrd #$(boot-parameters-initrd params))
918 (boot-name #$(boot-parameters-boot-name params))
920 (device #$(boot-parameters-store-device params))
921 (mount-point #$(boot-parameters-store-mount-point params))))
922 #:set-load-path? #f)))
924 ;;; system.scm ends here