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.

2 files changed, 203 insertions, 47 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