projects/guix·blob version-0.11.0 · refs

779 lines · 30.6 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <[email protected]>
3;;; Copyright © 2015 Mark H Weaver <[email protected]>
4;;; Copyright © 2015, 2016 Alex Kost <[email protected]>
5;;;
6;;; This file is part of GNU Guix.
7;;;
8;;; GNU Guix is free software; you can redistribute it and/or modify it
9;;; under the terms of the GNU General Public License as published by
10;;; the Free Software Foundation; either version 3 of the License, or (at
11;;; your option) any later version.
12;;;
13;;; GNU Guix is distributed in the hope that it will be useful, but
14;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;;; GNU General Public License for more details.
17;;;
18;;; You should have received a copy of the GNU General Public License
19;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20
21(define-module (gnu system)
22 #:use-module (guix store)
23 #:use-module (guix monads)
24 #:use-module (guix gexp)
25 #:use-module (guix records)
26 #:use-module (guix packages)
27 #:use-module (guix derivations)
28 #:use-module (guix profiles)
29 #:use-module (guix ui)
30 #:use-module (gnu packages base)
31 #:use-module (gnu packages bash)
32 #:use-module (gnu packages guile)
33 #:use-module (gnu packages admin)
34 #:use-module (gnu packages linux)
35 #:use-module (gnu packages pciutils)
36 #:use-module (gnu packages package-management)
37 #:use-module (gnu packages less)
38 #:use-module (gnu packages zile)
39 #:use-module (gnu packages nano)
40 #:use-module (gnu packages lsof)
41 #:use-module (gnu packages gawk)
42 #:use-module (gnu packages man)
43 #:use-module (gnu packages texinfo)
44 #:use-module (gnu packages compression)
45 #:use-module (gnu packages firmware)
46 #:use-module (gnu services)
47 #:use-module (gnu services shepherd)
48 #:use-module (gnu services base)
49 #:use-module (gnu system grub)
50 #:use-module (gnu system shadow)
51 #:use-module (gnu system nss)
52 #:use-module (gnu system locale)
53 #:use-module (gnu system pam)
54 #:use-module (gnu system linux-initrd)
55 #:use-module (gnu system file-systems)
56 #:use-module (gnu system mapped-devices)
57 #:use-module (ice-9 match)
58 #:use-module (srfi srfi-1)
59 #:use-module (srfi srfi-26)
60 #:use-module (srfi srfi-34)
61 #:use-module (srfi srfi-35)
62 #:export (operating-system
63 operating-system?
64
65 operating-system-bootloader
66 operating-system-services
67 operating-system-user-services
68 operating-system-packages
69 operating-system-host-name
70 operating-system-hosts-file
71 operating-system-kernel
72 operating-system-kernel-arguments
73 operating-system-initrd
74 operating-system-users
75 operating-system-groups
76 operating-system-issue
77 operating-system-timezone
78 operating-system-locale
79 operating-system-locale-definitions
80 operating-system-locale-libcs
81 operating-system-mapped-devices
82 operating-system-file-systems
83 operating-system-store-file-system
84 operating-system-user-mapped-devices
85 operating-system-boot-mapped-devices
86 operating-system-activation-script
87 operating-system-user-accounts
88 operating-system-shepherd-service-names
89
90 operating-system-derivation
91 operating-system-profile
92 operating-system-grub.cfg
93 operating-system-etc-directory
94 operating-system-locale-directory
95 operating-system-boot-script
96
97 boot-parameters
98 boot-parameters?
99 boot-parameters-label
100 boot-parameters-root-device
101 boot-parameters-kernel
102 boot-parameters-kernel-arguments
103 read-boot-parameters
104
105 local-host-aliases
106 %setuid-programs
107 %base-packages
108 %base-firmware))
109
110;;; Commentary:
111;;;
112;;; This module supports whole-system configuration.
113;;;
114;;; Code:
115
116;; System-wide configuration.
117;; TODO: Add per-field docstrings/stexi.
118(define-record-type* <operating-system> operating-system
119 make-operating-system
120 operating-system?
121 (kernel operating-system-kernel ; package
122 (default linux-libre))
123 (kernel-arguments operating-system-kernel-arguments
124 (default '())) ; list of gexps/strings
125 (bootloader operating-system-bootloader) ; <grub-configuration>
126
127 (initrd operating-system-initrd ; (list fs) -> M derivation
128 (default base-initrd))
129 (firmware operating-system-firmware ; list of packages
130 (default %base-firmware))
131
132 (host-name operating-system-host-name) ; string
133 (hosts-file operating-system-hosts-file ; file-like | #f
134 (default #f))
135
136 (mapped-devices operating-system-mapped-devices ; list of <mapped-device>
137 (default '()))
138 (file-systems operating-system-file-systems) ; list of fs
139 (swap-devices operating-system-swap-devices ; list of strings
140 (default '()))
141
142 (users operating-system-users ; list of user accounts
143 (default %base-user-accounts))
144 (groups operating-system-groups ; list of user groups
145 (default %base-groups))
146
147 (skeletons operating-system-skeletons ; list of name/monadic value
148 (default (default-skeletons)))
149 (issue operating-system-issue ; string
150 (default %default-issue))
151
152 (packages operating-system-packages ; list of (PACKAGE OUTPUT...)
153 (default %base-packages)) ; or just PACKAGE
154
155 (timezone operating-system-timezone) ; string
156 (locale operating-system-locale ; string
157 (default "en_US.utf8"))
158 (locale-definitions operating-system-locale-definitions ; list of <locale-definition>
159 (default %default-locale-definitions))
160 (locale-libcs operating-system-locale-libcs ; list of <packages>
161 (default %default-locale-libcs))
162 (name-service-switch operating-system-name-service-switch ; <name-service-switch>
163 (default %default-nss))
164
165 (services operating-system-user-services ; list of monadic services
166 (default %base-services))
167
168 (pam-services operating-system-pam-services ; list of PAM services
169 (default (base-pam-services)))
170 (setuid-programs operating-system-setuid-programs
171 (default %setuid-programs)) ; list of string-valued gexps
172
173 (sudoers-file operating-system-sudoers-file ; file-like
174 (default %sudoers-specification)))
175
176
177;;;
178;;; Services.
179;;;
180
181(define (other-file-system-services os)
182 "Return file system services for the file systems of OS that are not marked
183as 'needed-for-boot'."
184 (define file-systems
185 (remove file-system-needed-for-boot?
186 (operating-system-file-systems os)))
187
188 (define (device-mappings fs)
189 (let ((device (file-system-device fs)))
190 (if (string? device) ;title is 'device
191 (filter (lambda (md)
192 (string=? (string-append "/dev/mapper/"
193 (mapped-device-target md))
194 device))
195 (operating-system-mapped-devices os))
196 '())))
197
198 (define (add-dependencies fs)
199 ;; Add the dependencies due to device mappings to FS.
200 (file-system
201 (inherit fs)
202 (dependencies
203 (delete-duplicates (append (device-mappings fs)
204 (file-system-dependencies fs))
205 eq?))))
206
207 (map (compose file-system-service add-dependencies) file-systems))
208
209(define (mapped-device-user device file-systems)
210 "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
211 (let ((target (string-append "/dev/mapper/" (mapped-device-target device))))
212 (find (lambda (fs)
213 (or (member device (file-system-dependencies fs))
214 (and (eq? 'device (file-system-title fs))
215 (string=? (file-system-device fs) target))))
216 file-systems)))
217
218(define (operating-system-user-mapped-devices os)
219 "Return the subset of mapped devices that can be installed in
220user-land--i.e., those not needed during boot."
221 (let ((devices (operating-system-mapped-devices os))
222 (file-systems (operating-system-file-systems os)))
223 (filter (lambda (md)
224 (let ((user (mapped-device-user md file-systems)))
225 (or (not user)
226 (not (file-system-needed-for-boot? user)))))
227 devices)))
228
229(define (operating-system-boot-mapped-devices os)
230 "Return the subset of mapped devices that must be installed during boot,
231from the initrd."
232 (let ((devices (operating-system-mapped-devices os))
233 (file-systems (operating-system-file-systems os)))
234 (filter (lambda (md)
235 (let ((user (mapped-device-user md file-systems)))
236 (and user (file-system-needed-for-boot? user))))
237 devices)))
238
239(define (device-mapping-services os)
240 "Return the list of device-mapping services for OS as a list."
241 (map device-mapping-service
242 (operating-system-user-mapped-devices os)))
243
244(define (swap-services os)
245 "Return the list of swap services for OS."
246 (map swap-service (operating-system-swap-devices os)))
247
248(define* (operating-system-directory-base-entries os #:key container?)
249 "Return the basic entries of the 'system' directory of OS for use as the
250value of the SYSTEM-SERVICE-TYPE service."
251 (mlet %store-monad ((locale (operating-system-locale-directory os)))
252 (if container?
253 (return `(("locale" ,locale)))
254 (mlet %store-monad
255 ((kernel -> (operating-system-kernel os))
256 (initrd (operating-system-initrd-file os))
257 (params (operating-system-parameters-file os)))
258 (return `(("kernel" ,kernel)
259 ("parameters" ,params)
260 ("initrd" ,initrd)
261 ("locale" ,locale))))))) ;used by libc
262
263(define* (essential-services os #:key container?)
264 "Return the list of essential services for OS. These are special services
265that implement part of what's declared in OS are responsible for low-level
266bookkeeping. CONTAINER? determines whether to return the list of services for
267a container or that of a \"bare metal\" system."
268 (define known-fs
269 (map file-system-mount-point (operating-system-file-systems os)))
270
271 (let* ((mappings (device-mapping-services os))
272 (root-fs (root-file-system-service))
273 (other-fs (other-file-system-services os))
274 (unmount (user-unmount-service known-fs))
275 (swaps (swap-services os))
276 (procs (user-processes-service
277 (map service-parameters other-fs)))
278 (host-name (host-name-service (operating-system-host-name os)))
279 (entries (operating-system-directory-base-entries
280 os #:container? container?)))
281 (cons* (service system-service-type entries)
282 %boot-service
283
284 ;; %SHEPHERD-ROOT-SERVICE must come first so that the gexp that
285 ;; execs shepherd comes last in the boot script (XXX). Likewise,
286 ;; the cleanup service must come last so that its gexp runs before
287 ;; activation code.
288 %shepherd-root-service
289 %activation-service
290 (service cleanup-service-type #f)
291
292 (pam-root-service (operating-system-pam-services os))
293 (account-service (append (operating-system-accounts os)
294 (operating-system-groups os))
295 (operating-system-skeletons os))
296 (operating-system-etc-service os)
297 (service fstab-service-type '())
298 (session-environment-service
299 (operating-system-environment-variables os))
300 host-name procs root-fs unmount
301 (service setuid-program-service-type
302 (operating-system-setuid-programs os))
303 (service profile-service-type
304 (operating-system-packages os))
305 (append other-fs mappings swaps
306
307 ;; Add the firmware service, unless we are building for a
308 ;; container.
309 (if container?
310 '()
311 (list %linux-bare-metal-service
312 (service firmware-service-type
313 (operating-system-firmware os))))))))
314
315(define* (operating-system-services os #:key container?)
316 "Return all the services of OS, including \"internal\" services that do not
317explicitly appear in OS."
318 (append (operating-system-user-services os)
319 (essential-services os #:container? container?)))
320
321
322;;;
323;;; /etc.
324;;;
325
326(define %base-firmware
327 ;; Firmware usable by default.
328 (list ath9k-htc-firmware))
329
330(define %base-packages
331 ;; Default set of packages globally visible. It should include anything
332 ;; required for basic administrator tasks.
333 (cons* procps psmisc which less zile nano
334 lsof ;for Guix's 'list-runtime-roots'
335 pciutils usbutils
336 util-linux inetutils isc-dhcp
337
338 ;; wireless-tools is deprecated in favor of iw, but it's still what
339 ;; many people are familiar with, so keep it around.
340 iw wireless-tools rfkill
341
342 iproute
343 net-tools ; XXX: remove when Inetutils suffices
344 man-db
345 info-reader ;the standalone Info reader (no Perl)
346
347 ;; The 'sudo' command is already in %SETUID-PROGRAMS, but we also
348 ;; want the other commands and the man pages (notably because
349 ;; auto-completion in Emacs shell relies on man pages.)
350 sudo
351
352 ;; Get 'insmod' & co. from kmod, not module-init-tools, since udev
353 ;; already depends on it anyway.
354 kmod eudev
355
356 e2fsprogs kbd
357
358 bash-completion
359
360 ;; The packages below are also in %FINAL-INPUTS, so take them from
361 ;; there to avoid duplication.
362 (map canonical-package
363 (list guile-2.0 bash coreutils findutils grep sed
364 diffutils patch gawk tar gzip bzip2 xz lzip))))
365
366(define %default-issue
367 ;; Default contents for /etc/issue.
368 "
369This is the GNU system. Welcome.\n")
370
371(define (local-host-aliases host-name)
372 "Return aliases for HOST-NAME, to be used in /etc/hosts."
373 (string-append "127.0.0.1 localhost " host-name "\n"
374 "::1 localhost " host-name "\n"))
375
376(define (default-/etc/hosts host-name)
377 "Return the default /etc/hosts file."
378 (plain-file "hosts" (local-host-aliases host-name)))
379
380(define* (operating-system-etc-service os)
381 "Return a <service> that builds containing the static part of the /etc
382directory."
383 (let ((login.defs (plain-file "login.defs" "# Empty for now.\n"))
384
385 (issue (plain-file "issue" (operating-system-issue os)))
386 (nsswitch (plain-file "nsswitch.conf"
387 (name-service-switch->string
388 (operating-system-name-service-switch os))))
389
390 ;; Startup file for POSIX-compliant login shells, which set system-wide
391 ;; environment variables.
392 (profile (mixed-text-file "profile" "\
393# Crucial variables that could be missing in the profiles' 'etc/profile'
394# because they would require combining both profiles.
395# FIXME: See <http://bugs.gnu.org/20255>.
396export MANPATH=$HOME/.guix-profile/share/man:/run/current-system/profile/share/man
397export INFOPATH=$HOME/.guix-profile/share/info:/run/current-system/profile/share/info
398export XDG_DATA_DIRS=$HOME/.guix-profile/share:/run/current-system/profile/share
399export XDG_CONFIG_DIRS=$HOME/.guix-profile/etc/xdg:/run/current-system/profile/etc/xdg
400
401# Ignore the default value of 'PATH'.
402unset PATH
403
404# Load the system profile's settings.
405GUIX_PROFILE=/run/current-system/profile \\
406. /run/current-system/profile/etc/profile
407
408# Prepend setuid programs.
409export PATH=/run/setuid-programs:$PATH
410
411# Since 'lshd' does not use pam_env, /etc/environment must be explicitly
412# loaded when someone logs in via SSH. See <http://bugs.gnu.org/22175>.
413# We need 'PATH' to be defined here, for 'cat' and 'cut'. Do this before
414# reading the user's 'etc/profile' to allow variables to be overridden.
415if [ -f /etc/environment -a -n \"$SSH_CLIENT\" \\
416 -a -z \"$LINUX_MODULE_DIRECTORY\" ]
417then
418 . /etc/environment
419 export `cat /etc/environment | cut -d= -f1`
420fi
421
422if [ -f \"$HOME/.guix-profile/etc/profile\" ]
423then
424 # Load the user profile's settings.
425 GUIX_PROFILE=\"$HOME/.guix-profile\" \\
426 . \"$HOME/.guix-profile/etc/profile\"
427else
428 # At least define this one so that basic things just work
429 # when the user installs their first package.
430 export PATH=\"$HOME/.guix-profile/bin:$PATH\"
431fi
432
433# Set the umask, notably for users logging in via 'lsh'.
434# See <http://bugs.gnu.org/22650>.
435umask 022
436
437# Allow GStreamer-based applications to find plugins.
438export GST_PLUGIN_PATH=\"$HOME/.guix-profile/lib/gstreamer-1.0\"
439
440if [ -n \"$BASH_VERSION\" -a -f /etc/bashrc ]
441then
442 # Load Bash-specific initialization code.
443 . /etc/bashrc
444fi
445"))
446
447 (bashrc (plain-file "bashrc" "\
448# Bash-specific initialization.
449
450# The 'bash-completion' package.
451if [ -f /run/current-system/profile/etc/profile.d/bash_completion.sh ]
452then
453 # Bash-completion sources ~/.bash_completion. It installs a dynamic
454 # completion loader that searches its own completion files as well
455 # as those in ~/.guix-profile and /run/current-system/profile.
456 source /run/current-system/profile/etc/profile.d/bash_completion.sh
457fi\n")))
458 (etc-service
459 `(("services" ,#~(string-append #$net-base "/etc/services"))
460 ("protocols" ,#~(string-append #$net-base "/etc/protocols"))
461 ("rpc" ,#~(string-append #$net-base "/etc/rpc"))
462 ("login.defs" ,#~#$login.defs)
463 ("issue" ,#~#$issue)
464 ("nsswitch.conf" ,#~#$nsswitch)
465 ("profile" ,#~#$profile)
466 ("bashrc" ,#~#$bashrc)
467 ("hosts" ,#~#$(or (operating-system-hosts-file os)
468 (default-/etc/hosts (operating-system-host-name os))))
469 ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/"
470 #$(operating-system-timezone os)))
471 ("sudoers" ,(operating-system-sudoers-file os))))))
472
473(define %root-account
474 ;; Default root account.
475 (user-account
476 (name "root")
477 (password "")
478 (uid 0) (group "root")
479 (comment "System administrator")
480 (home-directory "/root")))
481
482(define (operating-system-accounts os)
483 "Return the user accounts for OS, including an obligatory 'root' account,
484and excluding accounts requested by services."
485 ;; Make sure there's a root account.
486 (if (find (lambda (user)
487 (and=> (user-account-uid user) zero?))
488 (operating-system-users os))
489 (operating-system-users os)
490 (cons %root-account (operating-system-users os))))
491
492(define (maybe-string->file file-name thing)
493 "If THING is a string, return a <plain-file> with THING as its content.
494Otherwise just return THING.
495
496This is for backward-compatibility of fields that used to be strings and are
497now file-like objects.."
498 (match thing
499 ((? string?)
500 (warning (_ "using a string for file '~a' is deprecated; \
501use 'plain-file' instead~%")
502 file-name)
503 (plain-file file-name thing))
504 (x
505 x)))
506
507(define (maybe-file->monadic file-name thing)
508 "If THING is a value in %STORE-MONAD, return it as is; otherwise return
509THING in the %STORE-MONAD.
510
511This is for backward-compatibility of fields that used to be monadic values
512and are now file-like objects."
513 (with-monad %store-monad
514 (match thing
515 ((? procedure?)
516 (warning (_ "using a monadic value for '~a' is deprecated; \
517use 'plain-file' instead~%")
518 file-name)
519 thing)
520 (x
521 (return x)))))
522
523(define (operating-system-etc-directory os)
524 "Return that static part of the /etc directory of OS."
525 (etc-directory
526 (fold-services (operating-system-services os)
527 #:target-type etc-service-type)))
528
529(define (operating-system-environment-variables os)
530 "Return the environment variables of OS for
531@var{session-environment-service-type}, to be used in @file{/etc/environment}."
532 `(("LANG" . ,(operating-system-locale os))
533 ("TZ" . ,(operating-system-timezone os))
534 ("TZDIR" . ,#~(string-append #$tzdata "/share/zoneinfo"))
535 ;; Tell 'modprobe' & co. where to look for modules.
536 ("LINUX_MODULE_DIRECTORY" . "/run/booted-system/kernel/lib/modules")
537 ;; These variables are honored by OpenSSL (libssl) and Git.
538 ("SSL_CERT_DIR" . "/etc/ssl/certs")
539 ("SSL_CERT_FILE" . "/etc/ssl/certs/ca-certificates.crt")
540 ("GIT_SSL_CAINFO" . "/etc/ssl/certs/ca-certificates.crt")
541
542 ;; 'GTK_DATA_PREFIX' must name one directory where GTK+ themes are
543 ;; searched for.
544 ("GTK_DATA_PREFIX" . "/run/current-system/profile")
545
546 ;; By default, applications that use D-Bus, such as Emacs, abort at startup
547 ;; when /etc/machine-id is missing. Make sure these warnings are non-fatal.
548 ("DBUS_FATAL_WARNINGS" . "0")
549
550 ;; XXX: Normally we wouldn't need to do this, but our [email protected] package
551 ;; looks things up in 'PREFIX/lib/locale' instead of
552 ;; '/run/current-system/locale' as was intended.
553 ("GUIX_LOCPATH" . "/run/current-system/locale")))
554
555(define %setuid-programs
556 ;; Default set of setuid-root programs.
557 (let ((shadow (@ (gnu packages admin) shadow)))
558 (list #~(string-append #$shadow "/bin/passwd")
559 #~(string-append #$shadow "/bin/su")
560 #~(string-append #$inetutils "/bin/ping")
561 #~(string-append #$inetutils "/bin/ping6")
562 #~(string-append #$sudo "/bin/sudo")
563 #~(string-append #$fuse "/bin/fusermount"))))
564
565(define %sudoers-specification
566 ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
567 ;; group can do anything. See
568 ;; <http://www.sudo.ws/sudo/man/1.8.10/sudoers.man.html>.
569 ;; TODO: Add a declarative API.
570 (plain-file "sudoers" "\
571root ALL=(ALL) ALL
572%wheel ALL=(ALL) ALL\n"))
573
574(define* (operating-system-activation-script os #:key container?)
575 "Return the activation script for OS---i.e., the code that \"activates\" the
576stateful part of OS, including user accounts and groups, special directories,
577etc."
578 (let* ((services (operating-system-services os #:container? container?))
579 (activation (fold-services services
580 #:target-type activation-service-type)))
581 (activation-service->script activation)))
582
583(define* (operating-system-boot-script os #:key container?)
584 "Return the boot script for OS---i.e., the code started by the initrd once
585we're running in the final root. When CONTAINER? is true, skip all
586hardware-related operations as necessary when booting a Linux container."
587 (let* ((services (operating-system-services os #:container? container?))
588 (boot (fold-services services #:target-type boot-service-type)))
589 ;; BOOT is the script as a monadic value.
590 (service-parameters boot)))
591
592(define (operating-system-user-accounts os)
593 "Return the list of user accounts of OS."
594 (let* ((services (operating-system-services os))
595 (account (fold-services services
596 #:target-type account-service-type)))
597 (filter user-account?
598 (service-parameters account))))
599
600(define (operating-system-shepherd-service-names os)
601 "Return the list of Shepherd service names for OS."
602 (append-map shepherd-service-provision
603 (service-parameters
604 (fold-services (operating-system-services os)
605 #:target-type
606 shepherd-root-service-type))))
607
608(define* (operating-system-derivation os #:key container?)
609 "Return a derivation that builds OS."
610 (let* ((services (operating-system-services os #:container? container?))
611 (system (fold-services services)))
612 ;; SYSTEM contains the derivation as a monadic value.
613 (service-parameters system)))
614
615(define* (operating-system-profile os #:key container?)
616 "Return a derivation that builds the system profile of OS."
617 (mlet* %store-monad
618 ((services -> (operating-system-services os #:container? container?))
619 (profile (fold-services services
620 #:target-type profile-service-type)))
621 (match profile
622 (("profile" profile)
623 (return profile)))))
624
625(define (operating-system-root-file-system os)
626 "Return the root file system of OS."
627 (find (match-lambda
628 (($ <file-system> _ _ "/") #t)
629 (_ #f))
630 (operating-system-file-systems os)))
631
632(define (operating-system-initrd-file os)
633 "Return a gexp denoting the initrd file of OS."
634 (define boot-file-systems
635 (filter file-system-needed-for-boot?
636 (operating-system-file-systems os)))
637
638 (define mapped-devices
639 (operating-system-boot-mapped-devices os))
640
641 (define make-initrd
642 (operating-system-initrd os))
643
644 (mlet %store-monad ((initrd (make-initrd boot-file-systems
645 #:linux (operating-system-kernel os)
646 #:mapped-devices mapped-devices)))
647 (return #~(string-append #$initrd "/initrd"))))
648
649(define (locale-name->definition* name)
650 "Variant of 'locale-name->definition' that raises an error upon failure."
651 (match (locale-name->definition name)
652 (#f
653 (raise (condition
654 (&message
655 (message (format #f (_ "~a: invalid locale name") name))))))
656 (def def)))
657
658(define (operating-system-locale-directory os)
659 "Return the directory containing the locales compiled for the definitions
660listed in OS. The C library expects to find it under
661/run/current-system/locale."
662 (define name
663 (operating-system-locale os))
664
665 (define definitions
666 ;; While we're at it, check whether NAME is defined and add it if needed.
667 (if (member name (map locale-definition-name
668 (operating-system-locale-definitions os)))
669 (operating-system-locale-definitions os)
670 (cons (locale-name->definition* name)
671 (operating-system-locale-definitions os))))
672
673 (locale-directory definitions
674 #:libcs (operating-system-locale-libcs os)))
675
676(define (kernel->grub-label kernel)
677 "Return a label for the GRUB menu entry that boots KERNEL."
678 (string-append "GNU with "
679 (string-titlecase (package-name kernel)) " "
680 (package-version kernel)
681 " (beta)"))
682
683(define (store-file-system file-systems)
684 "Return the file system object among FILE-SYSTEMS that contains the store."
685 (match (filter (lambda (fs)
686 (and (file-system-mount? fs)
687 (not (memq 'bind-mount (file-system-flags fs)))
688 (string-prefix? (file-system-mount-point fs)
689 (%store-prefix))))
690 file-systems)
691 ((and candidates (head . tail))
692 (reduce (lambda (fs1 fs2)
693 (if (> (string-length (file-system-mount-point fs1))
694 (string-length (file-system-mount-point fs2)))
695 fs1
696 fs2))
697 head
698 candidates))))
699
700(define (operating-system-store-file-system os)
701 "Return the file system that contains the store of OS."
702 (store-file-system (operating-system-file-systems os)))
703
704(define* (operating-system-grub.cfg os #:optional (old-entries '()))
705 "Return the GRUB configuration file for OS. Use OLD-ENTRIES to populate the
706\"old entries\" menu."
707 (mlet* %store-monad
708 ((system (operating-system-derivation os))
709 (root-fs -> (operating-system-root-file-system os))
710 (store-fs -> (operating-system-store-file-system os))
711 (kernel -> (operating-system-kernel os))
712 (root-device -> (if (eq? 'uuid (file-system-title root-fs))
713 (uuid->string (file-system-device root-fs))
714 (file-system-device root-fs)))
715 (entries -> (list (menu-entry
716 (label (kernel->grub-label kernel))
717 (linux kernel)
718 (linux-arguments
719 (cons* (string-append "--root=" root-device)
720 #~(string-append "--system=" #$system)
721 #~(string-append "--load=" #$system
722 "/boot")
723 (operating-system-kernel-arguments os)))
724 (initrd #~(string-append #$system "/initrd"))))))
725 (grub-configuration-file (operating-system-bootloader os)
726 store-fs entries
727 #:old-entries old-entries)))
728
729(define (operating-system-parameters-file os)
730 "Return a file that describes the boot parameters of OS. The primary use of
731this file is the reconstruction of GRUB menu entries for old configurations."
732 (mlet %store-monad ((initrd (operating-system-initrd-file os))
733 (root -> (operating-system-root-file-system os))
734 (label -> (kernel->grub-label
735 (operating-system-kernel os))))
736 (gexp->file "parameters"
737 #~(boot-parameters (version 0)
738 (label #$label)
739 (root-device #$(file-system-device root))
740 (kernel #$(operating-system-kernel os))
741 (kernel-arguments
742 #$(operating-system-kernel-arguments os))
743 (initrd #$initrd))
744 #:set-load-path? #f)))
745
746
747;;;
748;;; Boot parameters
749;;;
750
751(define-record-type* <boot-parameters>
752 boot-parameters make-boot-parameters boot-parameters?
753 (label boot-parameters-label)
754 (root-device boot-parameters-root-device)
755 (kernel boot-parameters-kernel)
756 (kernel-arguments boot-parameters-kernel-arguments))
757
758(define (read-boot-parameters port)
759 "Read boot parameters from PORT and return the corresponding
760<boot-parameters> object or #f if the format is unrecognized."
761 (match (read port)
762 (('boot-parameters ('version 0)
763 ('label label) ('root-device root)
764 ('kernel linux)
765 rest ...)
766 (boot-parameters
767 (label label)
768 (root-device root)
769 (kernel linux)
770 (kernel-arguments
771 (match (assq 'kernel-arguments rest)
772 ((_ args) args)
773 (#f '()))))) ;the old format
774 (x ;unsupported format
775 (warning (_ "unrecognized boot parameters for '~a'~%")
776 system)
777 #f)))
778
779;;; system.scm ends here