hurd-boot: Further cleanup of "rc".

* gnu/packages/hurd.scm (hurd-rc-script): Move implementation to ...
* gnu/build/hurd-boot.scm (boot-hurd-system): ...here, new file.
* gnu/build/linux-boot.scm (make-hurd-device-nodes): Move there likewise.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.

6 files changed, 219 insertions, 139 deletions

diff --git a/gnu/build/hurd-boot.scm b/gnu/build/hurd-boot.scm
new file mode 100644
index 0000000000..729822dcbd
--- /dev/null
+++ b/gnu/build/hurd-boot.scm
@@ -0,0 +1,202 @@
+;;; 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" "-s" node)))))))
+
+     (for-each (match-lambda
+                 ((node command)
+                  (unless (translated? node)
+                    (mkdir-p (dirname node))
+                    (apply invoke "settrans" "-c" 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"))
+
+     (let* ((args    (command-line))
+            (system  (find-long-option "--system" args))
+            (to-load (find-long-option "--load" args)))
+
+       (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/linux-boot.scm b/gnu/build/linux-boot.scm
index d62c670684..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,51 +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)
-                  (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 %host-qemu-ipv4-address
   (inet-pton AF_INET "10.0.2.10"))
 
@@ -610,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/local.mk b/gnu/local.mk
index 442e981830..b4d7ba5174 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -638,6 +638,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/build/cross-toolchain.scm			\
   %D%/build/image.scm				\
   %D%/build/file-systems.scm			\
+  %D%/build/hurd-boot.scm			\
   %D%/build/install.scm				\
   %D%/build/linux-boot.scm			\
   %D%/build/linux-container.scm			\
diff --git a/gnu/packages/hurd.scm b/gnu/packages/hurd.scm
index b341683afe..d02bbe6013 100644
--- a/gnu/packages/hurd.scm
+++ b/gnu/packages/hurd.scm
@@ -31,6 +31,7 @@
   #:use-module (guix utils)
   #:use-module (guix build-system gnu)
   #:use-module (guix build-system trivial)
+  #:use-module (gnu build hurd-boot)
   #:use-module (gnu packages autotools)
   #:use-module (gnu packages compression)
   #:use-module (gnu packages flex)
@@ -312,107 +313,26 @@ Hurd-minimal package which are needed for both glibc and GCC.")
 (define (hurd-rc-script)
   "Return a script to be installed as /libexec/rc in the 'hurd' package.  The
 script takes care of installing the relevant passive translators on the first
-boot, since this cannot be done from GNU/Linux."
-  (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"))))
+boot, since this cannot be done from GNU/Linux.  Then, it runs system
+activation; starting the Shepherd."
 
   (define rc
-    (with-imported-modules '((guix build utils))
+    (with-imported-modules '((guix build utils)
+                             (gnu build hurd-boot)
+                             (guix build syscalls))
       #~(begin
           (use-modules (guix build utils)
+                       (gnu build hurd-boot)
+                       (guix build syscalls)
                        (ice-9 match)
                        (system repl repl)
                        (srfi srfi-1)
                        (srfi srfi-26))
 
-          (display "Welcome, this is GNU's early boot Guile.\n")
-          (display "Use '--repl' for an initrd REPL.\n\n")
-
-          ;; "@HURD@" and "@COREUTILS@" are a placeholders.
+          ;; "@HURD@" and "@COREUTILS@" are placeholders.
           (setenv "PATH" "@HURD@/bin:@HURD@/sbin:@COREUTILS@/bin")
 
-          ;; 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 #\=)))))))
-
-          (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" "-s" node)))))))
-
-          (for-each (match-lambda
-                      ((node command)
-                       (unless (translated? node)
-                         (mkdir-p (dirname node))
-                         (apply invoke "settrans" "-c" 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"))
-
-          (let* ((args    (command-line))
-                 (system  (find-long-option "--system" args))
-                 (to-load (find-long-option "--load" args)))
-
-            (false-if-exception (delete-file "/hurd"))
-            (let ((hurd/hurd (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)
-                   (let ((shepherd.conf
-                          (if (file-exists? "/etc/shepherd.conf")
-                              "/etc/shepherd.conf"
-                              (let ((files (find-files "/gnu/store" ".*-shepherd.conf")))
-                                (and (pair? files) (car files))))))
-                     (unless shepherd.conf
-                       (format #t "No shepherd.conf found, dropping to a shell...\n")
-                       (invoke "/run/current-system/profile/bin/bash")
-                       (reboot))
-                     (false-if-exception (delete-file "/var/run/shepherd/socket"))
-                     (format #t "Starting the Shepherd... ~a\n" shepherd.conf)
-                     (execl "/run/current-system/profile/bin/shepherd" "shepherd"
-                            "--config" shepherd.conf))
-                   (sleep 2)
-                   (reboot))
-                  (else
-                   (display "no boot file passed via '--load'\n")
-                   (display "entering a warm and cozy REPL\n")
-                   (start-repl)))))))
+          (boot-hurd-system))))
 
   ;; FIXME: We want the program to use the cross-compiled Guile when
   ;; cross-compiling.  But why do we need to be explicit here?
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 15dac8af57..a0e6bf31f1 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -167,6 +167,7 @@
     (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?)
@@ -174,6 +175,7 @@
       #~(begin
           (use-modules (gnu build vm)
                        (gnu build image)
+                       (gnu build hurd-boot)
                        (gnu build linux-boot)
                        (guix store database)
                        (guix build utils))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 038cce19b6..686e56348d 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -344,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)