;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019 Meiyo Peng <meiyo.peng@gmail.com>
+;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com>
+;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
+;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
+;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <jannek@gnu.org>
+;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix profiles)
- #:use-module (guix ui)
+ #:use-module ((guix utils) #:select (substitute-keyword-arguments))
+ #:use-module (guix i18n)
+ #:use-module (guix diagnostics)
+ #:use-module (gnu packages admin)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
+ #:use-module (gnu packages compression)
+ #:use-module (gnu packages cross-base)
+ #:use-module (gnu packages cryptsetup)
+ #:use-module (gnu packages disk)
+ #:use-module (gnu packages file-systems)
+ #:use-module (gnu packages firmware)
+ #:use-module (gnu packages gawk)
#:use-module (gnu packages guile)
#:use-module (gnu packages guile-xyz)
- #:use-module (gnu packages admin)
- #:use-module (gnu packages linux)
- #:use-module (gnu packages pciutils)
- #:use-module (gnu packages package-management)
+ #:use-module (gnu packages hurd)
#:use-module (gnu packages less)
- #:use-module (gnu packages zile)
- #:use-module (gnu packages nano)
- #:use-module (gnu packages gawk)
+ #:use-module (gnu packages linux)
#:use-module (gnu packages man)
+ #:use-module (gnu packages nano)
+ #:use-module (gnu packages nvi)
+ #:use-module (gnu packages package-management)
+ #:use-module (gnu packages pciutils)
#:use-module (gnu packages texinfo)
- #:use-module (gnu packages compression)
- #:use-module (gnu packages firmware)
+ #:use-module (gnu packages zile)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu services base)
operating-system-packages
operating-system-host-name
operating-system-hosts-file
+ operating-system-hurd
operating-system-kernel
operating-system-kernel-file
operating-system-kernel-arguments
operating-system-store-file-system
operating-system-user-mapped-devices
operating-system-boot-mapped-devices
+ operating-system-bootloader-crypto-devices
operating-system-activation-script
operating-system-user-accounts
operating-system-shepherd-service-names
operating-system-skeletons
operating-system-sudoers-file
operating-system-swap-devices
+ operating-system-kernel-loadable-modules
+ operating-system-location
operating-system-derivation
operating-system-profile
operating-system-etc-directory
operating-system-locale-directory
operating-system-boot-script
+ operating-system-uuid
system-linux-image-file-name
operating-system-with-gc-roots
operating-system-with-provenance
+ hurd-default-essential-services
+
boot-parameters
boot-parameters?
boot-parameters-label
boot-parameters-root-device
boot-parameters-bootloader-name
boot-parameters-bootloader-menu-entries
+ boot-parameters-store-crypto-devices
boot-parameters-store-device
+ boot-parameters-store-directory-prefix
boot-parameters-store-mount-point
+ boot-parameters-locale
boot-parameters-kernel
boot-parameters-kernel-arguments
boot-parameters-initrd
+ boot-parameters-multiboot-modules
read-boot-parameters
read-boot-parameters-file
boot-parameters->menu-entry
%setuid-programs
%sudoers-specification
%base-packages
- %base-firmware))
+ %base-packages-interactive
+ %base-packages-linux
+ %base-packages-networking
+ %base-packages-disk-utilities
+ %base-packages-utils
+ %base-firmware
+ %default-kernel-arguments))
;;; Commentary:
;;;
(kernel operating-system-kernel ; package
(default linux-libre))
+ (kernel-loadable-modules operating-system-kernel-loadable-modules
+ (default '())) ; list of packages
(kernel-arguments operating-system-user-kernel-arguments
- (default '("quiet"))) ; list of gexps/strings
+ (default %default-kernel-arguments)) ; list of gexps/strings
+ (hurd operating-system-hurd
+ (default #f)) ; package
(bootloader operating-system-bootloader) ; <bootloader-configuration>
(label operating-system-label ; string
(thunked)
(default %setuid-programs)) ; list of string-valued gexps
(sudoers-file operating-system-sudoers-file ; file-like
- (default %sudoers-specification)))
+ (default %sudoers-specification))
+
+ (location operating-system-location ; <location>
+ (default (and=> (current-source-location)
+ source-properties->location))
+ (innate)))
(define (operating-system-kernel-arguments os root-device)
"Return all the kernel arguments, including the ones not specified
;; Because we will use the 'store-device' to create the GRUB search command,
;; the 'store-device' has slightly different semantics than 'root-device'.
;; The 'store-device' can be a file system uuid, a file system label, or #f,
- ;; but it cannot be a device path such as "/dev/sda3", since GRUB would not
- ;; understand that. The 'root-device', on the other hand, corresponds
+ ;; but it cannot be a device file name such as "/dev/sda3", since GRUB would
+ ;; not understand that. The 'root-device', on the other hand, corresponds
;; exactly to the device field of the <file-system> object representing the
- ;; OS's root file system, so it might be a device path like "/dev/sda3".
+ ;; OS's root file system, so it might be a device file name like
+ ;; "/dev/sda3". The 'store-directory-prefix' field contains #f or the store
+ ;; file name inside the 'store-device' as it is seen by GRUB, e.g. it would
+ ;; contain "/storefs" if the store is located in that subvolume of a btrfs
+ ;; partition.
(root-device boot-parameters-root-device)
(bootloader-name boot-parameters-bootloader-name)
(bootloader-menu-entries ;list of <menu-entry>
boot-parameters-bootloader-menu-entries)
(store-device boot-parameters-store-device)
(store-mount-point boot-parameters-store-mount-point)
+ (store-directory-prefix boot-parameters-store-directory-prefix)
+ (store-crypto-devices boot-parameters-store-crypto-devices
+ (default '()))
+ (locale boot-parameters-locale)
(kernel boot-parameters-kernel)
(kernel-arguments boot-parameters-kernel-arguments)
- (initrd boot-parameters-initrd))
+ (initrd boot-parameters-initrd)
+ (multiboot-modules boot-parameters-multiboot-modules))
(define (ensure-not-/dev device)
"If DEVICE starts with a slash, return #f. This is meant to filter out
((? bytevector? bv) ;old format
(bytevector->uuid bv 'dce))
((? string? device)
- ;; It used to be that we would not distinguish between labels and
- ;; device names. Try to infer the right thing here.
- (if (string-prefix? "/dev/" device)
- device
- (file-system-label device)))))
+ (if (string-contains device ":/")
+ device ; nfs-root
+ ;; It used to be that we would not distinguish between labels and
+ ;; device names. Try to infer the right thing here.
+ (if (string-prefix? "/" device)
+ device
+ (file-system-label device))))))
+ (define uuid-sexp->uuid
+ (match-lambda
+ (('uuid (? symbol? type) (? bytevector? bv))
+ (bytevector->uuid bv type))
+ (x
+ (warning (G_ "unrecognized uuid ~a at '~a'~%") x (port-filename port))
+ #f)))
(match (read port)
(('boot-parameters ('version 0)
('label label) ('root-device root)
- ('kernel linux)
+ ('kernel kernel)
rest ...)
(boot-parameters
(label label)
((_ entries) (map sexp->menu-entry entries))
(#f '())))
- ;; In the past, we would store the directory name of the kernel instead
- ;; of the absolute file name of its image. Detect that and correct it.
- (kernel (if (string=? linux (direct-store-path linux))
- (string-append linux "/"
+ ;; In the past, we would store the directory name of linux instead of
+ ;; the absolute file name of its image. Detect that and correct it.
+ (kernel (if (string=? kernel (direct-store-path kernel))
+ (string-append kernel "/"
(system-linux-image-file-name))
- linux))
+ kernel))
(kernel-arguments
(match (assq 'kernel-arguments rest)
(('initrd ('string-append directory file)) ;the old format
(string-append directory file))
(('initrd (? string? file))
- file)))
+ file)
+ (#f #f)))
+
+ (multiboot-modules
+ (match (assq 'multiboot-modules rest)
+ ((_ args) args)
+ (#f '())))
+
+ (locale
+ (match (assq 'locale rest)
+ ((_ locale) locale)
+ (#f #f)))
(store-device
;; Linux device names like "/dev/sda1" are not suitable GRUB device
(_ ;the old format
root-device))))
+ (store-directory-prefix
+ (match (assq 'store rest)
+ (('store . store-data)
+ (match (assq 'directory-prefix store-data)
+ (('directory-prefix prefix) prefix)
+ ;; No directory-prefix found.
+ (_ #f)))
+ (_
+ ;; No store found, old format.
+ #f)))
+
+ (store-crypto-devices
+ (match (assq 'store rest)
+ (('store . store-data)
+ (match (assq 'crypto-devices store-data)
+ (('crypto-devices (devices ...))
+ (map uuid-sexp->uuid devices))
+ (('crypto-devices dev)
+ (warning (G_ "unrecognized crypto-devices ~S at '~a'~%")
+ dev (port-filename port))
+ '())
+ (_
+ ;; No crypto-devices found.
+ '())))
+ (_
+ ;; No store found, old format.
+ '())))
+
(store-mount-point
(match (assq 'store rest)
(('store ('device _) ('mount-point mount-point) _ ...)
(boot-parameters-kernel-arguments params))))))
(define (boot-parameters->menu-entry conf)
- (menu-entry
- (label (boot-parameters-label conf))
- (device (boot-parameters-store-device conf))
- (device-mount-point (boot-parameters-store-mount-point conf))
- (linux (boot-parameters-kernel conf))
- (linux-arguments (boot-parameters-kernel-arguments conf))
- (initrd (boot-parameters-initrd conf))))
-
+ (let* ((kernel (boot-parameters-kernel conf))
+ (multiboot-modules (boot-parameters-multiboot-modules conf))
+ (multiboot? (pair? multiboot-modules)))
+ (menu-entry
+ (label (boot-parameters-label conf))
+ (device (boot-parameters-store-device conf))
+ (device-mount-point (boot-parameters-store-mount-point conf))
+ (linux (and (not multiboot?) kernel))
+ (linux-arguments (if (not multiboot?)
+ (boot-parameters-kernel-arguments conf)
+ '()))
+ (initrd (boot-parameters-initrd conf))
+ (multiboot-kernel (and multiboot? kernel))
+ (multiboot-arguments (if multiboot?
+ (boot-parameters-kernel-arguments conf)
+ '()))
+ (multiboot-modules (if multiboot?
+ (boot-parameters-multiboot-modules conf)
+ '())))))
\f
;;;
(let ((device (file-system-device fs)))
(if (string? device) ;title is 'device
(filter (lambda (md)
- (string=? (string-append "/dev/mapper/"
- (mapped-device-target md))
- device))
+ (any (cut string=? device <>)
+ (map (cut string-append "/dev/mapper" <>)
+ (mapped-device-targets md))))
(operating-system-mapped-devices os))
'())))
(define (mapped-device-users device file-systems)
"Return the subset of FILE-SYSTEMS that use DEVICE."
- (let ((target (string-append "/dev/mapper/" (mapped-device-target device))))
+ (let ((targets (map (cut string-append "/dev/mapper/" <>)
+ (mapped-device-targets device))))
(filter (lambda (fs)
(or (member device (file-system-dependencies fs))
(and (string? (file-system-device fs))
- (string=? (file-system-device fs) target))))
+ (any (cut string=? (file-system-device fs) <>) targets))))
file-systems)))
(define (operating-system-user-mapped-devices os)
(any file-system-needed-for-boot? users)))
devices)))
+(define (operating-system-bootloader-crypto-devices os)
+ "Return the subset of mapped devices that the bootloader must open.
+Only devices specified by uuid are supported."
+ (define (valid-crypto-device? dev)
+ (or (uuid? dev)
+ (begin
+ (warning (G_ "\
+mapped-device '~a' may not be mounted by the bootloader.~%")
+ dev)
+ #f)))
+ (filter-map (match-lambda
+ ((and (= mapped-device-type type)
+ (= mapped-device-source source))
+ (and (eq? luks-device-mapping type)
+ (valid-crypto-device? source)
+ source))
+ (_ #f))
+ ;; XXX: Ordering is important, we trust the returned one.
+ (operating-system-boot-mapped-devices os)))
+
(define (device-mapping-services os)
"Return the list of device-mapping services for OS as a list."
(map device-mapping-service
"Return the list of swap services for OS."
(map swap-service (operating-system-swap-devices os)))
-(define* (system-linux-image-file-name)
- "Return the basename of the kernel image file for SYSTEM."
- ;; FIXME: Evaluate the conditional based on the actual current system.
- (let ((target (or (%current-target-system) (%current-system))))
- (cond
- ((string-prefix? "arm" target) "zImage")
- ((string-prefix? "mips" target) "vmlinuz")
- ((string-prefix? "aarch64" target) "Image")
- (else "bzImage"))))
+(define* (system-linux-image-file-name #:optional
+ (target (or (%current-target-system)
+ (%current-system))))
+ "Return the basename of the kernel image file for TARGET."
+ (cond
+ ((string-prefix? "arm" target) "zImage")
+ ((string-prefix? "mips" target) "vmlinuz")
+ ((string-prefix? "aarch64" target) "Image")
+ (else "bzImage")))
(define (operating-system-kernel-file os)
"Return an object representing the absolute file name of the kernel image of
OS."
- (file-append (operating-system-kernel os)
- "/" (system-linux-image-file-name)))
+ (if (operating-system-hurd os)
+ (file-append (operating-system-kernel os) "/boot/gnumach")
+ (file-append (operating-system-kernel os)
+ "/" (system-linux-image-file-name))))
+
+(define (package-for-kernel target-kernel module-package)
+ "Return a package like MODULE-PACKAGE, adapted for TARGET-KERNEL, if
+possible (that is if there's a LINUX keyword argument in the build system)."
+ (package
+ (inherit module-package)
+ (arguments
+ (substitute-keyword-arguments (package-arguments module-package)
+ ((#:linux kernel #f)
+ target-kernel)))))
+
+(define %default-modprobe-blacklist
+ ;; List of kernel modules to blacklist by default.
+ '("usbmouse" ;races with bcm5974, see <https://bugs.gnu.org/35574>
+ "usbkbd")) ;races with usbhid, see <https://issues.guix.gnu.org/35574#18>
+
+(define %default-kernel-arguments
+ ;; Default arguments passed to the kernel.
+ (list (string-append "modprobe.blacklist="
+ (string-join %default-modprobe-blacklist ","))
+ "quiet"))
(define* (operating-system-directory-base-entries os)
"Return the basic entries of the 'system' directory of OS for use as the
value of the SYSTEM-SERVICE-TYPE service."
- (let ((locale (operating-system-locale-directory os)))
- (mlet %store-monad ((kernel -> (operating-system-kernel os))
- (initrd -> (operating-system-initrd-file os))
- (params (operating-system-boot-parameters-file os)))
- (return `(("kernel" ,kernel)
- ("parameters" ,params)
- ("initrd" ,initrd)
- ("locale" ,locale)))))) ;used by libc
+ (let* ((locale (operating-system-locale-directory os))
+ (kernel (operating-system-kernel os))
+ (hurd (operating-system-hurd os))
+ (modules (operating-system-kernel-loadable-modules os))
+ (kernel (if hurd
+ kernel
+ (profile
+ (content (packages->manifest
+ (cons kernel
+ (map (lambda (module)
+ (if (package? module)
+ (package-for-kernel kernel
+ module)
+ module))
+ modules))))
+ (hooks (list linux-module-database)))))
+ (initrd (and (not hurd) (operating-system-initrd-file os)))
+ (params (operating-system-boot-parameters-file os)))
+ `(("kernel" ,kernel)
+ ,@(if hurd `(("hurd" ,hurd)) '())
+ ("parameters" ,params)
+ ,@(if initrd `(("initrd" ,initrd)) '())
+ ("locale" ,locale)))) ;used by libc
(define (operating-system-default-essential-services os)
"Return the list of essential services for OS. These are special services
(service firmware-service-type
(operating-system-firmware os)))))))
+(define (hurd-default-essential-services os)
+ (let ((entries (operating-system-directory-base-entries os)))
+ (list (service system-service-type entries)
+ %boot-service
+ %hurd-startup-service
+ %activation-service
+ %shepherd-root-service
+ (service user-processes-service-type)
+ (account-service (append (operating-system-accounts os)
+ (operating-system-groups os))
+ (operating-system-skeletons os))
+ (root-file-system-service)
+ (service file-system-service-type '())
+ (service fstab-service-type
+ (filter file-system-needed-for-boot?
+ (operating-system-file-systems os)))
+ (pam-root-service (operating-system-pam-services os))
+ (operating-system-etc-service os)
+ (service setuid-program-service-type
+ (operating-system-setuid-programs os))
+ (service profile-service-type (operating-system-packages os)))))
+
(define* (operating-system-services os)
"Return all the services of OS, including \"essential\" services."
(instantiate-missing-services
gc-root-service-type roots)
(operating-system-user-services os)))))
-(define* (operating-system-with-provenance os #:optional config-file)
+(define (operating-system-configuration-file os)
+ "Return the configuration file of OS, based on its 'location' field, or #f
+if it could not be determined."
+ (let ((file (and=> (operating-system-location os)
+ location-file)))
+ (and file
+ (or (and (string-prefix? "/" file) file)
+ (search-path %load-path file)))))
+
+(define* (operating-system-with-provenance os
+ #:optional
+ (config-file
+ (operating-system-configuration-file
+ os)))
"Return a variant of OS that stores its own provenance information,
including CONFIG-FILE, if available. This is achieved by adding an instance
of PROVENANCE-SERVICE-TYPE to its services."
(list ath9k-htc-firmware
openfwwf-firmware))
+(define %base-packages-utils
+ ;; Default set of utilities packages.
+ (cons* procps psmisc which
+ (@ (gnu packages admin) shadow) ;for 'passwd'
+
+ guile-3.0-latest
+
+ ;; The packages below are also in %FINAL-INPUTS, so take them from
+ ;; there to avoid duplication.
+ (list bash coreutils findutils grep sed
+ diffutils patch gawk tar gzip bzip2 xz lzip)))
+
+(define %base-packages-linux
+ ;; Default set of linux specific packages.
+ (list pciutils usbutils
+ util-linux+udev
+ ;; Get 'insmod' & co. from kmod, not module-init-tools, since udev
+ ;; already depends on it anyway.
+ kmod eudev))
+
+(define %base-packages-interactive
+ ;; Default set of common interactive packages.
+ (list less zile nano
+ nvi
+ man-db
+ info-reader ;the standalone Info reader (no Perl)
+ bash-completion
+ kbd
+ ;; The 'sudo' command is already in %SETUID-PROGRAMS, but we also
+ ;; want the other commands and the man pages (notably because
+ ;; auto-completion in Emacs shell relies on man pages.)
+ sudo
+ guile-readline guile-colorized))
+
+(define %base-packages-networking
+ ;; Default set of networking packages.
+ (list inetutils isc-dhcp
+ iproute
+ ;; wireless-tools is deprecated in favor of iw, but it's still what
+ ;; many people are familiar with, so keep it around.
+ iw wireless-tools))
+
+(define %base-packages-disk-utilities
+ ;; A well-rounded set of packages for interacting with disks, partitions
+ ;; and filesystems.
+ (list parted gptfdisk ddrescue
+ ;; We used to provide fdisk from GNU fdisk, but as of version 2.0.0a
+ ;; it pulls Guile 1.8, which takes unreasonable space; furthermore
+ ;; util-linux's fdisk is already available, in %base-packages-linux.
+ cryptsetup mdadm
+ dosfstools
+ btrfs-progs
+ f2fs-tools
+ jfsutils))
+
(define %base-packages
;; Default set of packages globally visible. It should include anything
;; required for basic administrator tasks.
- (cons* procps psmisc which less zile nano
- pciutils usbutils
- util-linux+udev
- inetutils isc-dhcp
- (@ (gnu packages admin) shadow) ;for 'passwd'
-
- ;; wireless-tools is deprecated in favor of iw, but it's still what
- ;; many people are familiar with, so keep it around.
- iw wireless-tools
-
- iproute
- man-db
- info-reader ;the standalone Info reader (no Perl)
-
- ;; The 'sudo' command is already in %SETUID-PROGRAMS, but we also
- ;; want the other commands and the man pages (notably because
- ;; auto-completion in Emacs shell relies on man pages.)
- sudo
-
- ;; Get 'insmod' & co. from kmod, not module-init-tools, since udev
- ;; already depends on it anyway.
- kmod eudev
-
- e2fsprogs kbd
-
- bash-completion
-
- ;; XXX: We don't use (canonical-package guile-2.2) here because that
- ;; would create a collision in the global profile between the GMP
- ;; variant propagated by 'guile-final' and the GMP variant propagated
- ;; by 'gnutls', itself propagated by 'guix'.
- guile-2.2
- guile-readline guile-colorized
-
- ;; The packages below are also in %FINAL-INPUTS, so take them from
- ;; there to avoid duplication.
- (map canonical-package
- (list bash coreutils findutils grep sed
- diffutils patch gawk tar gzip bzip2 xz lzip))))
+ (append (list e2fsprogs)
+ %base-packages-interactive
+ %base-packages-linux
+ %base-packages-networking
+ %base-packages-utils))
(define %default-issue
;; Default contents for /etc/issue.
"Return the default /etc/hosts file."
(plain-file "hosts" (local-host-aliases host-name)))
+(define (validated-sudoers-file file)
+ "Return a copy of FILE, a sudoers file, after checking that it is
+syntactically correct."
+ (computed-file "sudoers"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+
+ (invoke #+(file-append sudo "/sbin/visudo")
+ "--check" "--file" #$file)
+ (copy-file #$file #$output)))))
+
(define* (operating-system-etc-service os)
- "Return a <service> that builds containing the static part of the /etc
-directory."
- (let ((login.defs
+ "Return a <service> that builds a directory containing the static part of
+the /etc directory."
+ (let* ((login.defs
(plain-file "login.defs"
(string-append
"# Default paths for non-login shells started by su(1).\n"
"/run/current-system/profile/bin:"
"/run/current-system/profile/sbin\n")))
- (issue (plain-file "issue" (operating-system-issue os)))
- (nsswitch (plain-file "nsswitch.conf"
- (name-service-switch->string
- (operating-system-name-service-switch os))))
+ (hurd (operating-system-hurd os))
+ (issue (plain-file "issue" (operating-system-issue os)))
+ (nsswitch (operating-system-name-service-switch os))
+ (nsswitch (and nsswitch
+ (plain-file "nsswitch.conf"
+ (name-service-switch->string nsswitch))))
+ (sudoers (operating-system-sudoers-file os))
;; Startup file for POSIX-compliant login shells, which set system-wide
;; environment variables.
("rpc" ,(file-append net-base "/etc/rpc"))
("login.defs" ,#~#$login.defs)
("issue" ,#~#$issue)
- ("nsswitch.conf" ,#~#$nsswitch)
+ ,@(if nsswitch `(("nsswitch.conf" ,#~#$nsswitch)) '())
("profile" ,#~#$profile)
("bashrc" ,#~#$bashrc)
("hosts" ,#~#$(or (operating-system-hosts-file os)
("timezone" ,(plain-file "timezone" (operating-system-timezone os)))
("localtime" ,(file-append tzdata "/share/zoneinfo/"
(operating-system-timezone os)))
- ("sudoers" ,(operating-system-sudoers-file os))))))
+ ,@(if sudoers
+ `(("sudoers" ,(validated-sudoers-file sudoers)))
+ '())
+ ,@(if hurd
+ `(("login" ,(file-append hurd "/etc/login"))
+ ("motd" ,(file-append hurd "/etc/motd"))
+ ("ttys" ,(file-append hurd "/etc/ttys")))
+ '())))))
(define %root-account
;; Default root account.
;; Default set of setuid-root programs.
(let ((shadow (@ (gnu packages admin) shadow)))
(list (file-append shadow "/bin/passwd")
+ (file-append shadow "/bin/sg")
(file-append shadow "/bin/su")
+ (file-append shadow "/bin/newgrp")
(file-append shadow "/bin/newuidmap")
(file-append shadow "/bin/newgidmap")
(file-append inetutils "/bin/ping")
(define (operating-system-shepherd-service-names os)
"Return the list of Shepherd service names for OS."
(append-map shepherd-service-provision
- (service-value
- (fold-services (operating-system-services os)
- #:target-type
- shepherd-root-service-type))))
+ (shepherd-configuration-services
+ (service-value
+ (fold-services (operating-system-services os)
+ #:target-type
+ shepherd-root-service-type)))))
(define* (operating-system-derivation os)
"Return a derivation that builds OS."
(define (operating-system-root-file-system os)
"Return the root file system of OS."
- (find (lambda (fs)
- (string=? "/" (file-system-mount-point fs)))
- (operating-system-file-systems os)))
+ (or (find (lambda (fs)
+ (string=? "/" (file-system-mount-point fs)))
+ (operating-system-file-systems os))
+ (raise (condition
+ (&message (message "missing root file system"))
+ (&error-location
+ (location (operating-system-location os)))))))
(define (operating-system-initrd-file os)
"Return a gexp denoting the initrd file of OS."
#:mapped-devices mapped-devices
#:keyboard-layout (operating-system-keyboard-layout os)))
+(define* (operating-system-uuid os #:optional (type 'dce))
+ "Compute UUID object with a deterministic \"UUID\" for OS, of the given
+TYPE (one of 'iso9660 or 'dce). Return a UUID object."
+ ;; Note: For this to be deterministic, we must not hash things that contains
+ ;; (directly or indirectly) procedures, for example. That rules out
+ ;; anything that contains gexps, thunk or delayed record fields, etc.
+
+ (define service-name
+ (compose service-type-name service-kind))
+
+ (define (file-system-digest fs)
+ ;; Return a hashable digest that does not contain 'dependencies' since
+ ;; this field can contain procedures.
+ (let ((device (file-system-device fs)))
+ (list (file-system-mount-point fs)
+ (file-system-type fs)
+ (file-system-device->string device)
+ (file-system-options fs))))
+
+ (if (eq? type 'iso9660)
+ (let ((pad (compose (cut string-pad <> 2 #\0)
+ number->string))
+ (h (hash (map service-name (operating-system-services os))
+ 3600)))
+ (bytevector->uuid
+ (string->iso9660-uuid
+ (string-append "1970-01-01-"
+ (pad (hash (operating-system-host-name os) 24)) "-"
+ (pad (quotient h 60)) "-"
+ (pad (modulo h 60)) "-"
+ (pad (hash (map file-system-digest
+ (operating-system-file-systems os))
+ 100))))
+ 'iso9660))
+ (bytevector->uuid
+ (uint-list->bytevector
+ (list (hash (map file-system-digest
+ (operating-system-file-systems os))
+ (- (expt 2 32) 1))
+ (hash (operating-system-host-name os)
+ (- (expt 2 32) 1))
+ (hash (map service-name (operating-system-services os))
+ (- (expt 2 32) 1))
+ (hash (map file-system-digest (operating-system-file-systems os))
+ (- (expt 2 32) 1)))
+ (endianness little)
+ 4)
+ type)))
+
(define (locale-name->definition* name)
"Variant of 'locale-name->definition' that raises an error upon failure."
(match (locale-name->definition name)
(#f
- (raise (condition
- (&message
- (message (format #f (G_ "~a: invalid locale name") name))))))
+ (raise (formatted-message (G_ "~a: invalid locale name") name)))
(def def)))
(define (operating-system-locale-directory os)
(locale-directory definitions
#:libcs (operating-system-locale-libcs os)))
-(define (kernel->boot-label kernel)
+(define* (kernel->boot-label kernel #:key hurd)
"Return a label for the bootloader menu entry that boots KERNEL."
- (cond ((package? kernel)
+ (cond ((package? hurd)
+ (string-append "GNU with the "
+ (string-titlecase (package-name hurd)) " "
+ (package-version hurd)))
+ ((package? kernel)
(string-append "GNU with "
(string-titlecase (package-name kernel)) " "
(package-version kernel)))
(define (operating-system-default-label os)
"Return the default label for OS, as it will appear in the bootloader menu
entry."
- (kernel->boot-label (operating-system-kernel os)))
+ (kernel->boot-label (operating-system-kernel os)
+ #:hurd (operating-system-hurd os)))
(define (store-file-system file-systems)
"Return the file system object among FILE-SYSTEMS that contains the store."
(define* (operating-system-bootcfg os #:optional (old-entries '()))
"Return the bootloader configuration file for OS. Use OLD-ENTRIES,
a list of <menu-entry>, to populate the \"old entries\" menu."
- (let* ((root-fs (operating-system-root-file-system os))
+ (let* ((file-systems (operating-system-file-systems os))
+ (root-fs (operating-system-root-file-system os))
(root-device (file-system-device root-fs))
+ (locale (operating-system-locale os))
+ (crypto-devices (operating-system-bootloader-crypto-devices os))
(params (operating-system-boot-parameters
os root-device
#:system-kernel-arguments? #t))
(entry (boot-parameters->menu-entry params))
(bootloader-conf (operating-system-bootloader os)))
+
(define generate-config-file
(bootloader-configuration-file-generator
(bootloader-configuration-bootloader bootloader-conf)))
(generate-config-file bootloader-conf (list entry)
- #:old-entries old-entries)))
+ #:old-entries old-entries
+ #:locale locale
+ #:store-crypto-devices crypto-devices
+ #:store-directory-prefix
+ (btrfs-store-subvolume-file-name file-systems))))
+
+(define (operating-system-multiboot-modules os)
+ (if (operating-system-hurd os) (hurd-multiboot-modules os) '()))
+
+(define (hurd-multiboot-modules os)
+ (let* ((hurd (operating-system-hurd os))
+ (root-file-system-command
+ (list (file-append hurd "/hurd/ext2fs.static")
+ "ext2fs"
+ "--multiboot-command-line='${kernel-command-line}'"
+ "--host-priv-port='${host-port}'"
+ "--device-master-port='${device-port}'"
+ "--exec-server-task='${exec-task}'"
+ "--store-type=typed"
+ "--x-xattr-translator-records"
+ "'${root}'" "'$(task-create)'" "'$(task-resume)'"))
+ (target (%current-target-system))
+ (libc (if target
+ (with-parameters ((%current-target-system #f))
+ ;; TODO: cross-libc has extra patches for the Hurd;
+ ;; remove in next rebuild cycle
+ (cross-libc target))
+ glibc))
+ (exec-server-command
+ (list (file-append libc "/lib/ld.so.1") "exec"
+ (file-append hurd "/hurd/exec") "'$(exec-task=task-create)'")))
+ (list root-file-system-command exec-server-command)))
(define* (operating-system-boot-parameters os root-device
#:key system-kernel-arguments?)
"Return a monadic <boot-parameters> record that describes the boot
parameters of OS. When SYSTEM-KERNEL-ARGUMENTS? is true, add kernel arguments
such as '--root' and '--load' to <boot-parameters>."
- (let* ((initrd (operating-system-initrd-file os))
+ (let* ((initrd (and (not (operating-system-hurd os))
+ (operating-system-initrd-file os)))
(store (operating-system-store-file-system os))
+ (file-systems (operating-system-file-systems os))
+ (crypto-devices (operating-system-bootloader-crypto-devices os))
+ (locale (operating-system-locale os))
(bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os)))
(bootloader-name (bootloader-name bootloader))
- (label (operating-system-label os)))
+ (label (operating-system-label os))
+ (multiboot-modules (operating-system-multiboot-modules os)))
(boot-parameters
(label label)
(root-device root-device)
(operating-system-kernel-arguments os root-device)
(operating-system-user-kernel-arguments os)))
(initrd initrd)
+ (multiboot-modules multiboot-modules)
(bootloader-name bootloader-name)
(bootloader-menu-entries
(bootloader-configuration-menu-entries (operating-system-bootloader os)))
+ (locale locale)
(store-device (ensure-not-/dev (file-system-device store)))
+ (store-directory-prefix (btrfs-store-subvolume-file-name file-systems))
+ (store-crypto-devices crypto-devices)
(store-mount-point (file-system-mount-point store)))))
(define (device->sexp device)
os device
#:system-kernel-arguments?
system-kernel-arguments?)))
- (gexp->file "parameters"
- #~(boot-parameters
- (version 0)
- (label #$(boot-parameters-label params))
- (root-device
- #$(device->sexp
- (boot-parameters-root-device params)))
- (kernel #$(boot-parameters-kernel params))
- (kernel-arguments
- #$(boot-parameters-kernel-arguments params))
- (initrd #$(boot-parameters-initrd params))
- (bootloader-name #$(boot-parameters-bootloader-name params))
- (bootloader-menu-entries
- #$(map menu-entry->sexp
- (or (and=> (operating-system-bootloader os)
- bootloader-configuration-menu-entries)
- '())))
- (store
- (device
- #$(device->sexp (boot-parameters-store-device params)))
- (mount-point #$(boot-parameters-store-mount-point params))))
- #:set-load-path? #f)))
+ (scheme-file "parameters"
+ #~(boot-parameters
+ (version 0)
+ (label #$(boot-parameters-label params))
+ (root-device
+ #$(device->sexp
+ (boot-parameters-root-device params)))
+ (kernel #$(boot-parameters-kernel params))
+ (kernel-arguments
+ #$(boot-parameters-kernel-arguments params))
+ #$@(if (boot-parameters-initrd params)
+ #~((initrd #$(boot-parameters-initrd params)))
+ #~())
+ #$@(if (pair? (boot-parameters-multiboot-modules params))
+ #~((multiboot-modules
+ #$(boot-parameters-multiboot-modules params)))
+ #~())
+ (bootloader-name #$(boot-parameters-bootloader-name params))
+ (bootloader-menu-entries
+ #$(map menu-entry->sexp
+ (or (and=> (operating-system-bootloader os)
+ bootloader-configuration-menu-entries)
+ '())))
+ (locale #$(boot-parameters-locale params))
+ (store
+ (device
+ #$(device->sexp (boot-parameters-store-device params)))
+ (mount-point #$(boot-parameters-store-mount-point
+ params))
+ (directory-prefix
+ #$(boot-parameters-store-directory-prefix params))
+ (crypto-devices
+ #$(map device->sexp
+ (boot-parameters-store-crypto-devices params)))))
+ #:set-load-path? #f)))
(define-gexp-compiler (operating-system-compiler (os <operating-system>)
system target)
HCoop / jackhill / guix / guix.git / blobdiff