Merge branch 'master' into core-updates

1 files changed, 131 insertions, 40 deletions

diff --git a/gnu/system.scm b/gnu/system.scm
index cd75e4d4ba..d51691fe76 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -8,6 +8,8 @@
 ;;; 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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -37,9 +39,11 @@
   #:use-module (guix utils)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bash)
+  #:use-module (gnu packages cross-base)
   #: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)
@@ -81,6 +85,7 @@
             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
@@ -126,6 +131,8 @@
             operating-system-with-gc-roots
             operating-system-with-provenance
 
+            hurd-default-essential-services
+
             boot-parameters
             boot-parameters?
             boot-parameters-label
@@ -137,6 +144,7 @@
             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
@@ -183,6 +191,8 @@
                     (default '()))                ; list of packages
   (kernel-arguments operating-system-user-kernel-arguments
                     (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)
@@ -276,7 +286,8 @@ directly by the user."
   (store-mount-point boot-parameters-store-mount-point)
   (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
@@ -307,7 +318,7 @@ file system labels."
   (match (read port)
     (('boot-parameters ('version 0)
                        ('label label) ('root-device root)
-                       ('kernel linux)
+                       ('kernel kernel)
                        rest ...)
      (boot-parameters
       (label label)
@@ -323,12 +334,12 @@ file system labels."
          ((_ 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)
@@ -342,6 +353,8 @@ file system labels."
          (('initrd (? string? file))
           file)))
 
+      (multiboot-modules (or (assq 'multiboot-modules rest) '()))
+
       (store-device
        ;; Linux device names like "/dev/sda1" are not suitable GRUB device
        ;; identifiers, so we just filter them out.
@@ -379,14 +392,25 @@ The object has its kernel-arguments extended in order to make it bootable."
                                (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)
+                            '())))))
 
 
 ;;;
@@ -465,21 +489,23 @@ 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)
-  "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
@@ -573,6 +599,25 @@ bookkeeping."
                          (service firmware-service-type
                                   (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))))
+
 (define* (operating-system-services os)
   "Return all the services of OS, including \"essential\" services."
   (instantiate-missing-services
@@ -676,7 +721,7 @@ This is the GNU system.  Welcome.\n")
 (define* (operating-system-etc-service os)
   "Return a <service> that builds containing the static part of the /etc
 directory."
-  (let ((login.defs
+  (let* ((login.defs
           (plain-file "login.defs"
                       (string-append
                         "# Default paths for non-login shells started by su(1).\n"
@@ -687,10 +732,13 @@ directory."
                         "/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.
@@ -780,7 +828,7 @@ fi\n")))
        ("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)
@@ -796,7 +844,12 @@ fi\n")))
        ("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" ,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.
@@ -1061,9 +1114,13 @@ listed in OS.  The C library expects to find it under
   (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)))
@@ -1076,7 +1133,8 @@ listed in OS.  The C library expects to find it under
 (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."
@@ -1102,31 +1160,63 @@ entry."
 (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))
          (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
+                          #: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"
+                "'${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 (hurd-target?))
+                               (operating-system-initrd-file os)))
          (store           (operating-system-store-file-system 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)
@@ -1136,6 +1226,7 @@ such as '--root' and '--load' to <boot-parameters>."
           (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)))