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
Jan Nieuwenhuizen
parent
11e4200fee
commit
b37c544196
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue