ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

hurd-boot: Further cleanup of "rc".

Browse source 
* 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
Show stats Download patch file Download diff file Expand all files Collapse all files

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

48
gnu/build/linux-boot.scm
View file

@ -40,7 +40,6 @@ (define-module (gnu build linux-boot)
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 @@ (define (scope dir)
;; 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 @@ (define (device-string->file-system-device device-string)
(start-repl)))))
#:on-error on-error))
;;; linux-initrd.scm ends here
;;; linux-boot.scm ends here

1
gnu/local.mk
View file

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

100
gnu/packages/hurd.scm
View file

@ -31,6 +31,7 @@ (define-module (gnu packages hurd)
#: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 @@ (define unifont
(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?

2
gnu/system/image.scm
View file

@ -167,6 +167,7 @@ (define-syntax-rule (with-imported-modules* gexp* ...)
(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 @@ (define-syntax-rule (with-imported-modules* gexp* ...)
#~(begin
(use-modules (gnu build vm)
(gnu build image)
(gnu build hurd-boot)
(gnu build linux-boot)
(guix store database)
(guix build utils))

5
gnu/system/vm.scm
View file

@ -344,9 +344,10 @@ (define inputs*
#~(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)