Merge branch 'master' into staging

5 files changed, 222 insertions, 36 deletions

diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index 30f5e87d5a..b915e6bb67 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -320,7 +320,9 @@ improvement."
 
 (define (boot-time-system)
   "Return the '--system' argument passed on the kernel command line."
-  (find-long-option "--system" (linux-command-line)))
+  (find-long-option "--system" (if (string-contains %host-type "linux-gnu")
+                                   linux-command-line
+                                   (command-line))))
 
 (define* (activate-current-system
           #:optional (system (or (getenv "GUIX_NEW_SYSTEM")
diff --git a/gnu/build/hurd-boot.scm b/gnu/build/hurd-boot.scm
new file mode 100644
index 0000000000..09326233d2
--- /dev/null
+++ b/gnu/build/hurd-boot.scm
@@ -0,0 +1,205 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu build hurd-boot)
+  #:use-module (system repl error-handling)
+  #:autoload   (system repl repl) (start-repl)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:use-module (guix build utils)
+  #:use-module ((guix build syscalls)
+                #:hide (file-system-type))
+  #:export (make-hurd-device-nodes
+            boot-hurd-system))
+
+;;; Commentary:
+;;;
+;;; Utility procedures useful to boot a Hurd system.
+;;;
+;;; Code:
+
+;; XXX FIXME c&p from linux-boot.scm
+(define (find-long-option option arguments)
+  "Find OPTION among ARGUMENTS, where OPTION is something like \"--load\".
+Return the value associated with OPTION, or #f on failure."
+  (let ((opt (string-append option "=")))
+    (and=> (find (cut string-prefix? opt <>)
+                 arguments)
+           (lambda (arg)
+             (substring arg (+ 1 (string-index arg #\=)))))))
+
+;; XXX FIXME c&p from guix/utils.scm
+(define (readlink* file)
+  "Call 'readlink' until the result is not a symlink."
+  (define %max-symlink-depth 50)
+
+  (let loop ((file  file)
+             (depth 0))
+    (define (absolute target)
+      (if (absolute-file-name? target)
+          target
+          (string-append (dirname file) "/" target)))
+
+    (if (>= depth %max-symlink-depth)
+        file
+        (call-with-values
+            (lambda ()
+              (catch 'system-error
+                (lambda ()
+                  (values #t (readlink file)))
+                (lambda args
+                  (let ((errno (system-error-errno args)))
+                    (if (or (= errno EINVAL))
+                        (values #f file)
+                        (apply throw args))))))
+          (lambda (success? target)
+            (if success?
+                (loop (absolute target) (+ depth 1))
+                file))))))
+
+(define* (make-hurd-device-nodes #:optional (root "/"))
+  "Make some of the nodes needed on GNU/Hurd."
+  (define (scope dir)
+    (string-append root (if (string-suffix? "/" root) "" "/") dir))
+
+  (mkdir (scope "dev"))
+  (for-each (lambda (file)
+              (call-with-output-file (scope file)
+                (lambda (port)
+                  (display file port)   ;avoid hard-linking
+                  (chmod port #o666))))
+            '("dev/null"
+              "dev/zero"
+              "dev/full"
+              "dev/random"
+              "dev/urandom"))
+  ;; Don't create /dev/console, /dev/vcs, etc.: they are created by
+  ;; console-run on first boot.
+
+  (mkdir (scope "servers"))
+  (for-each (lambda (file)
+              (call-with-output-file (scope (string-append "servers/" file))
+                (lambda (port)
+                  (display file port)   ;avoid hard-linking
+                  (chmod port #o444))))
+            '("startup"
+              "exec"
+              "proc"
+              "password"
+              "default-pager"
+              "crash-dump-core"
+              "kill"
+              "suspend"))
+
+  (mkdir (scope "servers/socket"))
+  ;; Don't create /servers/socket/1 & co: runsystem does that on first boot.
+
+  ;; TODO: Set the 'gnu.translator' extended attribute for passive translator
+  ;; settings?
+  )
+
+
+(define* (boot-hurd-system #:key (on-error 'debug))
+  "This procedure is meant to be called from an early RC script.
+
+Install the relevant passive translators on the first boot.  Then, run system
+activation by using the kernel command-line options '--system' and '--load';
+starting the Shepherd.
+
+XXX TODO: see linux-boot.scm:boot-system.
+XXX TODO: add proper file-system checking, mounting
+XXX TODO: move bits to (new?) (hurd?) (activation?) services
+XXX TODO: use settrans/setxattr instead of MAKEDEV
+
+"
+  (define translators
+    '(("/servers/crash-dump-core" ("/hurd/crash" "--dump-core"))
+      ("/servers/crash-kill" ("/hurd/crash" "--kill"))
+      ("/servers/crash-suspend" ("/hurd/crash" "--suspend"))
+      ("/servers/password" ("/hurd/password"))
+      ("/servers/socket/1" ("/hurd/pflocal"))
+      ("/servers/socket/2" ("/hurd/pfinet" "--interface" "eth0"
+                            "--address" "10.0.2.15" ;the default QEMU guest IP
+                            "--netmask" "255.255.255.0"
+                            "--gateway" "10.0.2.2"
+                            "--ipv6" "/servers/socket/16"))))
+
+  (display "Welcome, this is GNU's early boot Guile.\n")
+  (display "Use '--repl' for an initrd REPL.\n\n")
+
+  (call-with-error-handling
+   (lambda ()
+
+     (define (translated? node)
+       ;; Return true if a translator is installed on NODE.
+       (with-output-to-port (%make-void-port "w")
+         (lambda ()
+           (with-error-to-port (%make-void-port "w")
+             (lambda ()
+               (zero? (system* "showtrans" "--silent" node)))))))
+
+     (let* ((args    (command-line))
+            (system  (find-long-option "--system" args))
+            (to-load (find-long-option "--load" args)))
+
+       (format #t "Creating essential servers...\n")
+       (setenv "PATH" (string-append system "/profile/bin"
+                                     ":" system "/profile/sbin"))
+       (for-each (match-lambda
+                   ((node command)
+                    (unless (translated? node)
+                      (mkdir-p (dirname node))
+                      (apply invoke "settrans" "--create" node command))))
+                 translators)
+
+       (format #t "Creating essential device nodes...\n")
+       (with-directory-excursion "/dev"
+         (invoke "MAKEDEV" "--devdir=/dev" "std")
+         (invoke "MAKEDEV" "--devdir=/dev" "vcs")
+         (invoke "MAKEDEV" "--devdir=/dev" "tty1""tty2" "tty3" "tty4" "tty5" "tty6")
+         (invoke "MAKEDEV" "--devdir=/dev" "ptyp0" "ptyp1" "ptyp2")
+         (invoke "MAKEDEV" "--devdir=/dev" "console"))
+
+       (false-if-exception (delete-file "/hurd"))
+       (let ((hurd/hurd (readlink* (string-append system "/profile/hurd"))))
+         (symlink hurd/hurd "/hurd"))
+
+       (format #t "Starting pager...\n")
+       (unless (zero? (system* "/hurd/mach-defpager"))
+         (format #t "FAILED...Good luck!\n"))
+
+       (cond ((member "--repl" args)
+              (format #t "Starting repl...\n")
+              (start-repl))
+             (to-load
+              (format #t "loading '~a'...\n" to-load)
+              (primitive-load to-load)
+              (format (current-error-port)
+                      "boot program '~a' terminated, rebooting~%"
+                      to-load)
+              (sleep 2)
+              (reboot))
+             (else
+              (display "no boot file passed via '--load'\n")
+              (display "entering a warm and cozy REPL\n")
+              (start-repl)))))
+   #:on-error on-error))
+
+;;; hurd-boot.scm ends here
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index 14503b02ba..fb85bd4bb8 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -161,6 +161,8 @@ deduplicates files common to CLOSURE and the rest of PREFIX."
                                     references-graphs
                                     (register-closures? #t)
                                     system-directory
+                                    (make-device-nodes
+                                     make-essential-device-nodes)
                                     #:allow-other-keys)
   "Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to
 install the bootloader configuration.
@@ -172,6 +174,9 @@ of the directory of the 'system' derivation."
   (populate-root-file-system system-directory root)
   (populate-store references-graphs root)
 
+  ;; Populate /dev.
+  (make-device-nodes root)
+
   (when register-closures?
     (for-each (lambda (closure)
                 (register-closure root
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index f08bb11514..80fe0cfb9d 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -40,7 +40,6 @@
             find-long-option
             find-long-options
             make-essential-device-nodes
-            make-hurd-device-nodes
             make-static-device-nodes
             configure-qemu-networking
 
@@ -324,36 +323,6 @@ one specific hardware device. These we have to create."
   ;; File systems in user space (FUSE).
   (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229)))
 
-(define* (make-hurd-device-nodes #:optional (root "/"))
-  "Make some of the nodes needed on GNU/Hurd."
-  (define (scope dir)
-    (string-append root
-                   (if (string-suffix? "/" root)
-                       ""
-                       "/")
-                   dir))
-
-  (mkdir (scope "dev"))
-  (for-each (lambda (file)
-              (call-with-output-file (scope file)
-                (lambda (port)
-                  (chmod port #o666))))
-            '("dev/null"
-              "dev/zero"
-              "dev/full"
-              "dev/random"
-              "dev/urandom"))
-  ;; Don't create /dev/console, /dev/vcs, etc.: they are created by
-  ;; console-run on first boot.
-
-  (mkdir (scope "servers"))
-  (mkdir (scope "servers/socket"))
-  ;; Don't create /servers/socket/1 & co: runsystem does that on first boot.
-
-  ;; TODO: Set the 'gnu.translator' extended attribute for passive translator
-  ;; settings?
-  )
-
 (define %host-qemu-ipv4-address
   (inet-pton AF_INET "10.0.2.10"))
 
@@ -595,4 +564,4 @@ upon error."
               (start-repl)))))
     #:on-error on-error))
 
-;;; linux-initrd.scm ends here
+;;; linux-boot.scm ends here
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 433b5a7e8d..0f0ceae18f 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -84,8 +84,6 @@
                            linux initrd
                            make-disk-image?
                            single-file-output?
-                           target-arm32?
-                           target-aarch64?
                            (disk-image-size (* 100 (expt 2 20)))
                            (disk-image-format "qcow2")
                            (references-graphs '()))
@@ -101,7 +99,14 @@ access it via /dev/hda.
 REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
 the #:references-graphs parameter of 'derivation'."
 
-  (define target-arm? (or target-arm32? target-aarch64?))
+  (define target-arm32?
+    (string-prefix? "arm-" %host-type))
+
+  (define target-aarch64?
+    (string-prefix? "aarch64-" %host-type))
+
+  (define target-arm?
+    (or target-arm32? target-aarch64?))
 
   (define arch-specific-flags
     `(;; On ARM, a machine has to be specified. Use "virt" machine to avoid