aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gnu/build/hurd-boot.scm202
-rw-r--r--gnu/build/linux-boot.scm48
-rw-r--r--gnu/local.mk1
-rw-r--r--gnu/packages/hurd.scm100
-rw-r--r--gnu/system/image.scm2
-rw-r--r--gnu/system/vm.scm5
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)
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-30 00:08:35 +0000