projects/guix·blob python-team · refs

749 lines · 29.9 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <[email protected]>
3;;; Copyright © 2016, 2017, 2019–2021 Tobias Geerinckx-Rice <[email protected]>
4;;; Copyright © 2017 Mathieu Othacehe <[email protected]>
5;;; Copyright © 2019 Guillaume Le Vaillant <[email protected]>
6;;; Copyright © 2020, 2022 Maxim Cournoyer <[email protected]>
7;;;
8;;; This file is part of GNU Guix.
9;;;
10;;; GNU Guix is free software; you can redistribute it and/or modify it
11;;; under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 3 of the License, or (at
13;;; your option) any later version.
14;;;
15;;; GNU Guix is distributed in the hope that it will be useful, but
16;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22
23;;; Commentary:
24;;;
25;;; Utility procedures useful in a Linux initial RAM disk (initrd). Note that
26;;; many of these use procedures not yet available in vanilla Guile (`mount',
27;;; `load-linux-module', etc.); these are provided by a Guile patch used in
28;;; the GNU distribution.
29;;;
30;;; Code:
31
32(define-module (gnu build linux-boot)
33 #:use-module (rnrs io ports)
34 #:use-module (system repl error-handling)
35 #:autoload (system repl repl) (start-repl)
36 #:use-module (srfi srfi-1)
37 #:use-module (srfi srfi-9)
38 #:use-module (srfi srfi-11)
39 #:use-module (srfi srfi-26)
40 #:use-module (ice-9 match)
41 #:use-module (ice-9 rdelim)
42 #:use-module (ice-9 regex)
43 #:use-module (ice-9 ftw)
44 #:use-module (guix build utils)
45 #:use-module ((guix build syscalls)
46 #:hide (file-system-type))
47 #:use-module (gnu build linux-modules)
48 #:use-module (gnu build file-systems)
49 #:use-module (gnu system file-systems)
50 #:export (mount-essential-file-systems
51 linux-command-line
52 find-long-option
53 find-long-options
54 make-essential-device-nodes
55 make-static-device-nodes
56 configure-qemu-networking
57
58 boot-system
59
60 linux-console
61
62 linux-console?
63 linux-console-device
64 linux-console-can-read?
65 linux-console-can-write?
66 linux-console-can-unblank?
67 linux-console-enabled?
68 linux-console-preferred?
69 linux-console-primary?
70 linux-console-printk?
71 linux-console-braille?
72 linux-console-safe-when-cpu-offline?
73 linux-console-major
74 linux-console-minor
75 linux-console-virtual?
76
77 read-linux-consoles))
78
79(define* (mount-essential-file-systems #:key (root "/"))
80 "Mount /dev, /proc, and /sys under ROOT."
81 (define (scope dir)
82 (string-append root
83 (if (string-suffix? "/" root)
84 ""
85 "/")
86 dir))
87
88 (unless (file-exists? (scope "proc"))
89 (mkdir (scope "proc")))
90 (mount "none" (scope "proc") "proc")
91
92 (unless (file-exists? (scope "dev"))
93 (mkdir (scope "dev")))
94 (mount "none" (scope "dev") "devtmpfs")
95
96 (unless (file-exists? (scope "sys"))
97 (mkdir (scope "sys")))
98 (mount "none" (scope "sys") "sysfs"))
99
100(define (move-essential-file-systems root)
101 "Move currently mounted essential file systems to ROOT."
102 (for-each (lambda (dir)
103 (let ((target (string-append root dir)))
104 (unless (file-exists? target)
105 (mkdir target))
106 (mount dir target "" MS_MOVE)))
107 '("/dev" "/proc" "/sys")))
108
109(define (linux-command-line)
110 "Return the Linux kernel command line as a list of strings."
111 (string-tokenize
112 (call-with-input-file "/proc/cmdline"
113 get-string-all)))
114
115(define (find-long-option option arguments)
116 "Find OPTION among ARGUMENTS, where OPTION is something like \"gnu.load\".
117Return the value associated with OPTION, or #f on failure."
118 (let ((opt (string-append option "=")))
119 (and=> (find (cut string-prefix? opt <>)
120 arguments)
121 (lambda (arg)
122 (substring arg (+ 1 (string-index arg #\=)))))))
123
124(define (find-long-options option arguments)
125 "Find OPTIONs among ARGUMENTS, where OPTION is something like \"console\".
126Return the values associated with OPTIONs as a list, or the empty list if
127OPTION doesn't appear in ARGUMENTS."
128 (let ((opt (string-append option "=")))
129 (filter-map (lambda (arg)
130 (and (string-prefix? opt arg)
131 (substring arg (+ 1 (string-index arg #\=)))))
132 arguments)))
133
134(define (resume-if-hibernated device)
135 "Resume from hibernation if possible. This is safe ONLY if no on-disk file
136systems have been mounted; calling it later risks severe file system corruption!
137See <Documentation/swsusp.txt> in the kernel source directory. This is the
138caller's responsibility, as is catching exceptions if resumption was supposed to
139happen but didn't.
140
141Resume only from DEVICE if it's a string. If it's #f, use the kernel's default
142hibernation device (CONFIG_PM_STD_PARTITION). Never return if resumption
143succeeds. Return nothing otherwise. The kernel logs any details to dmesg."
144
145 (define (string->major:minor string)
146 "Return a string with MAJOR:MINOR numbers of the device specified by STRING"
147
148 ;; The "resume=" kernel command-line option always provides a string, which
149 ;; can represent a device, a UUID, or a label. Check for all three.
150 (let* ((spec (cond ((string-prefix? "/" string) string)
151 ((uuid string) => identity)
152 (else (file-system-label string))))
153 ;; XXX The kernel's swsusp_resume_can_resume() waits if ‘resumewait’
154 ;; is found on the command line; our canonicalize-device-spec gives
155 ;; up after 20 seconds. We could emulate the former by looping…
156 (device (canonicalize-device-spec spec))
157 (rdev (stat:rdev (stat device))))
158 (let-values (((major minor) (device-number->major+minor rdev)))
159 (format #f "~a:~a" major minor))))
160
161 ;; Write the resume DEVICE to this magic file, using the MAJOR:MINOR device
162 ;; numbers if possible. The kernel will immediately try to resume from it.
163 (let ((resume "/sys/power/resume"))
164 (when (file-exists? resume) ; this kernel supports hibernation
165 ;; Honour the kernel's default device (only) if none other was given.
166 (let ((major:minor (if device
167 (or (false-if-exception (string->major:minor
168 device))
169 ;; We can't parse it. Maybe the kernel can.
170 device)
171 (let ((default (call-with-input-file resume
172 read-line)))
173 ;; Don't waste time echoing 0:0 to /sys.
174 (if (string=? "0:0" default)
175 #f
176 default)))))
177 (when major:minor
178 (call-with-output-file resume ; may throw an ‘Invalid argument’
179 (cut display major:minor <>))))))) ; may never return
180
181(define* (make-disk-device-nodes base major #:optional (minor 0))
182 "Make the block device nodes around BASE (something like \"/root/dev/sda\")
183with the given MAJOR number, starting with MINOR."
184 (mknod base 'block-special #o644 (device-number major minor))
185 (let loop ((i 1))
186 (when (< i 16)
187 (mknod (string-append base (number->string i))
188 'block-special #o644 (device-number major (+ minor i)))
189 (loop (+ i 1)))))
190
191;; Representation of a /dev node.
192(define-record-type <device-node>
193 (device-node name type major minor module)
194 device-node?
195 (name device-node-name)
196 (type device-node-type)
197 (major device-node-major)
198 (minor device-node-minor)
199 (module device-node-module))
200
201(define (read-static-device-nodes port)
202 "Read from PORT a list of <device-node> written in the format used by
203/lib/modules/*/*.devname files."
204 (let loop ((line (read-line port)))
205 (if (eof-object? line)
206 '()
207 (match (string-split line #\space)
208 (((? (cut string-prefix? "#" <>)) _ ...)
209 (loop (read-line port)))
210 ((module-name device-name device-spec)
211 (let* ((device-parts
212 (string-match "([bc])([0-9][0-9]*):([0-9][0-9]*)"
213 device-spec))
214 (type-string (match:substring device-parts 1))
215 (type (match type-string
216 ("c" 'char-special)
217 ("b" 'block-special)))
218 (major-string (match:substring device-parts 2))
219 (major (string->number major-string 10))
220 (minor-string (match:substring device-parts 3))
221 (minor (string->number minor-string 10)))
222 (cons (device-node device-name type major minor module-name)
223 (loop (read-line port)))))
224 (_
225 (begin
226 (format (current-error-port)
227 "read-static-device-nodes: ignored devname line '~a'~%" line)
228 (loop (read-line port))))))))
229
230(define* (mkdir-p* dir #:optional (mode #o755))
231 "This is a variant of 'mkdir-p' that works around
232<http://bugs.gnu.org/24659> by passing MODE explicitly in each 'mkdir' call."
233 (define absolute?
234 (string-prefix? "/" dir))
235
236 (define not-slash
237 (char-set-complement (char-set #\/)))
238
239 (let loop ((components (string-tokenize dir not-slash))
240 (root (if absolute?
241 ""
242 ".")))
243 (match components
244 ((head tail ...)
245 (let ((path (string-append root "/" head)))
246 (catch 'system-error
247 (lambda ()
248 (mkdir path mode)
249 (loop tail path))
250 (lambda args
251 (if (= EEXIST (system-error-errno args))
252 (loop tail path)
253 (apply throw args))))))
254 (() #t))))
255
256(define (report-system-error name . args)
257 "Report a system error for the file NAME."
258 (let ((errno (system-error-errno args)))
259 (format (current-error-port) "could not create '~a': ~a~%" name
260 (strerror errno))))
261
262;; Catch a system-error, log it and don't die from it.
263(define-syntax-rule (catch-system-error name exp)
264 (catch 'system-error
265 (lambda ()
266 exp)
267 (lambda args
268 (apply report-system-error name args))))
269
270;; Create a device node like the <device-node> passed here on the file system.
271(define create-device-node
272 (match-lambda
273 (($ <device-node> xname type major minor module)
274 (let ((name (string-append "/dev/" xname)))
275 (mkdir-p* (dirname name))
276 (catch-system-error name
277 (mknod name type #o600 (device-number major minor)))))))
278
279(define* (make-static-device-nodes linux-release-module-directory)
280 "Create static device nodes required by the given Linux release.
281This is required in order to solve a chicken-or-egg problem:
282The Linux kernel has a feature to autoload modules when a device is first
283accessed.
284And udev has a feature to set the permissions of static nodes correctly
285when it is starting up and also to automatically create nodes when hardware
286is hotplugged. That leaves universal device files which are not linked to
287one specific hardware device. These we have to create."
288 (let ((devname-name (string-append linux-release-module-directory "/"
289 "modules.devname")))
290 (for-each create-device-node
291 (call-with-input-file devname-name
292 read-static-device-nodes))))
293
294(define* (make-essential-device-nodes #:optional (root "/"))
295 "Make essential device nodes under ROOT/dev."
296 ;; The hand-made devtmpfs/udev!
297
298 (define (scope dir)
299 (string-append root
300 (if (string-suffix? "/" root)
301 ""
302 "/")
303 dir))
304
305 (unless (file-exists? (scope "dev"))
306 (mkdir (scope "dev")))
307
308 ;; Make the device nodes for SCSI disks.
309 (make-disk-device-nodes (scope "dev/sda") 8)
310 (make-disk-device-nodes (scope "dev/sdb") 8 16)
311 (make-disk-device-nodes (scope "dev/sdc") 8 32)
312 (make-disk-device-nodes (scope "dev/sdd") 8 48)
313
314 ;; SCSI CD-ROM devices (aka. "/dev/sr0" etc.).
315 (mknod (scope "dev/scd0") 'block-special #o644 (device-number 11 0))
316 (mknod (scope "dev/scd1") 'block-special #o644 (device-number 11 1))
317
318 ;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM.
319 (make-disk-device-nodes (scope "dev/vda") 252)
320
321 ;; Memory (used by Xorg's VESA driver.)
322 (mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1))
323 (mknod (scope "dev/kmem") 'char-special #o640 (device-number 1 2))
324
325 ;; Inputs (used by Xorg.)
326 (unless (file-exists? (scope "dev/input"))
327 (mkdir (scope "dev/input")))
328 (mknod (scope "dev/input/mice") 'char-special #o640 (device-number 13 63))
329 (mknod (scope "dev/input/mouse0") 'char-special #o640 (device-number 13 32))
330 (mknod (scope "dev/input/event0") 'char-special #o640 (device-number 13 64))
331
332 ;; System console. This node is magically created by the kernel on the
333 ;; initrd's root, so don't try to create it in that case.
334 (unless (string=? root "/")
335 (mknod (scope "dev/console") 'char-special #o600
336 (device-number 5 1)))
337
338 ;; TTYs.
339 (mknod (scope "dev/tty") 'char-special #o600
340 (device-number 5 0))
341 (chmod (scope "dev/tty") #o666)
342 (let loop ((n 0))
343 (and (< n 50)
344 (let ((name (format #f "dev/tty~a" n)))
345 (mknod (scope name) 'char-special #o600
346 (device-number 4 n))
347 (loop (+ 1 n)))))
348
349 ;; Serial line.
350 (mknod (scope "dev/ttyS0") 'char-special #o660
351 (device-number 4 64))
352
353 ;; Pseudo ttys.
354 (mknod (scope "dev/ptmx") 'char-special #o666
355 (device-number 5 2))
356 (chmod (scope "dev/ptmx") #o666)
357
358 ;; Create /dev/pts; it will be mounted later, at boot time.
359 (unless (file-exists? (scope "dev/pts"))
360 (mkdir (scope "dev/pts")))
361
362 ;; Rendez-vous point for syslogd.
363 (mknod (scope "dev/log") 'socket #o666 0)
364 (mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11))
365
366 ;; Other useful nodes, notably relied on by guix-daemon.
367 (for-each (match-lambda
368 ((file major minor)
369 (mknod (scope file) 'char-special #o666
370 (device-number major minor))
371 (chmod (scope file) #o666)))
372 '(("dev/null" 1 3)
373 ("dev/zero" 1 5)
374 ("dev/full" 1 7)
375 ("dev/random" 1 8)
376 ("dev/urandom" 1 9)))
377
378 (symlink "/proc/self/fd" (scope "dev/fd"))
379 (symlink "/proc/self/fd/0" (scope "dev/stdin"))
380 (symlink "/proc/self/fd/1" (scope "dev/stdout"))
381 (symlink "/proc/self/fd/2" (scope "dev/stderr"))
382
383 ;; Loopback devices.
384 (let loop ((i 0))
385 (when (< i 8)
386 (mknod (scope (string-append "dev/loop" (number->string i)))
387 'block-special #o660
388 (device-number 7 i))
389 (loop (+ 1 i))))
390
391 ;; File systems in user space (FUSE).
392 (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229)))
393
394(define %host-qemu-ipv4-address
395 (inet-pton AF_INET "10.0.2.10"))
396
397(define* (configure-qemu-networking #:optional (interface "eth0"))
398 "Setup the INTERFACE network interface and /etc/resolv.conf according to
399QEMU's default networking settings (see net/slirp.c in QEMU for default
400networking values.) Return #t if INTERFACE is up, #f otherwise."
401 (display "configuring QEMU networking...\n")
402 (let* ((sock (socket AF_INET SOCK_STREAM 0))
403 (address (make-socket-address AF_INET %host-qemu-ipv4-address 0))
404 (flags (network-interface-flags sock interface)))
405 (set-network-interface-address sock interface address)
406 (set-network-interface-flags sock interface (logior flags IFF_UP))
407
408 (logand (network-interface-flags sock interface) IFF_UP)))
409
410(define (pidof program)
411 "Return the PID of the first presumed instance of PROGRAM."
412 (let ((program (basename program)))
413 (find (lambda (pid)
414 (let ((exe (format #f "/proc/~a/exe" pid)))
415 (and=> (false-if-exception (readlink exe))
416 (compose (cut string=? program <>) basename))))
417 (filter-map string->number (scandir "/proc")))))
418
419(define* (mount-root-file-system root type
420 #:key volatile-root? (flags 0) options
421 check? skip-check-if-clean? repair)
422 "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? is
423true, mount ROOT read-only and make it an overlay with a writable tmpfs using
424the kernel built-in overlayfs. FLAGS and OPTIONS indicates the options to use
425to mount ROOT, and behave the same as for the `mount' procedure.
426
427If CHECK? is true, first run ROOT's fsck tool (if any) non-interactively.
428If SKIP-CHECK-IF-CLEAN? is true, ask fsck to return immediately if ROOT is
429marked as clean. If REPAIR is true, fsck may write to ROOT to perform repairs.
430If REPAIR is also 'PREEN, ask fsck to perform only those repairs that it
431considers safe."
432
433 (if volatile-root?
434 (begin
435 (mkdir-p "/real-root")
436 (mount root "/real-root" type (logior MS_RDONLY flags) options)
437 (mkdir-p "/rw-root")
438 (mount "none" "/rw-root" "tmpfs")
439
440 ;; Create the upperdir and the workdir of the overlayfs
441 (mkdir-p "/rw-root/upper")
442 (mkdir-p "/rw-root/work")
443
444 ;; We want read-write /dev nodes.
445 (mkdir-p "/rw-root/upper/dev")
446 (mount "none" "/rw-root/upper/dev" "devtmpfs")
447
448 ;; Make /root an overlay of the tmpfs and the actual root.
449 (mount "none" "/root" "overlay" 0
450 "lowerdir=/real-root,upperdir=/rw-root/upper,workdir=/rw-root/work"))
451 (begin
452 (when check?
453 (check-file-system root type (not skip-check-if-clean?) repair))
454 (mount root "/root" type flags options)))
455
456 ;; Make sure /root/etc/mtab is a symlink to /proc/self/mounts.
457 (false-if-exception
458 (delete-file "/root/etc/mtab"))
459 (mkdir-p "/root/etc")
460 (symlink "/proc/self/mounts" "/root/etc/mtab"))
461
462(define (switch-root root)
463 "Switch to ROOT as the root file system, in a way similar to what
464util-linux' switch_root(8) does."
465 (move-essential-file-systems root)
466 (chdir root)
467
468 ;; Since we're about to 'rm -rf /', try to make sure we're on an initrd.
469 ;; TODO: Use 'statfs' to check the fs type, like klibc does.
470 (when (or (not (file-exists? "/init")) (directory-exists? "/home"))
471 (format (current-error-port)
472 "The root file system is probably not an initrd; \
473bailing out.~%root contents: ~s~%" (scandir "/"))
474 (force-output (current-error-port))
475 (exit 1))
476
477 ;; Delete files from the old root, without crossing mount points (assuming
478 ;; there are no mount points in sub-directories.) That means we're leaving
479 ;; the empty ROOT directory behind us, but that's OK.
480 (let ((root-device (stat:dev (stat "/"))))
481 (for-each (lambda (file)
482 (unless (member file '("." ".."))
483 (let* ((file (string-append "/" file))
484 (device (stat:dev (lstat file))))
485 (when (= device root-device)
486 (delete-file-recursively file)))))
487 (scandir "/")))
488
489 ;; Make ROOT the new root.
490 (mount root "/" "" MS_MOVE)
491 (chroot ".")
492 (chdir "/")
493
494 (when (file-exists? "/dev/console")
495 ;; Close the standard file descriptors since they refer to the old
496 ;; /dev/console, and reopen them.
497 (let ((console (open-file "/dev/console" "r+b0")))
498 (for-each close-fdes '(0 1 2))
499
500 (dup2 (fileno console) 0)
501 (dup2 (fileno console) 1)
502 (dup2 (fileno console) 2)
503
504 (close-port console))))
505
506
507(define* (boot-system #:key
508 (linux-modules '())
509 linux-module-directory
510 keymap-file
511 qemu-guest-networking?
512 volatile-root?
513 pre-mount
514 (mounts '())
515 (on-error 'debug))
516 "This procedure is meant to be called from an initrd. Boot a system by
517first loading LINUX-MODULES (a list of module names) from
518LINUX-MODULE-DIRECTORY, then installing KEYMAP-FILE with 'loadkeys' (if
519KEYMAP-FILE is true), then setting up QEMU guest networking if
520QEMU-GUEST-NETWORKING? is true, calling PRE-MOUNT, mounting the file systems
521specified in MOUNTS, and finally booting into the new root if any. The initrd
522supports the kernel command-line options 'gnu.load' and 'gnu.repl'. It also
523honors a subset of the Linux kernel command-line parameters such as
524'fsck.mode', 'resume', 'rootdelay', rootflags and rootfstype.
525
526Mount the root file system, specified by the 'root' command-line argument, if
527any.
528
529MOUNTS must be a list of <file-system> objects.
530
531When VOLATILE-ROOT? is true, the root file system is writable but any changes
532to it are lost.
533
534ON-ERROR is passed to 'call-with-error-handling'; it determines what happens
535upon error."
536 (define (root-mount-point? fs)
537 (string=? (file-system-mount-point fs) "/"))
538
539 (define (device-string->file-system-device device-string)
540 ;; The "root=SPEC" kernel command-line option always provides a string,
541 ;; but the string can represent a device, an nfs-root, a UUID, or a label.
542 ;; So check for all four.
543 (cond ((string-prefix? "/" device-string) device-string)
544 ((string-contains device-string ":/") device-string) ; nfs-root
545 ((uuid device-string) => identity)
546 (else (file-system-label device-string))))
547
548 (display "Welcome, this is GNU's early boot Guile.\n")
549 (display "Use 'gnu.repl' for an initrd REPL.\n\n")
550
551 (call-with-error-handling
552 (lambda ()
553 (mount-essential-file-systems)
554 (let* ((args (linux-command-line))
555 (to-load (find-long-option "gnu.load" args))
556 ;; If present, ‘root’ on the kernel command line takes precedence
557 ;; over the ‘device’ field of the root <file-system> record.
558 (root-device (and=> (find-long-option "root" args)
559 device-string->file-system-device))
560 (rootfstype (find-long-option "rootfstype" args))
561 (rootflags (find-long-option "rootflags" args))
562 (root-fs* (find root-mount-point? mounts))
563 (fsck.mode (find-long-option "fsck.mode" args)))
564
565 (unless (or root-fs* (and root-device rootfstype))
566 (error "no root file system or 'root' and 'rootfstype' parameters"))
567
568 ;; If present, ‘root’ on the kernel command line takes precedence over
569 ;; the ‘device’ field of the root <file-system> record; likewise for
570 ;; the 'rootfstype' and 'rootflags' arguments.
571 (define root-fs
572 (if root-fs*
573 (file-system
574 (inherit root-fs*)
575 (device (or root-device (file-system-device root-fs*)))
576 (type (or rootfstype (file-system-type root-fs*)))
577 (options (or rootflags (file-system-options root-fs*))))
578 (file-system
579 (device root-device)
580 (mount-point "/")
581 (type rootfstype)
582 (options rootflags))))
583
584 (define (check? fs)
585 (match fsck.mode
586 ("skip" #f)
587 ("force" #t)
588 (_ (file-system-check? fs)))) ; assume "auto"
589
590 (define (skip-check-if-clean? fs)
591 (match fsck.mode
592 ("force" #f)
593 (_ (file-system-skip-check-if-clean? fs))))
594
595 (define (repair fs)
596 (let ((arg (find-long-option "fsck.repair" args)))
597 (if arg
598 (match arg
599 ("no" #f)
600 ("yes" #t)
601 (_ 'preen))
602 (file-system-repair fs))))
603
604 (when (member "gnu.repl" args)
605 (start-repl))
606
607 (display "loading kernel modules...\n")
608 (load-linux-modules-from-directory linux-modules
609 linux-module-directory)
610
611 (when keymap-file
612 (let ((status (system* "loadkeys" keymap-file)))
613 (unless (zero? status)
614 ;; Emit a warning rather than abort when we cannot load
615 ;; KEYMAP-FILE.
616 (format (current-error-port)
617 "warning: 'loadkeys' exited with status ~a~%"
618 status))))
619
620 (when qemu-guest-networking?
621 (unless (configure-qemu-networking)
622 (display "network interface is DOWN\n")))
623
624 ;; A big ugly hammer, to be used only for debugging and in desperate
625 ;; situations where no proper device synchonisation is possible.
626 (let ((root-delay (and=> (find-long-option "rootdelay" args)
627 string->number)))
628 (when root-delay
629 (format #t "Pausing for rootdelay=~a seconds before mounting \
630the root file system...\n" root-delay)
631 (sleep root-delay)))
632
633 (when (procedure? pre-mount)
634 ;; Do whatever actions are needed before mounting the root file
635 ;; system--e.g., installing device mappings. Error out when the
636 ;; return value is false.
637 (unless (pre-mount)
638 (error "pre-mount actions failed")))
639
640 (unless (or (member "hibernate=noresume" args)
641 ;; Also handle the equivalent old-style argument.
642 ;; See Documentation/admin-guide/kernel-parameters.txt.
643 (member "noresume" args))
644 ;; Try to resume immediately after loading (storage) modules
645 ;; but before any on-disk file systems have been mounted.
646 (false-if-exception ; failure is not fatal
647 (resume-if-hibernated (find-long-option "resume" args))))
648
649 ;; Prepare the real root file system under /root.
650 (unless (file-exists? "/root")
651 (mkdir "/root"))
652
653 (setenv "EXT2FS_NO_MTAB_OK" "1")
654
655 ;; Mount the root file system.
656 (mount-root-file-system (canonicalize-device-spec
657 (file-system-device root-fs))
658 (file-system-type root-fs)
659 #:volatile-root? volatile-root?
660 #:flags (mount-flags->bit-mask
661 (file-system-flags root-fs))
662 #:options (file-system-options root-fs)
663 #:check? (check? root-fs)
664 #:skip-check-if-clean?
665 (skip-check-if-clean? root-fs)
666 #:repair (repair root-fs))
667
668 ;; Mount the specified non-root file systems.
669 (for-each (lambda (fs)
670 (mount-file-system fs
671 #:check? (check? fs)
672 #:skip-check-if-clean?
673 (skip-check-if-clean? fs)
674 #:repair (repair fs)))
675 (remove root-mount-point? mounts))
676
677 (setenv "EXT2FS_NO_MTAB_OK" #f)
678
679 (if to-load
680 (begin
681 (switch-root "/root")
682 (format #t "loading '~a'...\n" to-load)
683
684 (primitive-load to-load)
685
686 (format (current-error-port)
687 "boot program '~a' terminated, rebooting~%"
688 to-load)
689 (sleep 2)
690 (reboot))
691 (begin
692 (display "no boot file passed via 'gnu.load'\n")
693 (display "entering a warm and cozy REPL\n")
694 (start-repl)))))
695 #:on-error on-error))
696
697(define-record-type <linux-console>
698 (make-linux-console device can-read? can-write? can-unblank?
699 enabled? preferred? primary? printk? braille?
700 safe-when-cpu-offline? major minor virtual?)
701 linux-console?
702 (device linux-console-device)
703 (can-read? linux-console-can-read?)
704 (can-write? linux-console-can-write?)
705 (can-unblank? linux-console-can-unblank?)
706 (enabled? linux-console-enabled?)
707 (preferred? linux-console-preferred?)
708 (primary? linux-console-primary?)
709 (printk? linux-console-printk?)
710 (braille? linux-console-braille?)
711 (safe-when-cpu-offline? linux-console-safe-when-cpu-offline?)
712 (major linux-console-major)
713 (minor linux-console-minor)
714 (virtual? linux-console-virtual?))
715
716(define* (read-linux-consoles #:optional (consoles-file "/proc/consoles"))
717 "Parses CONSOLES-FILE and returns a list of <linux-console> records."
718 (if (not (file-exists? consoles-file))
719 '()
720 (with-input-from-file consoles-file
721 (lambda ()
722 (let ((line-regex (make-regexp
723 "^([^ ]+)[ ]+(.+)[ ]+([0-9]+):([0-9]+)$"))
724 (virt-regex (make-regexp "^tty[0-9]+$")))
725 (let loop ((line (read-line))
726 (results '()))
727 (cond
728 ((eof-object? line)
729 (reverse results))
730 ((regexp-exec line-regex line)
731 => (lambda (m)
732 (let* ((dev (match:substring m 1))
733 (flags (match:substring m 2))
734 (major (string->number (match:substring m 3)))
735 (minor (string->number (match:substring m 4)))
736 (virtual? (regexp-exec virt-regex dev))
737 (has? (lambda (c)
738 (string-any (lambda (f) (char=? f c)) flags))))
739 (loop (read-line)
740 (cons (make-linux-console
741 dev
742 (has? #\R) (has? #\W) (has? #\U) (has? #\E)
743 (has? #\C) (has? #\B) (has? #\p) (has? #\b)
744 (has? #\a)
745 major minor virtual?)
746 results)))))
747 (else (loop (read-line) results)))))))))
748
749;;; linux-boot.scm ends here