tribes/guix-fork
1
0
Fork 0
forked from tribes/guix
Code Pull Requests Activity
Files
master
guix-fork/gnu/build/hurd-boot.scm
T
Janneke Nieuwenhuizen c62a39174e system: hurd-boot: Prepare for runsystem in Guile. 
Fo guile to run, it needs pipe support: without pipe support it aborts at
startup.  Pipe support is currently createn in runsystem by creating a
passive translator

    settrans --create /servers/socket/1 /hurd/pflocal

However, this needs a writable root file-system, and runsystem is started with
a readonly root file-system.

This patch enables running guile early in runsystem, and thus prepares for
replacing the runsystem shell script with a guile program, by embedding the
servers/socket/1 passive translator into the hurd system image using xattr.

* gnu/build/hurd-boot.scm (make-hurd-device-nodes): Change optional root
parameter to keyword #:root.  Add #:hurd keyword parameter.  Use it to
create servers/socket/1 (pipe) and proc passive xattr translators.
* gnu/build/image.scm (initialize-root-partition): Update caller.
* gnu/system/image.scm (with-imported-modules*): Include (ice-9 optargs).
* gnu/system/images/hurd.scm (hurd-initialize-root-partition): Use it to
update caller.
* guix/scripts/system.scm (install): Update caller.

Change-Id: Ib3a672ae78bd969a2a4c0e33db8e38ccf71238ba
Merges: #8609
2026-05-19 18:34:56 +02:00

438 lines
17 KiB
Scheme
Raw Permalink Blame History

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020, 2023 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 #:key (root "/") (hurd "/hurd"))
"Make some of the nodes needed on GNU/Hurd."
(define (scope dir)
(in-vicinity root dir))
(define scope-set-translator
(match-lambda
((file-name command)
(scope-set-translator (list file-name command #o600)))
((file-name command mode)
(let ((mount-point (scope file-name)))
(set-translator mount-point command mode)))))
(mkdir-p (scope "dev"))
;; XXX: We must have `/dev/console` otherwise `console-run` tries to
;; create it while the file-system is still read-only.
(for-each (lambda (file)
(call-with-output-file (scope file)
(lambda (port)
(display file port) ;avoid hard-linking
(chmod port #o666))))
'("dev/console"
;; XXX What about vcs?
;; Don't create /dev/null etc just yet; the store
;; messes-up the permission bits.
;; "dev/null"
;; "dev/zero"
;; "dev/full"
;; "dev/random"
;; "dev/urandom"
))
(mkdir-p (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-p (scope "servers/socket"))
(mkdir-p (scope "servers/bus/pci"))
;; Set the 'gnu.translator' extended attribute for passive translator
;; settings for pipes (servers/socet/1) and mount information (proc/mounts).
;; Pipes are needed for guile-3.0.11 to startup, this enables moving
;; "runsystem" to guile.
;; XXX TODO: Set more passive xattr translators?
(define servers
`(
;; ("servers/bus/pci" ("/hurd/pci-arbiter"))
;; ("servers/crash-dump-core" ("/hurd/crash" "--dump-core"))
;; ("servers/crash-kill" ("/hurd/crash" "--kill"))
;; ("servers/crash-suspend" ("/hurd/crash" "--suspend"))
;; ("servers/password" ("/hurd/password"))
;; PIPE -- for running runsystem as Guile
("servers/socket/1" (,(in-vicinity hurd "pflocal")))
;; /servers/socket/2 and /26 are created by 'static-networking-service'.
;; XXX: Spawn pfinet without arguments on these nodes so that a DHCP
;; client has someone to talk to?
("proc" (,(in-vicinity hurd "procfs") "--stat-mode=444"))))
(for-each scope-set-translator servers)
(define devices
'())
(for-each scope-set-translator devices))
(define (passive-translator-xattr? file-name)
"Return true if FILE-NAME has an extended @code{gnu.translator} attribute
set.
Note that reading \"gnu.*\" xattrs on Linux only work with ext4; for tmpfs,
used during image creation, linux-7.0 with linux-shmem-hurd-xattr patch is
needed."
(and (file-exists? file-name)
(catch 'system-error
(lambda _ (not (string-null? (getxattr file-name "gnu.translator"))))
(lambda args
(if (= ENODATA (system-error-errno args))
#f
(apply throw args))))))
(define (passive-translator-installed? file-name)
"Return true if @file{showtrans} finds a translator installed on FILE-NAME."
(with-output-to-port (%make-void-port "w")
(lambda _
(with-error-to-port (%make-void-port "w")
(lambda _
(zero? (system* "showtrans" "--silent" file-name)))))))
(define (translated? file-name)
"Return true if a translator is installed on FILE-NAME."
;; On GNU/Hurd, 'getxattr' in glibc opens the file without O_NOTRANS, and
;; then, for "gnu.translator", it calls 'file_get_translator', resulting in
;; EOPNOTSUPP (conversely, 'showtrans' opens the file with O_NOTRANS).
(if (string-contains %host-type "linux-gnu")
(passive-translator-xattr? file-name)
(passive-translator-installed? file-name)))
(define* (set-translator file-name command #:optional (mode #o600))
"Setup translator COMMAND on FILE-NAME.
Note that setting \"gnu.*\" xattrs on Linux only work with ext4; for tmpfs,
used during image creation, linux-7.0 with linux-shmem-hurd-xattr patch is
needed."
(unless (translated? file-name)
(let ((dir (dirname file-name)))
(unless (directory-exists? dir)
(mkdir-p dir))
(unless (file-exists? file-name)
(call-with-output-file file-name
(lambda (port)
(display file-name port) ;avoid hard-linking
(chmod port mode)))))
(catch 'system-error
(lambda _
(setxattr file-name "gnu.translator" (string-join command "\0" 'suffix)))
(lambda (key . args)
(let ((errno (system-error-errno (cons key args))))
(format (current-error-port) "~a: ~a\n"
(strerror errno) file-name)
(format (current-error-port) "Ignoring...Good Luck!\n"))))))
(define-syntax-rule (false-if-EEXIST exp)
"Evaluate EXP but return #f if it raises to 'system-error with EEXIST."
(catch 'system-error
(lambda () exp)
(lambda args
(if (= EEXIST (system-error-errno args))
#f
(apply throw args)))))
(define* (set-hurd-device-translators #:optional (root "/"))
"Make some of the device nodes needed on GNU/Hurd."
(define (scope dir)
(in-vicinity root dir))
(define scope-set-translator
(match-lambda
((file-name command)
(scope-set-translator (list file-name command #o600)))
((file-name command mode)
(let ((mount-point (scope file-name)))
(set-translator mount-point command mode)))))
(define (mkdir* dir)
(let ((dir (scope dir)))
(unless (file-exists? dir)
(mkdir-p dir))))
;; (define random-seed "/var/lib/random-seed")
;; ;; Create seed file to avoid
;; ;; /gnu/store/...-hurd-x.y.z/hurd/random: Warning: Failed to read random seed file /var/lib/random-seed: No such file or directory
;; (let ((file (scope random-seed)))
;; (mkdir-p (dirname file))
;; (call-with-output-file file
;; (lambda (port)
;; (display (iota 1000) port)
;; (chmod port #o600))))
(define servers
'(("servers/bus/pci" ("/hurd/pci-arbiter"))
("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 and /26 are created by 'static-networking-service'.
;; XXX: Spawn pfinet without arguments on these nodes so that a DHCP
;; client has someone to talk to?
("proc" ("/hurd/procfs" "--stat-mode=444"))))
(define devices
`(("dev/full" ("/hurd/null" "--full") #o666)
("dev/null" ("/hurd/null") #o666)
;; The random translators, especially /dev/urandom, need to be non-passive
;; When they exist in the file-system and reference /var/lib/random-seed
;; while / is read-only. console-run will hang.
;; ("dev/random" ("/hurd/random" "--seed-file" ,random-seed)
;; #o644)
;; ("dev/urandom" ("/hurd/random" "--seed-file" ,random-seed
;; "--fast")
;; #o644)
("dev/zero" ("/hurd/storeio" "--store-type=zero") #o666)
("dev/console" ("/hurd/term" "/dev/console" "device" "console"))
("dev/klog" ("/hurd/streamio" "kmsg"))
("dev/mem" ("/hurd/storeio" "--no-cache" "mem") #o660)
("dev/shm" ("/hurd/tmpfs" "--mode=1777" "50%") #o644)
("dev/time" ("/hurd/storeio" "--no-cache" "time") #o644)
("dev/vcs" ("/hurd/console"))
("dev/tty" ("/hurd/magic" "tty") #o666)
;; 'fd_to_filename' in libc expects it.
("dev/fd" ("/hurd/magic" "--directory" "fd") #o555)
("dev/rumpdisk" ("/hurd/rumpdisk") #o660)
("dev/netdde" ("/hurd/netdde") #o660)
("dev/eth0" ("/hurd/devnode" "--master-device=/dev/net"
"eth0")
#o660)
("dev/eth1" ("/hurd/devnode" "--master-device=/dev/net"
"eth1")
#o660)
;; Create a number of ttys; syslogd writes to tty12 by default.
;; FIXME: Creating /dev/tty12 leads the console client to switch to
;; tty12 when syslogd starts, which is confusing for users. Thus, do
;; not create tty12.
,@(map (lambda (n)
(let ((n (number->string n)))
`(,(string-append "dev/tty" n)
("/hurd/term" ,(string-append "/dev/tty" n)
"hurdio" ,(string-append "/dev/vcs/" n "/console"))
#o666)))
(iota 11 1))
,@(append-map (lambda (n)
(let ((n (number->string n)))
`((,(string-append "dev/ptyp" n)
("/hurd/term" ,(string-append "/dev/ptyp" n)
"pty-master" ,(string-append "/dev/ttyp" n))
#o666)
(,(string-append "dev/ttyp" n)
("/hurd/term" ,(string-append "/dev/ttyp" n)
"pty-slave" ,(string-append "/dev/ptyp" n))
#o666))))
(iota 10 0))
,@(append-map (lambda (n)
(let* ((n (number->string n))
(disk (string-append "hd" n))
(drive (string-append "dev/" disk)))
`((,drive ("/hurd/storeio" ,disk) #o600)
,@(map (lambda (p)
(let ((p (number->string p)))
`(,(string-append drive "s" p)
("/hurd/storeio"
,(string-append disk "s" p))
#o660)))
(iota 4 1)))))
(iota 4 0))
,@(append-map (lambda (n)
(let* ((n (number->string n))
(drive (string-append "dev/wd" n))
(disk (string-append "@/dev/disk:wd" n)))
`((,drive ("/hurd/storeio" ,disk) #o600)
,@(map (lambda (p)
(let ((p (number->string p)))
`(,(string-append drive "s" p)
("/hurd/storeio"
"--store-type=typed"
,(string-append
"part:" p ":device:" disk))
#o660)))
(iota 4 1)))))
(iota 4 0))))
(for-each scope-set-translator servers)
(mkdir* "dev/vcs/1")
(mkdir* "dev/vcs/2")
(when (file-exists? (scope "dev/console"))
(rename-file (scope "dev/console") (scope "dev/console-")))
(for-each scope-set-translator devices)
(false-if-EEXIST (symlink "/dev/fd/0" (scope "dev/stdin")))
(false-if-EEXIST (symlink "/dev/fd/1" (scope "dev/stdout")))
(false-if-EEXIST (symlink "/dev/fd/2" (scope "dev/stderr")))
(false-if-EEXIST (symlink "crash-dump-core" (scope "servers/crash")))
(false-if-EEXIST (symlink "/dev/rumpdisk" (scope "dev/disk")))
(false-if-EEXIST (symlink "/dev/netdde" (scope "dev/net")))
(false-if-EEXIST (symlink "/servers/socket/2" (scope "servers/socket/inet")))
(false-if-EEXIST (symlink "/servers/socket/26" (scope "servers/socket/inet6")))
;; Make sure /var/run/mtab is a symlink to /proc/mounts.
(false-if-exception (delete-file (scope "var/run/mtab")))
(mkdir* (scope "var/run"))
(symlink "/proc/mounts" (scope "var/run/mtab")))
(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 'gnu.system' and 'gnu.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 Linux xattr/setxattr to remove (settrans in) /libexec/RUNSYSTEM
"
(display "Welcome, this is GNU's early boot Guile.\n")
(display "Use 'gnu.repl' for an initrd REPL.\n\n")
(call-with-error-handling
(lambda ()
(let* ((args (command-line))
(system (find-long-option "gnu.system" args))
(to-load (find-long-option "gnu.load" args))
(profile (string-append system "/profile"))
(bin (string-append profile "/bin"))
(sbin (string-append profile "/bin")))
(setenv "PATH" (string-append bin ":" sbin))
(when (file-exists? "/var/run/shepherd/socket")
(format #t "Removing stale shepherd socket...\n")
(delete-file "/var/run/shepherd/socket"))
(unless (file-exists? "/servers/startup")
(format #t "Creating essential device nodes...\n")
(make-hurd-device-nodes))
(let ((profile/hurd (readlink* (string-append profile "/hurd"))))
(when (file-exists? "/hurd")
(format #t "Removing stale /hurd link\n")
(delete-file "/hurd"))
(format #t "Linking /hurd from ~a...\n" profile/hurd)
(symlink profile/hurd "/hurd"))
(format #t "Setting-up essential translators...\n")
(set-hurd-device-translators)
(format #t "Starting pager...\n")
(unless (zero? (system* "/hurd/mach-defpager"))
(format #t "FAILED...Good luck!\n"))
(cond ((member "gnu.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 'gnu.load'\n")
(display "entering a warm and cozy REPL\n")
(start-repl)))))
#:on-error on-error))
;;; hurd-boot.scm ends here
View Git Blame Copy Permalink