summaryrefslogtreecommitdiff
path: root/gnu/build
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/build')
-rw-r--r--gnu/build/activation.scm4
-rw-r--r--gnu/build/file-systems.scm6
-rw-r--r--gnu/build/hurd-boot.scm205
-rw-r--r--gnu/build/image.scm60
-rw-r--r--gnu/build/linux-boot.scm96
-rw-r--r--gnu/build/shepherd.scm19
-rw-r--r--gnu/build/vm.scm11
7 files changed, 303 insertions, 98 deletions
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index 30f5e87d5a..4b67926e88 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -320,7 +320,9 @@ improvement."
(define (boot-time-system)
"Return the '--system' argument passed on the kernel command line."
- (find-long-option "--system" (linux-command-line)))
+ (find-long-option "--system" (if (string-contains %host-type "linux-gnu")
+ (linux-command-line)
+ (command-line))))
(define* (activate-current-system
#:optional (system (or (getenv "GUIX_NEW_SYSTEM")
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index b920e8fc62..ad92d8a496 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -661,8 +661,10 @@ were found."
(match spec
((? string?)
- ;; Nothing to do, but wait until SPEC shows up.
- (resolve identity spec identity))
+ (if (string-contains spec ":/")
+ spec ; do not resolve NFS devices
+ ;; Nothing to do, but wait until SPEC shows up.
+ (resolve identity spec identity)))
((? file-system-label?)
;; Resolve the label.
(resolve find-partition-by-label
diff --git a/gnu/build/hurd-boot.scm b/gnu/build/hurd-boot.scm
new file mode 100644
index 0000000000..09326233d2
--- /dev/null
+++ b/gnu/build/hurd-boot.scm
@@ -0,0 +1,205 @@
+;;; 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" "--silent" node)))))))
+
+ (let* ((args (command-line))
+ (system (find-long-option "--system" args))
+ (to-load (find-long-option "--load" args)))
+
+ (format #t "Creating essential servers...\n")
+ (setenv "PATH" (string-append system "/profile/bin"
+ ":" system "/profile/sbin"))
+ (for-each (match-lambda
+ ((node command)
+ (unless (translated? node)
+ (mkdir-p (dirname node))
+ (apply invoke "settrans" "--create" 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"))
+
+ (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/image.scm b/gnu/build/image.scm
index fe8e11aa1b..893b846976 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -47,9 +47,10 @@
"Take SEXP, a tuple as returned by 'partition->gexp', and turn it into a
<partition> record."
(match sexp
- ((size file-system label uuid)
+ ((size file-system file-system-options label uuid)
(partition (size size)
(file-system file-system)
+ (file-system-options file-system-options)
(label label)
(uuid uuid)))))
@@ -63,25 +64,30 @@
take the partition metadata size into account, take a 25% margin."
(* 1.25 (file-size root)))
-(define* (make-ext4-image partition target root
- #:key
- (owner-uid 0)
- (owner-gid 0))
- "Handle the creation of EXT4 partition images. See 'make-partition-image'."
+(define* (make-ext-image partition target root
+ #:key
+ (owner-uid 0)
+ (owner-gid 0))
+ "Handle the creation of EXT2/3/4 partition images. See
+'make-partition-image'."
(let ((size (partition-size partition))
+ (fs (partition-file-system partition))
+ (fs-options (partition-file-system-options partition))
(label (partition-label partition))
(uuid (partition-uuid partition))
- (options "lazy_itable_init=1,lazy_journal_init=1"))
- (invoke "mke2fs" "-t" "ext4" "-d" root
- "-L" label "-U" (uuid->string uuid)
- "-E" (format #f "root_owner=~a:~a,~a"
- owner-uid owner-gid options)
- target
- (format #f "~ak"
- (size-in-kib
- (if (eq? size 'guess)
- (estimate-partition-size root)
- size))))))
+ (journal-options "lazy_itable_init=1,lazy_journal_init=1"))
+ (apply invoke
+ `("mke2fs" "-t" ,fs "-d" ,root
+ "-L" ,label "-U" ,(uuid->string uuid)
+ "-E" ,(format #f "root_owner=~a:~a,~a"
+ owner-uid owner-gid journal-options)
+ ,@fs-options
+ ,target
+ ,(format #f "~ak"
+ (size-in-kib
+ (if (eq? size 'guess)
+ (estimate-partition-size root)
+ size)))))))
(define* (make-vfat-image partition target root)
"Handle the creation of VFAT partition images. See 'make-partition-image'."
@@ -105,8 +111,8 @@ ROOT directory to populate the image."
(let* ((partition (sexp->partition partition-sexp))
(type (partition-file-system partition)))
(cond
- ((string=? type "ext4")
- (make-ext4-image partition target root))
+ ((string-prefix? "ext" type)
+ (make-ext-image partition target root))
((string=? type "vfat")
(make-vfat-image partition target root))
(else
@@ -140,19 +146,22 @@ deduplicates files common to CLOSURE and the rest of PREFIX."
(define* (initialize-efi-partition root
#:key
- bootloader-package
+ grub-efi
#:allow-other-keys)
- "Install in ROOT directory, an EFI loader using BOOTLOADER-PACKAGE."
- (install-efi-loader bootloader-package root))
+ "Install in ROOT directory, an EFI loader using GRUB-EFI."
+ (install-efi-loader grub-efi root))
(define* (initialize-root-partition root
#:key
bootcfg
bootcfg-location
+ bootloader-package
+ bootloader-installer
(deduplicate? #t)
references-graphs
(register-closures? #t)
system-directory
+ make-device-nodes
#:allow-other-keys)
"Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to
install the bootloader configuration.
@@ -164,6 +173,10 @@ of the directory of the 'system' derivation."
(populate-root-file-system system-directory root)
(populate-store references-graphs root)
+ ;; Populate /dev.
+ (when make-device-nodes
+ (make-device-nodes root))
+
(when register-closures?
(for-each (lambda (closure)
(register-closure root
@@ -172,6 +185,9 @@ of the directory of the 'system' derivation."
#:deduplicate? deduplicate?))
references-graphs))
+ (when bootloader-installer
+ (display "installing bootloader...\n")
+ (bootloader-installer bootloader-package #f root))
(when bootcfg
(install-boot-config bootcfg bootcfg-location root)))
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index c6f9df5f29..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,36 +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)
- (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"))
- (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"))
@@ -498,25 +467,13 @@ upon error."
(define (root-mount-point? fs)
(string=? (file-system-mount-point fs) "/"))
- (define root-fs-type
- (or (any (lambda (fs)
- (and (root-mount-point? fs)
- (file-system-type fs)))
- mounts)
- "ext4"))
-
- (define root-fs-flags
- (mount-flags->bit-mask (or (any (lambda (fs)
- (and (root-mount-point? fs)
- (file-system-flags fs)))
- mounts)
- '())))
-
- (define root-fs-options
- (any (lambda (fs)
- (and (root-mount-point? fs)
- (file-system-options fs)))
- mounts))
+ (define (device-string->file-system-device device-string)
+ ;; The "--root=SPEC" kernel command-line option always provides a
+ ;; string, but the string can represent a device, a UUID, or a
+ ;; label. So check for all three.
+ (cond ((string-prefix? "/" device-string) device-string)
+ ((uuid device-string) => identity)
+ (else (file-system-label device-string))))
(display "Welcome, this is GNU's early boot Guile.\n")
(display "Use '--repl' for an initrd REPL.\n\n")
@@ -526,7 +483,21 @@ upon error."
(mount-essential-file-systems)
(let* ((args (linux-command-line))
(to-load (find-long-option "--load" args))
- (root (find-long-option "--root" args)))
+ (root-fs (find root-mount-point? mounts))
+ (root-fs-type (or (and=> root-fs file-system-type)
+ "ext4"))
+ (root-fs-device (and=> root-fs file-system-device))
+ (root-fs-flags (mount-flags->bit-mask
+ (or (and=> root-fs file-system-flags)
+ '())))
+ (root-options (if root-fs
+ (file-system-options root-fs)
+ #f))
+ ;; --root takes precedence over the 'device' field of the root
+ ;; <file-system> record.
+ (root-device (or (and=> (find-long-option "--root" args)
+ device-string->file-system-device)
+ root-fs-device)))
(when (member "--repl" args)
(start-repl))
@@ -561,21 +532,12 @@ upon error."
(setenv "EXT2FS_NO_MTAB_OK" "1")
- (if root
- ;; The "--root=SPEC" kernel command-line option always provides a
- ;; string, but the string can represent a device, a UUID, or a
- ;; label. So check for all three.
- (let ((device-spec (cond ((string-prefix? "/" root) root)
- ((uuid root) => identity)
- ((string-contains root ":/") #f) ; nfs
- (else (file-system-label root)))))
- (mount-root-file-system (if device-spec
- (canonicalize-device-spec device-spec)
- root)
- root-fs-type
- #:volatile-root? volatile-root?
- #:flags root-fs-flags
- #:options root-fs-options))
+ (if root-device
+ (mount-root-file-system (canonicalize-device-spec root-device)
+ root-fs-type
+ #:volatile-root? volatile-root?
+ #:flags root-fs-flags
+ #:options root-options)
(mount "none" "/root" "tmpfs"))
;; Mount the specified file systems.
@@ -602,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/build/shepherd.scm b/gnu/build/shepherd.scm
index 14bdf4edb8..fd93e7f3f4 100644
--- a/gnu/build/shepherd.scm
+++ b/gnu/build/shepherd.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,6 +21,7 @@
#:use-module (gnu build linux-container)
#:use-module (guix build utils)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:export (make-forkexec-constructor/container))
@@ -91,7 +92,10 @@
;; XXX: Lazy-bind the Shepherd to avoid a compile-time dependency.
(module-autoload! (current-module)
- '(shepherd service) '(read-pid-file exec-command))
+ '(shepherd service)
+ '(read-pid-file exec-command %precious-signals))
+(module-autoload! (current-module)
+ '(shepherd system) '(unblock-signals))
(define* (read-pid-file/container pid pid-file #:key (max-delay 5))
"Read PID-FILE in the container namespaces of PID, which exists in a
@@ -101,7 +105,8 @@ separate mount and PID name space. Return the \"outer\" PID. "
(read-pid-file pid-file
#:max-delay max-delay)))
(#f
- (catch-system-error (kill pid SIGTERM))
+ ;; Send SIGTERM to the whole process group.
+ (catch-system-error (kill (- pid) SIGTERM))
#f)
((? integer? container-pid)
;; XXX: When COMMAND is started in a separate PID namespace, its
@@ -158,6 +163,14 @@ namespace, in addition to essential bind-mounts such /proc."
(let ((pid (run-container container-directory
mounts namespaces 1
(lambda ()
+ ;; First restore the default handlers.
+ (for-each (cut sigaction <> SIG_DFL)
+ %precious-signals)
+
+ ;; Unblock any signals that have been blocked
+ ;; by the parent process.
+ (unblock-signals %precious-signals)
+
(mkdir-p "/var/run")
(clean-up pid-file)
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 433b5a7e8d..0f0ceae18f 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -84,8 +84,6 @@
linux initrd
make-disk-image?
single-file-output?
- target-arm32?
- target-aarch64?
(disk-image-size (* 100 (expt 2 20)))
(disk-image-format "qcow2")
(references-graphs '()))
@@ -101,7 +99,14 @@ access it via /dev/hda.
REFERENCES-GRAPHS can specify a list of reference-graph files as produced by
the #:references-graphs parameter of 'derivation'."
- (define target-arm? (or target-arm32? target-aarch64?))
+ (define target-arm32?
+ (string-prefix? "arm-" %host-type))
+
+ (define target-aarch64?
+ (string-prefix? "aarch64-" %host-type))
+
+ (define target-arm?
+ (or target-arm32? target-aarch64?))
(define arch-specific-flags
`(;; On ARM, a machine has to be specified. Use "virt" machine to avoid
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-11 06:02:28 +0000