diff options
| -rw-r--r-- | gnu/build/hurd-boot.scm | 202 | ||||
| -rw-r--r-- | gnu/build/linux-boot.scm | 48 | ||||
| -rw-r--r-- | gnu/local.mk | 1 | ||||
| -rw-r--r-- | gnu/packages/hurd.scm | 100 | ||||
| -rw-r--r-- | gnu/system/image.scm | 2 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 5 |
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) |