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.
This commit is contained in:
Jan (janneke) Nieuwenhuizen 2020-06-01 09:46:39 +02:00 committed by Jan Nieuwenhuizen
parent 11e4200fee
commit b37c544196
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
6 changed files with 219 additions and 139 deletions

202
gnu/build/hurd-boot.scm Normal file
View file

@ -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

View file

@ -40,7 +40,6 @@ (define-module (gnu build linux-boot)
find-long-option find-long-option
find-long-options find-long-options
make-essential-device-nodes make-essential-device-nodes
make-hurd-device-nodes
make-static-device-nodes make-static-device-nodes
configure-qemu-networking configure-qemu-networking
@ -324,51 +323,6 @@ (define (scope dir)
;; File systems in user space (FUSE). ;; File systems in user space (FUSE).
(mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229))) (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 (define %host-qemu-ipv4-address
(inet-pton AF_INET "10.0.2.10")) (inet-pton AF_INET "10.0.2.10"))
@ -610,4 +564,4 @@ (define (device-string->file-system-device device-string)
(start-repl))))) (start-repl)))))
#:on-error on-error)) #:on-error on-error))
;;; linux-initrd.scm ends here ;;; linux-boot.scm ends here

View file

@ -638,6 +638,7 @@ GNU_SYSTEM_MODULES = \
%D%/build/cross-toolchain.scm \ %D%/build/cross-toolchain.scm \
%D%/build/image.scm \ %D%/build/image.scm \
%D%/build/file-systems.scm \ %D%/build/file-systems.scm \
%D%/build/hurd-boot.scm \
%D%/build/install.scm \ %D%/build/install.scm \
%D%/build/linux-boot.scm \ %D%/build/linux-boot.scm \
%D%/build/linux-container.scm \ %D%/build/linux-container.scm \

View file

@ -31,6 +31,7 @@ (define-module (gnu packages hurd)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (guix build-system trivial) #:use-module (guix build-system trivial)
#:use-module (gnu build hurd-boot)
#:use-module (gnu packages autotools) #:use-module (gnu packages autotools)
#:use-module (gnu packages compression) #:use-module (gnu packages compression)
#:use-module (gnu packages flex) #:use-module (gnu packages flex)
@ -312,107 +313,26 @@ (define unifont
(define (hurd-rc-script) (define (hurd-rc-script)
"Return a script to be installed as /libexec/rc in the 'hurd' package. The "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 script takes care of installing the relevant passive translators on the first
boot, since this cannot be done from GNU/Linux." boot, since this cannot be done from GNU/Linux. Then, it runs system
(define translators activation; starting the Shepherd."
'(("/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"))))
(define rc (define rc
(with-imported-modules '((guix build utils)) (with-imported-modules '((guix build utils)
(gnu build hurd-boot)
(guix build syscalls))
#~(begin #~(begin
(use-modules (guix build utils) (use-modules (guix build utils)
(gnu build hurd-boot)
(guix build syscalls)
(ice-9 match) (ice-9 match)
(system repl repl) (system repl repl)
(srfi srfi-1) (srfi srfi-1)
(srfi srfi-26)) (srfi srfi-26))
(display "Welcome, this is GNU's early boot Guile.\n") ;; "@HURD@" and "@COREUTILS@" are placeholders.
(display "Use '--repl' for an initrd REPL.\n\n")
;; "@HURD@" and "@COREUTILS@" are a placeholders.
(setenv "PATH" "@HURD@/bin:@HURD@/sbin:@COREUTILS@/bin") (setenv "PATH" "@HURD@/bin:@HURD@/sbin:@COREUTILS@/bin")
;; XXX FIXME c&p from linux-boot.scm (boot-hurd-system))))
(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)))))))
;; FIXME: We want the program to use the cross-compiled Guile when ;; FIXME: We want the program to use the cross-compiled Guile when
;; cross-compiling. But why do we need to be explicit here? ;; cross-compiling. But why do we need to be explicit here?

View file

@ -167,6 +167,7 @@ (define-syntax-rule (with-imported-modules* gexp* ...)
(with-imported-modules `(,@(source-module-closure (with-imported-modules `(,@(source-module-closure
'((gnu build vm) '((gnu build vm)
(gnu build image) (gnu build image)
(gnu build hurd-boot)
(gnu build linux-boot) (gnu build linux-boot)
(guix store database)) (guix store database))
#:select? not-config?) #:select? not-config?)
@ -174,6 +175,7 @@ (define-syntax-rule (with-imported-modules* gexp* ...)
#~(begin #~(begin
(use-modules (gnu build vm) (use-modules (gnu build vm)
(gnu build image) (gnu build image)
(gnu build hurd-boot)
(gnu build linux-boot) (gnu build linux-boot)
(guix store database) (guix store database)
(guix build utils)) (guix build utils))

View file

@ -344,9 +344,10 @@ (define inputs*
#~(begin #~(begin
(use-modules (gnu build bootloader) (use-modules (gnu build bootloader)
(gnu build vm) (gnu build vm)
((gnu build hurd-boot)
#:select (make-hurd-device-nodes))
((gnu build linux-boot) ((gnu build linux-boot)
#:select (make-essential-device-nodes #:select (make-essential-device-nodes))
make-hurd-device-nodes))
(guix store database) (guix store database)
(guix build utils) (guix build utils)
(srfi srfi-26) (srfi srfi-26)