;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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 © 2020 Danny Milosavljevic <dannym@scratchpost.org>
+;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
;;;
;;; This file is part of GNU Guix.
;;;
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu system)
+ #:use-module (guix inferior)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix derivations)
#:use-module (guix profiles)
#:use-module (guix ui)
+ #:use-module (guix utils)
#:use-module (gnu packages base)
#:use-module (gnu packages bash)
#: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 (rnrs bytevectors)
#:export (operating-system
operating-system?
+ this-operating-system
operating-system-bootloader
operating-system-services
+ operating-system-essential-services
+ operating-system-default-essential-services
operating-system-user-services
operating-system-packages
operating-system-host-name
operating-system-kernel
operating-system-kernel-file
operating-system-kernel-arguments
+ operating-system-label
+ operating-system-default-label
operating-system-initrd-modules
operating-system-initrd
operating-system-users
operating-system-user-accounts
operating-system-shepherd-service-names
operating-system-user-kernel-arguments
+ operating-system-firmware
+ operating-system-keyboard-layout
+ operating-system-name-service-switch
+ operating-system-pam-services
+ operating-system-setuid-programs
+ operating-system-skeletons
+ operating-system-sudoers-file
+ operating-system-swap-devices
+ operating-system-kernel-loadable-modules
operating-system-derivation
operating-system-profile
operating-system-boot-script
system-linux-image-file-name
+ operating-system-with-gc-roots
+ operating-system-with-provenance
boot-parameters
boot-parameters?
boot-parameters-label
boot-parameters-root-device
boot-parameters-bootloader-name
+ boot-parameters-bootloader-menu-entries
boot-parameters-store-device
boot-parameters-store-mount-point
boot-parameters-kernel
boot-parameters->menu-entry
local-host-aliases
+ %root-account
%setuid-programs
+ %sudoers-specification
%base-packages
+ %base-packages-interactive
+ %base-packages-linux
+ %base-packages-networking
+ %base-packages-utils
%base-firmware))
;;; Commentary:
(define (bootable-kernel-arguments system root-device)
"Return a list of kernel arguments (gexps) to boot SYSTEM from ROOT-DEVICE."
(list (string-append "--root="
- (cond ((uuid? root-device)
-
- ;; Note: Always use the DCE format because that's
- ;; what (gnu build linux-boot) expects for the
- ;; '--root' kernel command-line option.
- (uuid->string (uuid-bytevector root-device)
- 'dce))
- ((file-system-label? root-device)
- (file-system-label->string root-device))
- (else root-device)))
+ ;; Note: Always use the DCE format because that's what
+ ;; (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")))
(define-record-type* <operating-system> operating-system
make-operating-system
operating-system?
+ this-operating-system
+
(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 '())) ; list of gexps/strings
+ (default '("quiet"))) ; list of gexps/strings
(bootloader operating-system-bootloader) ; <bootloader-configuration>
+ (label operating-system-label ; string
+ (thunked)
+ (default (operating-system-default-label this-operating-system)))
+ (keyboard-layout operating-system-keyboard-layout ;#f | <keyboard-layout>
+ (default #f))
(initrd operating-system-initrd ; (list fs) -> file-like
(default base-initrd))
(initrd-modules operating-system-initrd-modules ; list of strings
(groups operating-system-groups ; list of user groups
(default %base-groups))
- (skeletons operating-system-skeletons ; list of name/monadic value
+ (skeletons operating-system-skeletons ; list of name/file-like value
(default (default-skeletons)))
(issue operating-system-issue ; string
(default %default-issue))
(name-service-switch operating-system-name-service-switch ; <name-service-switch>
(default %default-nss))
- (services operating-system-user-services ; list of monadic services
+ (essential-services operating-system-essential-services ; list of services
+ (thunked)
+ (default (operating-system-default-essential-services
+ this-operating-system)))
+ (services operating-system-user-services ; list of services
(default %base-services))
(pam-services operating-system-pam-services ; list of PAM services
;; OS's root file system, so it might be a device path like "/dev/sda3".
(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)
(kernel boot-parameters-kernel)
((_ args) args)
(#f 'grub))) ; for compatibility reasons.
+ (bootloader-menu-entries
+ (match (assq 'bootloader-menu-entries rest)
+ ((_ 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))
"Return the list of swap services for OS."
(map swap-service (operating-system-swap-devices os)))
-(define* (system-linux-image-file-name #:optional (system (%current-system)))
+(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.
- (cond
- ((string-prefix? "arm" (%current-system)) "zImage")
- ((string-prefix? "mips" (%current-system)) "vmlinuz")
- ((string-prefix? "aarch64" (%current-system)) "Image")
- (else "bzImage")))
+ (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 (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 os)))
-
-(define* (operating-system-directory-base-entries os #:key container?)
+ "/" (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* (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)))
- (with-monad %store-monad
- (if container?
- (return `(("locale" ,locale)))
- (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
-
-(define* (essential-services os #:key container?)
+ (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))
+ (params (operating-system-boot-parameters-file os)))
+ `(("kernel" ,kernel)
+ ("parameters" ,params)
+ ("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
that implement part of what's declared in OS are responsible for low-level
-bookkeeping. CONTAINER? determines whether to return the list of services for
-a container or that of a \"bare metal\" system."
+bookkeeping."
(define known-fs
(map file-system-mount-point (operating-system-file-systems 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 #:container? container?)))
+ (entries (operating-system-directory-base-entries os)))
(cons* (service system-service-type entries)
%boot-service
(operating-system-groups os))
(operating-system-skeletons os))
(operating-system-etc-service os)
- (service fstab-service-type '())
+ (service fstab-service-type
+ (filter file-system-needed-for-boot?
+ (operating-system-file-systems os)))
(session-environment-service
(operating-system-environment-variables os))
host-name procs root-fs
other-fs
(append mappings swaps
- ;; Add the firmware service, unless we are building for a
- ;; container.
- (if container?
- (list %containerized-shepherd-service)
- (list %linux-bare-metal-service
- (service firmware-service-type
- (operating-system-firmware os))))))))
-
-(define* (operating-system-services os #:key container?)
- "Return all the services of OS, including \"internal\" services that do not
-explicitly appear in OS."
+ ;; Add the firmware service.
+ (list %linux-bare-metal-service
+ (service firmware-service-type
+ (operating-system-firmware os)))))))
+
+(define* (operating-system-services os)
+ "Return all the services of OS, including \"essential\" services."
(instantiate-missing-services
(append (operating-system-user-services os)
- (essential-services os #:container? container?))))
+ (operating-system-essential-services os))))
+
+(define (operating-system-with-gc-roots os roots)
+ "Return a variant of OS where ROOTS are registered as GC roots."
+ (operating-system
+ (inherit os)
+
+ ;; We use this procedure for the installation OS, which already defines GC
+ ;; roots. Add ROOTS to those.
+ (services (cons (simple-service 'extra-root
+ gc-root-service-type roots)
+ (operating-system-user-services os)))))
+
+(define* (operating-system-with-provenance os #:optional config-file)
+ "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."
+ (operating-system
+ (inherit os)
+ (services (cons (service provenance-service-type config-file)
+ (operating-system-user-services os)))))
\f
;;;
(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'
+
+ ;; 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
+
+ ;; 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))))
+
+(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
+ 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
;; 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
- 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
- net-tools ; XXX: remove when Inetutils suffices
- 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
-
- ;; 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.
;; to certain networks. Some discussion at
;; https://lists.gnu.org/archive/html/help-guix/2017-09/msg00037.html
("hostname" ,(plain-file "hostname" (operating-system-host-name os)))
+ ;; 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)))
("localtime" ,(file-append tzdata "/share/zoneinfo/"
(operating-system-timezone os)))
("sudoers" ,(operating-system-sudoers-file os))))))
(file-append inetutils "/bin/ping")
(file-append inetutils "/bin/ping6")
(file-append sudo "/bin/sudo")
- (file-append fuse "/bin/fusermount"))))
+ (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"))))
(define %sudoers-specification
;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
root ALL=(ALL) ALL
%wheel ALL=(ALL) ALL\n"))
-(define* (operating-system-activation-script os #:key container?)
+(define* (operating-system-activation-script os)
"Return the activation script for OS---i.e., the code that \"activates\" the
stateful part of OS, including user accounts and groups, special directories,
etc."
- (let* ((services (operating-system-services os #:container? container?))
+ (let* ((services (operating-system-services os))
(activation (fold-services services
#:target-type activation-service-type)))
(activation-service->script activation)))
-(define* (operating-system-boot-script os #:key container?)
+(define* (operating-system-boot-script os)
"Return the boot script for OS---i.e., the code started by the initrd once
-we're running in the final root. When CONTAINER? is true, skip all
-hardware-related operations as necessary when booting a Linux container."
- (let* ((services (operating-system-services os #:container? container?))
+we're running in the final root."
+ (let* ((services (operating-system-services os))
(boot (fold-services services #:target-type boot-service-type)))
(service-value boot)))
#:target-type
shepherd-root-service-type))))
-(define* (operating-system-derivation os #:key container?)
+(define* (operating-system-derivation os)
"Return a derivation that builds OS."
- (let* ((services (operating-system-services os #:container? container?))
+ (let* ((services (operating-system-services os))
(system (fold-services services)))
;; SYSTEM contains the derivation as a monadic value.
(service-value system)))
-(define* (operating-system-profile os #:key container?)
+(define* (operating-system-profile os)
"Return a derivation that builds the system profile of OS."
(mlet* %store-monad
- ((services -> (operating-system-services os #:container? container?))
+ ((services -> (operating-system-services os))
(profile (fold-services services
#:target-type profile-service-type)))
(match profile
(define make-initrd
(operating-system-initrd os))
- (let ((initrd (make-initrd boot-file-systems
- #:linux (operating-system-kernel os)
- #:linux-modules
- (operating-system-initrd-modules os)
- #:mapped-devices mapped-devices)))
- (file-append initrd "/initrd")))
+ (make-initrd boot-file-systems
+ #:linux (operating-system-kernel os)
+ #:linux-modules
+ (operating-system-initrd-modules os)
+ #:mapped-devices mapped-devices
+ #:keyboard-layout (operating-system-keyboard-layout os)))
(define (locale-name->definition* name)
"Variant of 'locale-name->definition' that raises an error upon failure."
(define (kernel->boot-label kernel)
"Return a label for the bootloader menu entry that boots KERNEL."
- (string-append "GNU with "
- (string-titlecase (package-name kernel)) " "
- (package-version kernel)
- " (beta)"))
+ (cond ((package? kernel)
+ (string-append "GNU with "
+ (string-titlecase (package-name kernel)) " "
+ (package-version kernel)))
+ ((inferior-package? kernel)
+ (string-append "GNU with "
+ (string-titlecase (inferior-package-name kernel)) " "
+ (inferior-package-version kernel)))
+ (else "GNU")))
+
+(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)))
(define (store-file-system file-systems)
"Return the file system object among FILE-SYSTEMS that contains the store."
(bootloader (bootloader-configuration-bootloader
(operating-system-bootloader os)))
(bootloader-name (bootloader-name bootloader))
- (label (kernel->boot-label (operating-system-kernel os))))
+ (label (operating-system-label os)))
(boot-parameters
(label label)
(root-device root-device)
(operating-system-user-kernel-arguments os)))
(initrd initrd)
(bootloader-name bootloader-name)
+ (bootloader-menu-entries
+ (bootloader-configuration-menu-entries (operating-system-bootloader os)))
(store-device (ensure-not-/dev (file-system-device store)))
(store-mount-point (file-system-mount-point store)))))
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))
- (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))
+ (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)))
(define-gexp-compiler (operating-system-compiler (os <operating-system>)
system target)