gnu: Add rust-rpassword-4.
[jackhill/guix/guix.git] / gnu / system.scm
index 6bccdaa..107b93d 100644 (file)
@@ -1,10 +1,13 @@
 ;;; 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>
+;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
   #: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
@@ -76,6 +84,8 @@
             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
             local-host-aliases
             %root-account
             %setuid-programs
+            %sudoers-specification
             %base-packages
-            %base-firmware))
+            %base-packages-interactive
+            %base-packages-linux
+            %base-packages-networking
+            %base-packages-utils
+            %base-firmware
+            %default-kernel-arguments))
 
 ;;; 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 %default-kernel-arguments)) ; 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
   (name-service-switch operating-system-name-service-switch ; <name-service-switch>
                        (default %default-nss))
 
+  (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))
 
@@ -233,6 +269,8 @@ directly by the user."
   ;; 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)
@@ -279,6 +317,11 @@ file system labels."
          ((_ 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))
@@ -421,42 +464,70 @@ from the initrd."
   "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 %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)))
-    (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)))
 
@@ -466,8 +537,7 @@ a container or that of a \"bare metal\" system."
          (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
 
@@ -484,7 +554,9 @@ a container or that of a \"bare metal\" system."
                                     (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
@@ -495,20 +567,36 @@ a container or that of a \"bare metal\" system."
            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
 ;;;
@@ -520,48 +608,60 @@ explicitly appear in OS."
   (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.
@@ -694,6 +794,10 @@ fi\n")))
        ;; 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))))))
@@ -795,7 +899,12 @@ use 'plain-file' instead~%")
           (file-append inetutils "/bin/ping6")
           (file-append sudo "/bin/sudo")
           (file-append sudo "/bin/sudoedit")
-          (file-append fuse "/bin/fusermount"))))
+          (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'
@@ -806,20 +915,19 @@ use 'plain-file' instead~%")
 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)))
 
@@ -839,17 +947,17 @@ hardware-related operations as necessary when booting a Linux container."
                               #: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
@@ -878,7 +986,8 @@ hardware-related operations as necessary when booting a Linux container."
                #:linux (operating-system-kernel os)
                #:linux-modules
                (operating-system-initrd-modules os)
-               #:mapped-devices mapped-devices))
+               #: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."
@@ -912,15 +1021,18 @@ listed in OS.  The C library expects to find it under
   (cond ((package? kernel)
          (string-append "GNU with "
                         (string-titlecase (package-name kernel)) " "
-                        (package-version kernel)
-                        " (beta)"))
+                        (package-version kernel)))
         ((inferior-package? kernel)
          (string-append "GNU with "
                         (string-titlecase (inferior-package-name kernel)) " "
-                        (inferior-package-version kernel)
-                        " (beta)"))
+                        (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."
   (match (filter (lambda (fs)
@@ -969,7 +1081,7 @@ such as '--root' and '--load' to <boot-parameters>."
          (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)
@@ -980,6 +1092,8 @@ such as '--root' and '--load' to <boot-parameters>."
           (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)))))
 
@@ -1009,23 +1123,29 @@ being stored into the \"parameters\" file)."
                    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)