;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 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, 2021 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
-;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2020, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <jannek@gnu.org>
+;;; Copyright © 2020, 2022 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework@protonmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (gnu system)
#:use-module (guix inferior)
#:use-module (guix store)
+ #:use-module (guix memoization)
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix records)
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (guix profiles)
+ #:use-module ((guix utils) #:select (substitute-keyword-arguments))
+ #:use-module (guix i18n)
+ #:use-module (guix diagnostics)
#:use-module (guix ui)
- #:use-module (guix utils)
+ #: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 hurd)
- #:use-module (gnu packages linux)
- #:use-module (gnu packages pciutils)
- #:use-module (gnu packages package-management)
#: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 text-editors)
+ #:use-module (gnu packages wget)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu services base)
#:use-module (gnu system locale)
#:use-module (gnu system pam)
#:use-module (gnu system linux-initrd)
+ #:use-module (gnu system setuid)
#:use-module (gnu system uuid)
#:use-module (gnu system file-systems)
#:use-module (gnu system mapped-devices)
+ #:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-71)
#:use-module (rnrs bytevectors)
#:export (operating-system
operating-system?
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-sudoers-file
operating-system-swap-devices
operating-system-kernel-loadable-modules
+ operating-system-location
operating-system-derivation
operating-system-profile
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
+ boot-parameters-version
+ %boot-parameters-version
read-boot-parameters
read-boot-parameters-file
boot-parameters->menu-entry
%setuid-programs
%sudoers-specification
%base-packages
+ %base-packages-artwork
%base-packages-interactive
%base-packages-linux
%base-packages-networking
+ %base-packages-disk-utilities
%base-packages-utils
%base-firmware
%default-kernel-arguments))
;;;
;;; Code:
-(define (bootable-kernel-arguments system root-device)
- "Return a list of kernel arguments (gexps) to boot SYSTEM from ROOT-DEVICE."
- (list (string-append "--root="
+(define* (bootable-kernel-arguments system root-device version)
+ "Return a list of kernel arguments (gexps) to boot SYSTEM from ROOT-DEVICE.
+VERSION is the target version of the boot-parameters record."
+ ;; If the version is newer than 0, we use the new style initrd parameter
+ ;; names, otherwise we use the legacy ones. This is to maintain backward
+ ;; compatibility when producing bootloader configurations for older
+ ;; generations.
+ (define version>0? (> version 0))
+ (list (string-append (if version>0? "root=" "--root=")
;; Note: Always use the DCE format because that's what
- ;; (gnu build linux-boot) expects for the '--root'
+ ;; (gnu build linux-boot) expects for the 'root'
;; kernel command-line option.
(file-system-device->string root-device
#:uuid-type 'dce))
- #~(string-append "--system=" #$system)
- #~(string-append "--load=" #$system "/boot")))
+ #~(string-append (if #$version>0? "gnu.system=" "--system=") #$system)
+ #~(string-append (if #$version>0? "gnu.load=" "--load=")
+ #$system "/boot")))
;; System-wide configuration.
;; TODO: Add per-field docstrings/stexi.
(mapped-devices operating-system-mapped-devices ; list of <mapped-device>
(default '()))
(file-systems operating-system-file-systems) ; list of fs
- (swap-devices operating-system-swap-devices ; list of strings
- (default '()))
+ (swap-devices operating-system-swap-devices ; list of string | <swap-space>
+ (default '())
+ (delayed)
+ (sanitize warn-swap-devices-change))
(users operating-system-users ; list of user accounts
(default %base-user-accounts))
(packages operating-system-packages ; list of (PACKAGE OUTPUT...)
(default %base-packages)) ; or just PACKAGE
- (timezone operating-system-timezone) ; string
+ (timezone operating-system-timezone
+ (default "Etc/UTC")) ; string
(locale operating-system-locale ; string
(default "en_US.utf8"))
(locale-definitions operating-system-locale-definitions ; list of <locale-definition>
(default (operating-system-default-essential-services
this-operating-system)))
(services operating-system-user-services ; list of services
+ (thunked) ;allow for system-dependent services
(default %base-services))
(pam-services operating-system-pam-services ; list of PAM services
(default (base-pam-services)))
(setuid-programs operating-system-setuid-programs
- (default %setuid-programs)) ; list of string-valued gexps
+ (default %setuid-programs) ; list of <setuid-program>
+ (sanitize ensure-setuid-program-list))
(sudoers-file operating-system-sudoers-file ; file-like
- (default %sudoers-specification)))
-
-(define (operating-system-kernel-arguments os root-device)
- "Return all the kernel arguments, including the ones not specified
-directly by the user."
- (append (bootable-kernel-arguments os root-device)
+ (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 #:key (version %boot-parameters-version))
+ "Return all the kernel arguments, including the ones not specified directly
+by the user. VERSION should match that of the target <boot-parameters> record
+object that will contain the kernel parameters."
+ (append (bootable-kernel-arguments os root-device version)
(operating-system-user-kernel-arguments os)))
\f
;;; Boot parameters
;;;
+;;; Version 1 was introduced early 2022 to mark the departure from long option
+;;; names such as '--load' to the more conventional initrd option names like
+;;; 'gnu.load'.
+;;;
+;;; When bumping the boot-parameters version, increment it by one (1).
+(define %boot-parameters-version 1)
+
(define-record-type* <boot-parameters>
boot-parameters make-boot-parameters boot-parameters?
(label boot-parameters-label)
;; 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)
- (multiboot-modules boot-parameters-multiboot-modules))
+ (multiboot-modules boot-parameters-multiboot-modules)
+ (version boot-parameters-version ;positive integer
+ (default %boot-parameters-version)))
(define (ensure-not-/dev device)
"If DEVICE starts with a slash, return #f. This is meant to filter out
(define (read-boot-parameters port)
"Read boot parameters from PORT and return the corresponding
-<boot-parameters> object or #f if the format is unrecognized."
+<boot-parameters> object. Raise an error if the format is unrecognized."
(define device-sexp->device
(match-lambda
(('uuid (? symbol? type) (? bytevector? bv))
((? 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)))
+
+ ;; New versions are not backward-compatible, so only accept past and current
+ ;; versions, not future ones.
+ (define (version? n)
+ (member n (iota (1+ %boot-parameters-version))))
(match (read port)
- (('boot-parameters ('version 0)
+ (('boot-parameters ('version (? version? version))
('label label) ('root-device root)
('kernel kernel)
rest ...)
(boot-parameters
+ (version version)
(label label)
(root-device (device-sexp->device root))
(('initrd ('string-append directory file)) ;the old format
(string-append directory file))
(('initrd (? string? file))
- file)))
+ file)
+ (#f #f)))
- (multiboot-modules (or (assq 'multiboot-modules rest) '()))
+ (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) _ ...)
(_ ;the old format
"/")))))
(x ;unsupported format
- (warning (G_ "unrecognized boot parameters at '~a'~%")
- (port-filename port))
- #f)))
+ (raise
+ (make-compound-condition
+ (formatted-message
+ (G_ "unrecognized boot parameters at '~a'~%")
+ (port-filename port))
+ (condition
+ (&fix-hint (hint (format #f (G_ "This probably means that this version
+of Guix is older than the one that created @file{~a}. To address this, you
+need to update Guix:
+
+@example
+guix pull
+@end example")
+ (port-filename port))))))))))
(define (read-boot-parameters-file system)
"Read boot parameters from SYSTEM's (system or generation) \"parameters\"
The object has its kernel-arguments extended in order to make it bootable."
(let* ((file (string-append system "/parameters"))
(params (call-with-input-file file read-boot-parameters))
- (root (boot-parameters-root-device params)))
+ (root (boot-parameters-root-device params))
+ (version (boot-parameters-version params)))
(boot-parameters
(inherit params)
- (kernel-arguments (append (bootable-kernel-arguments system root)
+ (kernel-arguments (append (bootable-kernel-arguments system root version)
(boot-parameters-kernel-arguments params))))))
(define (boot-parameters->menu-entry conf)
+ "Return a <menu-entry> instance given CONF, a <boot-parameters> instance."
(let* ((kernel (boot-parameters-kernel conf))
(multiboot-modules (boot-parameters-multiboot-modules conf))
(multiboot? (pair? multiboot-modules)))
(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))
'())))
(service file-system-service-type
(map add-dependencies file-systems)))
+(define (boot-file-system-service os)
+ "Return a service which adds, to the system profile, packages providing the
+utilites for the file systems marked as 'needed-for-boot' in OS."
+ (let ((file-systems (filter file-system-needed-for-boot?
+ (operating-system-file-systems os))))
+ (simple-service 'boot-file-system-utilities profile-service-type
+ (file-system-utilities file-systems))))
+
(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
+ (mlambdaq (os) ;to avoid duplicated output
+ "Return the sources of the LUKS mapped devices specified by UUID."
+ ;; XXX: Device ordering is important, we trust the returned one.
+ (let* ((luks-devices (filter (lambda (m)
+ (eq? luks-device-mapping
+ (mapped-device-type m)))
+ (operating-system-boot-mapped-devices os)))
+ (uuid-crypto-devices non-uuid-crypto-devices
+ (partition (compose uuid? mapped-device-source)
+ luks-devices)))
+ (when (not (null? non-uuid-crypto-devices))
+ (for-each (lambda (dev)
+ (warning
+ (source-properties->location (mapped-device-location dev))
+ (G_ "mapped device '~a' may be ignored by bootloader~%")
+ (mapped-device-source dev)))
+ non-uuid-crypto-devices)
+ (display-hint "Specify mapped device sources via their LUKS UUID."))
+ (map mapped-device-source uuid-crypto-devices))))
+
(define (device-mapping-services os)
"Return the list of device-mapping services for OS as a list."
(map device-mapping-service
(operating-system-user-mapped-devices os)))
+(define-syntax-rule (warn-swap-devices-change value)
+ (%warn-swap-devices-change value (current-source-location)))
+
+(define (%warn-swap-devices-change value location)
+ (map (lambda (x)
+ (unless (swap-space? x)
+ (warning
+ (source-properties->location
+ location)
+ (G_ "List elements of the field 'swap-devices' should \
+now use the <swap-space> record, as the old method is deprecated. \
+See \"(guix) operating-system Reference\" for more details.~%")))
+ x) value))
+
(define (swap-services os)
"Return the list of swap services for OS."
- (map swap-service (operating-system-swap-devices os)))
+ (define early-userspace-file-systems
+ (filter file-system-needed-for-boot?
+ (operating-system-file-systems os)))
+
+ (define early-userspace-mapped-devices
+ (operating-system-boot-mapped-devices os))
+
+ (define (filter-deps swap)
+ (if (swap-space? swap)
+ (swap-space
+ (inherit swap)
+ (dependencies (remove (lambda (dep)
+ (or (member dep early-userspace-mapped-devices)
+ (member dep early-userspace-file-systems)))
+ (swap-space-dependencies swap))))
+ swap))
+
+ (map (compose swap-service filter-deps)
+ (operating-system-swap-devices os)))
(define* (system-linux-image-file-name #:optional
(target (or (%current-target-system)
((string-prefix? "arm" target) "zImage")
((string-prefix? "mips" target) "vmlinuz")
((string-prefix? "aarch64" target) "Image")
+ ((string-prefix? "riscv64" target) "Image")
(else "bzImage")))
(define (operating-system-kernel-file os)
(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>
value of the SYSTEM-SERVICE-TYPE service."
(let* ((locale (operating-system-locale-directory os))
(kernel (operating-system-kernel os))
- (modules (operating-system-kernel-loadable-modules os))
- (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 (operating-system-initrd-file os))
+ (hurd (operating-system-hurd os))
+ (initrd (and (not hurd) (operating-system-initrd-file os)))
(params (operating-system-boot-parameters-file os)))
- `(("kernel" ,kernel)
+ `(,@(if hurd
+ `(("hurd" ,hurd)
+ ("kernel" ,kernel))
+ '())
("parameters" ,params)
- ("initrd" ,initrd)
+ ,@(if initrd `(("initrd" ,initrd)) '())
("locale" ,locale)))) ;used by libc
(define (operating-system-default-essential-services os)
(define known-fs
(map file-system-mount-point (operating-system-file-systems os)))
- (let* ((mappings (device-mapping-services os))
- (root-fs (root-file-system-service))
- (other-fs (non-boot-file-system-service os))
- (swaps (swap-services os))
- (procs (service user-processes-service-type))
- (host-name (host-name-service (operating-system-host-name os)))
- (entries (operating-system-directory-base-entries os)))
+ (let* ((mappings (device-mapping-services os))
+ (root-fs (root-file-system-service))
+ (boot-fs (boot-file-system-service os))
+ (non-boot-fs (non-boot-file-system-service os))
+ (swaps (swap-services os))
+ (procs (service user-processes-service-type))
+ (host-name (host-name-service (operating-system-host-name os)))
+ (entries (operating-system-directory-base-entries os)))
(cons* (service system-service-type entries)
+ (service linux-builder-service-type
+ (linux-builder-configuration
+ (kernel (operating-system-kernel os))
+ (modules (operating-system-kernel-loadable-modules os))))
%boot-service
;; %SHEPHERD-ROOT-SERVICE must come last so that the gexp that
(operating-system-setuid-programs os))
(service profile-service-type
(operating-system-packages os))
- other-fs
+ boot-fs non-boot-fs
(append mappings swaps
;; Add the firmware service.
(operating-system-firmware os)))))))
(define (hurd-default-essential-services os)
- (list (service system-service-type '())
- %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 profile-service-type (operating-system-packages os))))
+ (let ((entries (operating-system-directory-base-entries os)))
+ (list (service system-service-type entries)
+ %boot-service
+ %hurd-startup-service
+ %activation-service
+ (service shepherd-root-service-type
+ (shepherd-configuration
+ (shepherd shepherd-0.8))) ;no Fibers
+
+ (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."
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-artwork
+ ;; Default set of artwork packages.
+ (list guix-icons))
+
(define %base-packages-utils
;; Default set of utilities packages.
(cons* procps psmisc which
- (@ (gnu packages admin) shadow) ;for 'passwd'
+ (@ (gnu packages admin) shadow-with-man-pages) ;for 'passwd'
- guile-3.0
+ guile-3.0-latest
;; The packages below are also in %FINAL-INPUTS, so take them from
;; there to avoid duplication.
(define %base-packages-interactive
;; Default set of common interactive packages.
- (list less zile nano
+ (list less mg nano
+ nvi
man-db
info-reader ;the standalone Info reader (no Perl)
bash-completion
;; Default set of networking packages.
(list inetutils isc-dhcp
iproute
+ wget
;; 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, included with the Guix installation
+ ;; image.
+ (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
+ xfsprogs))
+
(define %base-packages
;; Default set of packages globally visible. It should include anything
;; required for basic administrator tasks.
- (append (list e2fsprogs)
+ (append %base-packages-artwork
%base-packages-interactive
%base-packages-linux
%base-packages-networking
"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 (os-release)
+ (plain-file "os-release"
+ "\
+NAME=\"Guix System\"
+ID=guix
+PRETTY_NAME=\"Guix System\"
+LOGO=guix-icon
+HOME_URL=\"https://guix.gnu.org\"
+DOCUMENTATION_URL=\"https://guix.gnu.org/en/manual\"
+SUPPORT_URL=\"https://guix.gnu.org/en/help\"
+BUG_REPORT_URL=\"https://lists.gnu.org/mailman/listinfo/bug-guix\"
+"))
+
(define* (operating-system-etc-service os)
- "Return a <service> that builds containing the static part of the /etc
-directory."
+ "Return a <service> that builds a directory containing the static part of
+the /etc directory."
(let* ((login.defs
(plain-file "login.defs"
(string-append
"/run/current-system/profile/sbin\n"
"ENV_SUPATH /run/setuid-programs:"
"/run/current-system/profile/bin:"
- "/run/current-system/profile/sbin\n")))
+ "/run/current-system/profile/sbin\n"
+
+ "\n"
+ "# Allow 'chfn' to change the full name,\n"
+ "# room number, and so on.\n"
+ "CHFN_RESTRICT frwh\n")))
(hurd (operating-system-hurd os))
(issue (plain-file "issue" (operating-system-issue os)))
source /run/current-system/profile/etc/profile.d/bash_completion.sh
fi\n")))
(etc-service
- `(("services" ,(file-append net-base "/etc/services"))
+ `(("os-release" ,#~#$(os-release))
+ ("services" ,(file-append net-base "/etc/services"))
("protocols" ,(file-append net-base "/etc/protocols"))
("rpc" ,(file-append net-base "/etc/rpc"))
("login.defs" ,#~#$login.defs)
;; Some programs (e.g., GLib) look at /etc/timezone to find the
;; name of the current timezone. For details, see
;; https://lists.gnu.org/archive/html/guix-devel/2019-07/msg00166.html
- ("timezone" ,(plain-file "timezone" (operating-system-timezone os)))
+ ;; Some programs expect a terminating newline.
+ ("timezone" ,(plain-file "timezone"
+ (string-append
+ (string-trim-both
+ (operating-system-timezone os))
+ "\n")))
("localtime" ,(file-append tzdata "/share/zoneinfo/"
(operating-system-timezone os)))
- ,@(if sudoers `(("sudoers" ,sudoers)) '())
+ ,@(if sudoers
+ `(("sudoers" ,(validated-sudoers-file sudoers)))
+ '())
,@(if hurd
`(("login" ,(file-append hurd "/etc/login"))
("motd" ,(file-append hurd "/etc/motd"))
;; TODO: Remove when glibc@2.23 is long gone.
("GUIX_LOCPATH" . "/run/current-system/locale")))
+;; Ensure LST is a list of <setuid-program> records and warn otherwise.
+(define-with-syntax-properties (ensure-setuid-program-list (lst properties))
+ (%ensure-setuid-program-list lst properties))
+
+;; We want to be able to use defines, so define a procedure.
+(define (%ensure-setuid-program-list lst properties)
+ (define warned? #f)
+
+ (define (warn-once)
+ (unless warned?
+ (warning (source-properties->location properties)
+ (G_ "representing setuid programs with file-like objects is \
+deprecated; use 'setuid-program' instead~%"))
+ (set! warned? #t)))
+
+ (map (match-lambda
+ ((? setuid-program? program)
+ program)
+ (program
+ ;; PROGRAM is a file-like or a gexp like #~(string-append #$foo
+ ;; "/bin/bar").
+ (warn-once)
+ (setuid-program (program program))))
+ lst))
+
(define %setuid-programs
;; 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")
- (file-append inetutils "/bin/ping6")
- (file-append sudo "/bin/sudo")
- (file-append sudo "/bin/sudoedit")
- (file-append fuse "/bin/fusermount")
-
- ;; To allow mounts with the "user" option, "mount" and "umount" must
- ;; be setuid-root.
- (file-append util-linux "/bin/mount")
- (file-append util-linux "/bin/umount"))))
+ (map file-like->setuid-program
+ (list (file-append shadow "/bin/passwd")
+ (file-append shadow "/bin/chfn")
+ (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")
+ (file-append inetutils "/bin/ping6")
+ (file-append sudo "/bin/sudo")
+ (file-append sudo "/bin/sudoedit")
+ (file-append fuse "/bin/fusermount")
+ (file-append fuse-3 "/bin/fusermount3")
+
+ ;; To allow mounts with the "user" option, "mount" and "umount" must
+ ;; be setuid-root.
+ (file-append util-linux "/bin/mount")
+ (file-append util-linux "/bin/umount")))))
(define %sudoers-specification
;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
(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."
"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)
(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))
(generate-config-file bootloader-conf (list entry)
#:old-entries old-entries
+ #:locale locale
+ #:store-crypto-devices crypto-devices
#:store-directory-prefix
(btrfs-store-subvolume-file-name file-systems))))
(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 (and (not (hurd-target?))
+parameters of OS. When SYSTEM-KERNEL-ARGUMENTS? is true, add the kernel
+arguments 'root', 'gnu.load' and 'gnu.system' to <boot-parameters>. The
+SYSTEM-KERNEL-ARGUMENTS? should only be used in necessity, as the 'gnu.load'
+and 'gnu.system' values are self-referential (they refer to the system), thus
+susceptible to introduce a cyclic dependency."
+ (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))
(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)
(_
device)))
-(define* (operating-system-boot-parameters-file os
- #:key system-kernel-arguments?)
- "Return a file that describes the boot parameters of OS. The primary use of
-this file is the reconstruction of GRUB menu entries for old configurations.
-
-When SYSTEM-KERNEL-ARGUMENTS? is true, add kernel arguments such as '--root'
-and '--load' to the returned file (since the returned file is then usually
-stored into the content-addressed \"system\" directory, it's usually not a
-good idea to give it because the content hash would change by the content hash
-being stored into the \"parameters\" file)."
+(define* (operating-system-boot-parameters-file os)
+ "Return a file that describes the boot parameters of OS. The primary use
+of this file is the reconstruction of GRUB menu entries for old
+configurations."
(let* ((root (operating-system-root-file-system os))
(device (file-system-device root))
- (params (operating-system-boot-parameters
- os device
- #:system-kernel-arguments?
- system-kernel-arguments?)))
+ (params (operating-system-boot-parameters os device)))
(scheme-file "parameters"
#~(boot-parameters
- (version 0)
+ (version #$(boot-parameters-version params))
(label #$(boot-parameters-label params))
(root-device
#$(device->sexp
(kernel #$(boot-parameters-kernel params))
(kernel-arguments
#$(boot-parameters-kernel-arguments params))
- (initrd #$(boot-parameters-initrd 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))))
+ 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>)
(lambda (store)
;; XXX: This is not super elegant but we can't pass SYSTEM and TARGET to
;; 'operating-system-derivation'.
- (run-with-store store (operating-system-derivation os)
- #:system system
- #:target target)))))
+ (parameterize ((%current-system system)
+ (%current-target-system target))
+ (run-with-store store
+ (mbegin %store-monad
+ (set-guile-for-build (default-guile))
+ (operating-system-derivation os))
+ #:system system
+ #:target target))))))
;;; system.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff