Merge branch 'master' into staging

6 files changed, 185 insertions, 33 deletions

diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl
index 4f30a5b756..1035ab1d60 100644
--- a/gnu/system/examples/bare-bones.tmpl
+++ b/gnu/system/examples/bare-bones.tmpl
@@ -3,7 +3,7 @@
 
 (use-modules (gnu))
 (use-service-modules networking ssh)
-(use-package-modules screen)
+(use-package-modules screen ssh)
 
 (operating-system
   (host-name "komputilo")
@@ -46,5 +46,6 @@
   (services (append (list (service dhcp-client-service-type)
                           (service openssh-service-type
                                    (openssh-configuration
+                                    (openssh openssh-sans-x)
                                     (port-number 2222))))
                     %base-services)))
diff --git a/gnu/system/examples/bare-hurd.tmpl b/gnu/system/examples/bare-hurd.tmpl
new file mode 100644
index 0000000000..16f20416aa
--- /dev/null
+++ b/gnu/system/examples/bare-hurd.tmpl
@@ -0,0 +1,31 @@
+;; -*-scheme-*-
+
+;; This is an operating system configuration template
+;; for a "bare bones" setup, with no X11 display server.
+
+;; To build a disk image for a virtual machine, do
+;;
+;;     ./pre-inst-env guix system disk-image --target=i586-pc-gnu --no-grafts \
+;;         gnu/system/examples/bare-hurd.tmpl
+;;
+;; it boots, but needs activation, more setup and services to be useful.
+
+(use-modules (gnu) (gnu system hurd) (guix utils))
+
+(define %hurd-os
+  (operating-system
+    (inherit %hurd-default-operating-system)
+    (bootloader (bootloader-configuration
+                 (bootloader grub-minimal-bootloader)
+                 (target "/dev/sdX")))
+    (file-systems (cons (file-system
+                          (device (file-system-label "my-root"))
+                          (mount-point "/")
+                          (type "ext2"))
+                        %base-file-systems))
+    (host-name "guixygnu")
+    (timezone "Europe/Amsterdam")
+    (packages %base-packages/hurd)
+    (services %base-services/hurd)))
+
+%hurd-os
diff --git a/gnu/system/hurd.scm b/gnu/system/hurd.scm
index 3ccf47aa21..956682357e 100644
--- a/gnu/system/hurd.scm
+++ b/gnu/system/hurd.scm
@@ -21,6 +21,7 @@
   #:use-module (guix gexp)
   #:use-module (guix profiles)
   #:use-module (guix utils)
+  #:use-module (gnu bootloader)
   #:use-module (gnu bootloader grub)
   #:use-module (gnu packages admin)
   #:use-module (gnu packages base)
@@ -31,8 +32,18 @@
   #:use-module (gnu packages guile-xyz)
   #:use-module (gnu packages hurd)
   #:use-module (gnu packages less)
+  #:use-module (gnu services)
+  #:use-module (gnu services base)
+  #:use-module (gnu services hurd)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system)
+  #:use-module (gnu system shadow)
   #:use-module (gnu system vm)
-  #:export (cross-hurd-image))
+  #:export (cross-hurd-image
+            %base-packages/hurd
+            %base-services/hurd
+            %hurd-default-operating-system
+            %hurd-default-operating-system-kernel))
 
 ;;; Commentary:
 ;;;
@@ -41,10 +52,58 @@
 ;;;
 ;;; Code:
 
+(define %hurd-default-operating-system-kernel
+  (if (hurd-system?)
+      gnumach
+      ;; A cross-built GNUmach does not work
+      (with-parameters ((%current-system "i686-linux")
+                        (%current-target-system #f))
+        gnumach)))
+
 (define %base-packages/hurd
   (list hurd bash coreutils file findutils grep sed
         guile-3.0 guile-colorized guile-readline
-        net-base inetutils less which))
+        net-base inetutils less shepherd which))
+
+(define %base-services/hurd
+  (list (service hurd-console-service-type
+                 (hurd-console-configuration (hurd hurd)))
+        (service hurd-getty-service-type (hurd-getty-configuration
+                                          (tty "tty1")))
+        (service hurd-getty-service-type (hurd-getty-configuration
+                                          (tty "tty2")))
+        (service static-networking-service-type
+                 (list (static-networking (interface "lo")
+                                          (ip "127.0.0.1")
+                                          (requirement '())
+                                          (provision '(loopback))
+                                          (name-servers '("10.0.2.3")))))
+        (syslog-service)
+        (service guix-service-type
+                 (guix-configuration
+                  (extra-options '("--disable-chroot"
+                                   "--disable-deduplication"))))))
+
+(define %hurd-default-operating-system
+  (operating-system
+    (kernel %hurd-default-operating-system-kernel)
+    (kernel-arguments '())
+    (hurd hurd)
+    (bootloader (bootloader-configuration
+                 (bootloader grub-minimal-bootloader)
+                 (target "/dev/vda")))
+    (initrd (lambda _ '()))
+    (initrd-modules (lambda _ '()))
+    (firmware '())
+    (host-name "guixygnu")
+    (file-systems '())
+    (packages %base-packages/hurd)
+    (timezone "GNUrope")
+    (name-service-switch #f)
+    (essential-services (hurd-default-essential-services this-operating-system))
+    (pam-services '())
+    (setuid-programs '())
+    (sudoers-file #f)))
 
 (define* (cross-hurd-image #:key (hurd hurd) (gnumach gnumach))
   "Return a cross-built GNU/Hurd image."
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index f44886c137..a0e6bf31f1 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -43,6 +43,7 @@
   #:use-module (gnu packages genimage)
   #:use-module (gnu packages guile)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
+  #:use-module (gnu packages hurd)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages mtools)
   #:use-module ((srfi srfi-1) #:prefix srfi-1:)
@@ -54,6 +55,7 @@
   #:export (esp-partition
             root-partition
 
+            hurd-disk-image
             efi-disk-image
             iso9660-image
 
@@ -91,6 +93,26 @@
    (flags '(boot))
    (initializer (gexp initialize-root-partition))))
 
+(define hurd-initialize-root-partition
+  #~(lambda* (#:rest args)
+      (apply initialize-root-partition
+             (append args
+                     (list #:make-device-nodes
+                           make-hurd-device-nodes)))))
+
+(define hurd-disk-image
+  (image
+   (format 'disk-image)
+   (partitions
+    (list (partition
+           (size 'guess)
+           (offset root-offset)
+           (label root-label)
+           (file-system "ext2")
+           (file-system-options '("-o" "hurd" "-O" "ext_attr"))
+           (flags '(boot))
+           (initializer hurd-initialize-root-partition))))))
+
 (define efi-disk-image
   (image
    (format 'disk-image)
@@ -145,12 +167,16 @@
     (with-imported-modules `(,@(source-module-closure
                                 '((gnu build vm)
                                   (gnu build image)
+                                  (gnu build hurd-boot)
+                                  (gnu build linux-boot)
                                   (guix store database))
                                 #:select? not-config?)
                              ((guix config) => ,(make-config.scm)))
       #~(begin
           (use-modules (gnu build vm)
                        (gnu build image)
+                       (gnu build hurd-boot)
+                       (gnu build linux-boot)
                        (guix store database)
                        (guix build utils))
           gexp* ...))))
@@ -525,10 +551,16 @@ image, depending on IMAGE format."
   "Find and return an image that could match the given FILE-SYSTEM-TYPE.  This
 is useful to adapt to interfaces written before the addition of the <image>
 record."
-  (mbegin %store-monad
-    (return
-     (match file-system-type
-       ("iso9660" iso9660-image)
-       (_ efi-disk-image)))))
+  (mlet %store-monad ((target (current-target-system)))
+    (mbegin %store-monad
+      (return
+       (match file-system-type
+         ("iso9660" iso9660-image)
+         (_ (cond
+             ((and target
+                   (hurd-triplet? target))
+              hurd-disk-image)
+             (else
+              efi-disk-image))))))))
 
 ;;; image.scm ends here
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index fe49ffdb94..d0ff2e7c52 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -32,6 +32,7 @@
   #:use-module ((guix packages) #:select (package-version))
   #:use-module ((guix store) #:select (%store-prefix))
   #:use-module (gnu installer)
+  #:use-module (gnu system locale)
   #:use-module (gnu services dbus)
   #:use-module (gnu services networking)
   #:use-module (gnu services shepherd)
@@ -439,10 +440,12 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
           ;; things needed by 'profile-derivation' to minimize the amount of
           ;; download.
           (service gc-root-service-type
-                   (list bare-bones-os
-                         glibc-utf8-locales
-                         texinfo
-                         guile-3.0))
+                   (append
+                    (list bare-bones-os
+                          glibc-utf8-locales
+                          texinfo
+                          guile-3.0)
+                    %default-locale-libcs))
 
           ;; Machines without Kernel Mode Setting (those with many old and
           ;; current AMD GPUs, SiS GPUs, ...) need uvesafb to show the GUI
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 3e483fd86c..686e56348d 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -141,7 +141,7 @@
 
 (define* (expression->derivation-in-linux-vm name exp
                                              #:key
-                                             (system (%current-system)) target
+                                             (system (%current-system))
                                              (linux linux-libre)
                                              initrd
                                              (qemu qemu-minimal)
@@ -226,10 +226,11 @@ substitutable."
 
               (let* ((native-inputs
                       '#+(list qemu (canonical-package coreutils)))
-                     (linux   (string-append #$linux "/"
-                                             #$(system-linux-image-file-name)))
-                     (initrd  #$initrd)
-                     (loader  #$loader)
+                     (linux   (string-append
+                               #+linux "/"
+                               #+(system-linux-image-file-name system)))
+                     (initrd  #+initrd)
+                     (loader  #+loader)
                      (graphs  '#$(match references-graphs
                                    (((graph-files . _) ...) graph-files)
                                    (_ #f)))
@@ -249,8 +250,6 @@ substitutable."
                                   #:memory-size #$memory-size
                                   #:make-disk-image? #$make-disk-image?
                                   #:single-file-output? #$single-file-output?
-                                  #:target-arm32? #$(check target-arm32?)
-                                  #:target-aarch64? #$(check target-aarch64?)
                                   #:disk-image-format #$disk-image-format
                                   #:disk-image-size size
                                   #:references-graphs graphs))))))
@@ -258,7 +257,7 @@ substitutable."
     (gexp->derivation name builder
                       ;; TODO: Require the "kvm" feature.
                       #:system system
-                      #:target target
+                      #:target #f             ;EXP is always executed natively
                       #:env-vars env-vars
                       #:guile-for-build guile-for-build
                       #:references-graphs references-graphs
@@ -318,6 +317,21 @@ system that is passed to 'populate-root-file-system'."
          (local-file (search-path %load-path
                                   "guix/store/schema.sql"))))
 
+  (define preserve-target
+    (if target
+        (lambda (obj)
+          (with-parameters ((%current-target-system target))
+            obj))
+        identity))
+
+  (define inputs*
+    (map (match-lambda
+           ((name thing)
+            `(,name ,(preserve-target thing)))
+           ((name thing output)
+            `(,name ,(preserve-target thing) ,output)))
+         inputs))
+
   (expression->derivation-in-linux-vm
    name
    (with-extensions gcrypt-sqlite3&co
@@ -330,9 +344,10 @@ system that is passed to 'populate-root-file-system'."
        #~(begin
            (use-modules (gnu build bootloader)
                         (gnu build vm)
+                        ((gnu build hurd-boot)
+                         #:select (make-hurd-device-nodes))
                         ((gnu build linux-boot)
-                         #:select (make-essential-device-nodes
-                                   make-hurd-device-nodes))
+                         #:select (make-essential-device-nodes))
                         (guix store database)
                         (guix build utils)
                         (srfi srfi-26)
@@ -346,7 +361,7 @@ system that is passed to 'populate-root-file-system'."
            (setlocale LC_ALL "en_US.utf8")
 
            (let ((inputs
-                  '#$(append (list parted e2fsprogs dosfstools)
+                  '#+(append (list parted e2fsprogs dosfstools)
                              (map canonical-package
                                   (list sed grep coreutils findutils gawk))))
 
@@ -356,7 +371,7 @@ system that is passed to 'populate-root-file-system'."
                   '#$(map (match-lambda
                             ((name thing) thing)
                             ((name thing output) `(,thing ,output)))
-                          inputs)))
+                          inputs*)))
 
              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 
@@ -368,7 +383,7 @@ system that is passed to 'populate-root-file-system'."
                                  #:closures graphs
                                  #:copy-closures? #$copy-inputs?
                                  #:register-closures? #$register-closures?
-                                 #:system-directory #$os
+                                 #:system-directory #$(preserve-target os)
 
                                  #:make-device-nodes
                                  #$(match device-nodes
@@ -423,18 +438,17 @@ system that is passed to 'populate-root-file-system'."
                                      #:partitions partitions
                                      #:grub-efi grub-efi
                                      #:bootloader-package
-                                     #$(bootloader-package bootloader)
-                                     #:bootcfg #$bootcfg-drv
+                                     #+(bootloader-package bootloader)
+                                     #:bootcfg #$(preserve-target bootcfg-drv)
                                      #:bootcfg-location
                                      #$(bootloader-configuration-file bootloader)
                                      #:bootloader-installer
-                                     #$(bootloader-installer bootloader)))))))
+                                     #+(bootloader-installer bootloader)))))))
    #:system system
-   #:target target
    #:make-disk-image? #t
    #:disk-image-size disk-image-size
    #:disk-image-format disk-image-format
-   #:references-graphs inputs
+   #:references-graphs inputs*
    #:substitutable? substitutable?))
 
 (define* (system-docker-image os
@@ -751,6 +765,8 @@ environment with the store shared with the host.  MAPPINGS is a list of
 (define* (system-qemu-image/shared-store
           os
           #:key
+          (system (%current-system))
+          (target (%current-target-system))
           full-boot?
           (disk-image-size (* (if full-boot? 500 30) (expt 2 20))))
   "Return a derivation that builds a QEMU image of OS that shares its store
@@ -771,6 +787,8 @@ bootloader refers to: OS kernel, initrd, bootloader data, etc."
   ;; This is more than needed (we only need the kernel, initrd, GRUB for its
   ;; font, and the background image), but it's hard to filter that.
   (qemu-image #:os os
+              #:system system
+              #:target target
               #:bootcfg-drv bootcfg
               #:bootloader (bootloader-configuration-bootloader
                             (operating-system-bootloader os))
@@ -811,6 +829,8 @@ with '-virtfs' options for the host file systems listed in SHARED-FS."
 
 (define* (system-qemu-image/shared-store-script os
                                                 #:key
+                                                (system (%current-system))
+                                                (target (%current-target-system))
                                                 (qemu qemu)
                                                 (graphic? #t)
                                                 (memory-size 256)
@@ -834,6 +854,8 @@ it is mostly useful when FULL-BOOT?  is true."
   (mlet* %store-monad ((os ->  (virtualized-operating-system os mappings full-boot?))
                        (image  (system-qemu-image/shared-store
                                 os
+                                #:system system
+                                #:target target
                                 #:full-boot? full-boot?
                                 #:disk-image-size disk-image-size)))
     (define kernel-arguments
@@ -841,7 +863,8 @@ it is mostly useful when FULL-BOOT?  is true."
               #+@(operating-system-kernel-arguments os "/dev/vda1")))
 
     (define qemu-exec
-      #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system)))
+      #~(list #+(file-append qemu "/bin/"
+                             (qemu-command (or target system)))
               #$@(if full-boot?
                      #~()
                      #~("-kernel" #$(operating-system-kernel-file os)
@@ -858,7 +881,7 @@ it is mostly useful when FULL-BOOT?  is true."
       #~(call-with-output-file #$output
           (lambda (port)
             (format port "#!~a~% exec ~a \"$@\"~%"
-                    #$(file-append bash "/bin/sh")
+                    #+(file-append bash "/bin/sh")
                     (string-join #$qemu-exec " "))
             (chmod port #o555))))
 
@@ -907,10 +930,11 @@ FORWARDINGS is a list of host-port/guest-port pairs."
 
 (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
                                                 system target)
-  ;; XXX: SYSTEM and TARGET are ignored.
   (match vm
     (($ <virtual-machine> os qemu graphic? memory-size disk-image-size ())
      (system-qemu-image/shared-store-script os
+                                            #:system system
+                                            #:target target
                                             #:qemu qemu
                                             #:graphic? graphic?
                                             #:memory-size memory-size
@@ -923,6 +947,8 @@ FORWARDINGS is a list of host-port/guest-port pairs."
                        "user,model=virtio-net-pci,"
                        (port-forwardings->qemu-options forwardings)))))
        (system-qemu-image/shared-store-script os
+                                              #:system system
+                                              #:target target
                                               #:qemu qemu
                                               #:graphic? graphic?
                                               #:memory-size memory-size