Move operating system helpers from (guix build …) to (gnu build …).
[jackhill/guix/guix.git] / gnu / build / linux-initrd.scm
CommitLineData
88840f02 1;;; GNU Guix --- Functional package management for GNU
b97c95eb 2;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
88840f02
LC
3;;;
4;;; This file is part of GNU Guix.
5;;;
6;;; GNU Guix is free software; you can redistribute it and/or modify it
7;;; under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 3 of the License, or (at
9;;; your option) any later version.
10;;;
11;;; GNU Guix is distributed in the hope that it will be useful, but
12;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18
548f7a8f 19(define-module (gnu build linux-initrd)
88840f02 20 #:use-module (rnrs io ports)
85a83edb 21 #:use-module (rnrs bytevectors)
88840f02 22 #:use-module (system foreign)
e3ced65a 23 #:use-module (system repl error-handling)
d4254711
LC
24 #:autoload (system repl repl) (start-repl)
25 #:autoload (system base compile) (compile-file)
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-26)
28 #:use-module (ice-9 match)
85a83edb 29 #:use-module (ice-9 rdelim)
44ddf33e 30 #:use-module (ice-9 ftw)
d4254711 31 #:use-module (guix build utils)
88840f02
LC
32 #:export (mount-essential-file-systems
33 linux-command-line
87a52da7 34 find-long-option
d91712ee 35 make-essential-device-nodes
88840f02 36 configure-qemu-networking
85a83edb
LC
37
38 disk-partitions
39 partition-label-predicate
40 find-partition-by-label
d4c87617 41 canonicalize-device-spec
85a83edb 42
2c071ce9 43 mount-flags->bit-mask
023f391c 44 check-file-system
83bcd0b8 45 mount-file-system
89bf140b 46 bind-mount
85a83edb 47
88840f02 48 load-linux-module*
d4254711
LC
49 device-number
50 boot-system))
88840f02
LC
51
52;;; Commentary:
53;;;
54;;; Utility procedures useful in a Linux initial RAM disk (initrd). Note that
55;;; many of these use procedures not yet available in vanilla Guile (`mount',
56;;; `load-linux-module', etc.); these are provided by a Guile patch used in
57;;; the GNU distribution.
58;;;
59;;; Code:
60
61(define* (mount-essential-file-systems #:key (root "/"))
62 "Mount /proc and /sys under ROOT."
63 (define (scope dir)
64 (string-append root
65 (if (string-suffix? "/" root)
66 ""
67 "/")
68 dir))
69
70 (unless (file-exists? (scope "proc"))
71 (mkdir (scope "proc")))
72 (mount "none" (scope "proc") "proc")
73
74 (unless (file-exists? (scope "sys"))
75 (mkdir (scope "sys")))
76 (mount "none" (scope "sys") "sysfs"))
77
1d462832
LC
78(define (move-essential-file-systems root)
79 "Move currently mounted essential file systems to ROOT."
80 (for-each (lambda (dir)
81 (let ((target (string-append root dir)))
82 (unless (file-exists? target)
83 (mkdir target))
84 (mount dir target "" MS_MOVE)))
85 '("/proc" "/sys")))
86
88840f02
LC
87(define (linux-command-line)
88 "Return the Linux kernel command line as a list of strings."
89 (string-tokenize
90 (call-with-input-file "/proc/cmdline"
91 get-string-all)))
92
87a52da7
LC
93(define (find-long-option option arguments)
94 "Find OPTION among ARGUMENTS, where OPTION is something like \"--load\".
95Return the value associated with OPTION, or #f on failure."
96 (let ((opt (string-append option "=")))
97 (and=> (find (cut string-prefix? opt <>)
98 arguments)
99 (lambda (arg)
100 (substring arg (+ 1 (string-index arg #\=)))))))
101
85a83edb
LC
102(define-syntax %ext2-endianness
103 ;; Endianness of ext2 file systems.
104 (identifier-syntax (endianness little)))
105
106;; Offset in bytes of interesting parts of an ext2 superblock. See
107;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
108;; TODO: Use "packed structs" from Guile-OpenGL or similar.
109(define-syntax %ext2-sblock-magic (identifier-syntax 56))
110(define-syntax %ext2-sblock-creator-os (identifier-syntax 72))
111(define-syntax %ext2-sblock-uuid (identifier-syntax 104))
112(define-syntax %ext2-sblock-volume-name (identifier-syntax 120))
113
114(define (read-ext2-superblock device)
115 "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
116if DEVICE does not contain an ext2 file system."
117 (define %ext2-magic
118 ;; The magic bytes that identify an ext2 file system.
119 #xef53)
120
d266b793
LC
121 (define superblock-size
122 ;; Size of the interesting part of an ext2 superblock.
123 264)
124
125 (define block
126 ;; The superblock contents.
127 (make-bytevector superblock-size))
128
85a83edb
LC
129 (call-with-input-file device
130 (lambda (port)
131 (seek port 1024 SEEK_SET)
d266b793
LC
132
133 ;; Note: work around <http://bugs.gnu.org/17466>.
134 (and (eqv? superblock-size (get-bytevector-n! port block 0
135 superblock-size))
136 (let ((magic (bytevector-u16-ref block %ext2-sblock-magic
137 %ext2-endianness)))
138 (and (= magic %ext2-magic)
139 block))))))
85a83edb
LC
140
141(define (ext2-superblock-uuid sblock)
142 "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
143 (let ((uuid (make-bytevector 16)))
144 (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16)
145 uuid))
146
147(define (ext2-superblock-volume-name sblock)
148 "Return the volume name of SBLOCK as a string of at most 16 characters, or
149#f if SBLOCK has no volume name."
150 (let ((bv (make-bytevector 16)))
151 (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16)
152
153 ;; This is a Latin-1, nul-terminated string.
154 (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
155 (if (null? bytes)
156 #f
157 (list->string (map integer->char bytes))))))
158
159(define (disk-partitions)
160 "Return the list of device names corresponding to valid disk partitions."
161 (define (partition? major minor)
162 (let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor)))
163 (catch 'system-error
164 (lambda ()
165 (not (zero? (call-with-input-file marker read))))
166 (lambda args
167 (if (= ENOENT (system-error-errno args))
168 #f
169 (apply throw args))))))
170
171 (call-with-input-file "/proc/partitions"
172 (lambda (port)
173 ;; Skip the two header lines.
174 (read-line port)
175 (read-line port)
176
177 ;; Read each subsequent line, and extract the last space-separated
178 ;; field.
179 (let loop ((parts '()))
180 (let ((line (read-line port)))
181 (if (eof-object? line)
182 (reverse parts)
183 (match (string-tokenize line)
184 (((= string->number major) (= string->number minor)
185 blocks name)
186 (if (partition? major minor)
187 (loop (cons name parts))
188 (loop parts))))))))))
189
190(define (partition-label-predicate label)
191 "Return a procedure that, when applied to a partition name such as \"sda1\",
192return #t if that partition's volume name is LABEL."
193 (lambda (part)
194 (let* ((device (string-append "/dev/" part))
009d8311
LC
195 (sblock (catch 'system-error
196 (lambda ()
197 (read-ext2-superblock device))
198 (lambda args
199 ;; When running on the hand-made /dev,
200 ;; 'disk-partitions' could return partitions for which
201 ;; we have no /dev node. Handle that gracefully.
202 (if (= ENOENT (system-error-errno args))
203 (begin
204 (format (current-error-port)
205 "warning: device '~a' not found~%"
206 device)
207 #f)
208 (apply throw args))))))
85a83edb 209 (and sblock
1bb784ea
LC
210 (let ((volume (ext2-superblock-volume-name sblock)))
211 (and volume
212 (string=? volume label)))))))
85a83edb
LC
213
214(define (find-partition-by-label label)
215 "Return the first partition found whose volume name is LABEL, or #f if none
216were found."
217 (and=> (find (partition-label-predicate label)
218 (disk-partitions))
219 (cut string-append "/dev/" <>)))
220
2405858a
LC
221(define* (canonicalize-device-spec spec #:optional (title 'any))
222 "Return the device name corresponding to SPEC. TITLE is a symbol, one of
223the following:
224
225 • 'device', in which case SPEC is known to designate a device node--e.g.,
226 \"/dev/sda1\";
227 • 'label', in which case SPEC is known to designate a partition label--e.g.,
228 \"my-root-part\";
229 • 'any', in which case SPEC can be anything.
230"
231 (define max-trials
5c3eb14e
LC
232 ;; Number of times we retry partition label resolution, 1 second per
233 ;; trial. Note: somebody reported a delay of 16 seconds (!) before their
234 ;; USB key would be detected by the kernel, so we must wait for at least
235 ;; this long.
236 20)
2405858a
LC
237
238 (define canonical-title
239 ;; The realm of canonicalization.
240 (if (eq? title 'any)
241 (if (string-prefix? "/" spec)
242 'device
243 'label)
244 title))
245
246 (case canonical-title
247 ((device)
248 ;; Nothing to do.
249 spec)
250 ((label)
251 ;; Resolve the label.
252 (let loop ((count 0))
253 (let ((device (find-partition-by-label spec)))
254 (or device
255 ;; Some devices take a bit of time to appear, most notably USB
256 ;; storage devices. Thus, wait for the device to appear.
257 (if (> count max-trials)
e3ced65a 258 (error "failed to resolve partition label" spec)
2405858a 259 (begin
5c3eb14e
LC
260 (format #t "waiting for partition '~a' to appear...~%"
261 spec)
2405858a
LC
262 (sleep 1)
263 (loop (+ 1 count))))))))
264 ;; TODO: Add support for UUIDs.
265 (else
266 (error "unknown device title" title))))
85a83edb 267
ac52e80b
LC
268(define* (make-disk-device-nodes base major #:optional (minor 0))
269 "Make the block device nodes around BASE (something like \"/root/dev/sda\")
270with the given MAJOR number, starting with MINOR."
271 (mknod base 'block-special #o644 (device-number major minor))
272 (let loop ((i 1))
273 (when (< i 6)
274 (mknod (string-append base (number->string i))
275 'block-special #o644 (device-number major (+ minor i)))
276 (loop (+ i 1)))))
277
d91712ee
LC
278(define* (make-essential-device-nodes #:key (root "/"))
279 "Make essential device nodes under ROOT/dev."
280 ;; The hand-made udev!
281
282 (define (scope dir)
283 (string-append root
284 (if (string-suffix? "/" root)
285 ""
286 "/")
287 dir))
288
289 (unless (file-exists? (scope "dev"))
290 (mkdir (scope "dev")))
291
fc4bc4b6 292 ;; Make the device nodes for SCSI disks.
ac52e80b
LC
293 (make-disk-device-nodes (scope "dev/sda") 8)
294 (make-disk-device-nodes (scope "dev/sdb") 8 16)
295 (make-disk-device-nodes (scope "dev/sdc") 8 32)
296 (make-disk-device-nodes (scope "dev/sdd") 8 48)
297
298 ;; SCSI CD-ROM devices (aka. "/dev/sr0" etc.).
299 (mknod (scope "dev/scd0") 'block-special #o644 (device-number 11 0))
300 (mknod (scope "dev/scd1") 'block-special #o644 (device-number 11 1))
fc4bc4b6
LC
301
302 ;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM.
ac52e80b 303 (make-disk-device-nodes (scope "dev/vda") 252)
d91712ee 304
c04c6ff6
LC
305 ;; Memory (used by Xorg's VESA driver.)
306 (mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1))
307 (mknod (scope "dev/kmem") 'char-special #o640 (device-number 1 2))
308
1c221510
LC
309 ;; Inputs (used by Xorg.)
310 (unless (file-exists? (scope "dev/input"))
311 (mkdir (scope "dev/input")))
312 (mknod (scope "dev/input/mice") 'char-special #o640 (device-number 13 63))
313 (mknod (scope "dev/input/mouse0") 'char-special #o640 (device-number 13 32))
314 (mknod (scope "dev/input/event0") 'char-special #o640 (device-number 13 64))
315
9b4a163a
LC
316 ;; System console. This node is magically created by the kernel on the
317 ;; initrd's root, so don't try to create it in that case.
318 (unless (string=? root "/")
319 (mknod (scope "dev/console") 'char-special #o600
320 (device-number 5 1)))
321
d91712ee 322 ;; TTYs.
29804e6e
LC
323 (mknod (scope "dev/tty") 'char-special #o600
324 (device-number 5 0))
289773c1 325 (chmod (scope "dev/tty") #o666)
d91712ee
LC
326 (let loop ((n 0))
327 (and (< n 50)
328 (let ((name (format #f "dev/tty~a" n)))
29804e6e 329 (mknod (scope name) 'char-special #o600
d91712ee
LC
330 (device-number 4 n))
331 (loop (+ 1 n)))))
332
7f17ff78
LC
333 ;; Serial line.
334 (mknod (scope "dev/ttyS0") 'char-special #o660
335 (device-number 4 64))
336
c9c88118
LC
337 ;; Pseudo ttys.
338 (mknod (scope "dev/ptmx") 'char-special #o666
339 (device-number 5 2))
289773c1 340 (chmod (scope "dev/ptmx") #o666)
c9c88118 341
c865a878 342 ;; Create /dev/pts; it will be mounted later, at boot time.
c9c88118
LC
343 (unless (file-exists? (scope "dev/pts"))
344 (mkdir (scope "dev/pts")))
c9c88118 345
37c825eb
LC
346 ;; Rendez-vous point for syslogd.
347 (mknod (scope "dev/log") 'socket #o666 0)
348 (mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11))
349
289773c1
LC
350 ;; Other useful nodes, notably relied on by guix-daemon.
351 (for-each (match-lambda
352 ((file major minor)
353 (mknod (scope file) 'char-special #o666
354 (device-number major minor))
355 (chmod (scope file) #o666)))
356 '(("dev/null" 1 3)
357 ("dev/zero" 1 5)
358 ("dev/full" 1 7)
359 ("dev/random" 1 8)
360 ("dev/urandom" 1 9)))
361
362 (symlink "/proc/self/fd" (scope "dev/fd"))
363 (symlink "/proc/self/fd/0" (scope "dev/stdin"))
364 (symlink "/proc/self/fd/1" (scope "dev/stdout"))
1c96c1bb
LC
365 (symlink "/proc/self/fd/2" (scope "dev/stderr"))
366
3035b50f
LC
367 ;; Loopback devices.
368 (let loop ((i 0))
369 (when (< i 8)
370 (mknod (scope (string-append "dev/loop" (number->string i)))
371 'block-special #o660
372 (device-number 7 i))
373 (loop (+ 1 i))))
374
1c96c1bb
LC
375 ;; File systems in user space (FUSE).
376 (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229)))
d91712ee 377
88840f02
LC
378(define %host-qemu-ipv4-address
379 (inet-pton AF_INET "10.0.2.10"))
380
381(define* (configure-qemu-networking #:optional (interface "eth0"))
382 "Setup the INTERFACE network interface and /etc/resolv.conf according to
383QEMU's default networking settings (see net/slirp.c in QEMU for default
384networking values.) Return #t if INTERFACE is up, #f otherwise."
385 (display "configuring QEMU networking...\n")
386 (let* ((sock (socket AF_INET SOCK_STREAM 0))
387 (address (make-socket-address AF_INET %host-qemu-ipv4-address 0))
388 (flags (network-interface-flags sock interface)))
389 (set-network-interface-address sock interface address)
390 (set-network-interface-flags sock interface (logior flags IFF_UP))
391
c0b9213d
LC
392 ;; Hello! We used to create /etc/resolv.conf here, with "nameserver
393 ;; 10.0.2.3\n". However, with Linux-libre 3.16, we're getting ENOSPC.
394 ;; And since it's actually unnecessary, it's gone.
88840f02
LC
395
396 (logand (network-interface-flags sock interface) IFF_UP)))
397
83bcd0b8
LC
398;; Linux mount flags, from libc's <sys/mount.h>.
399(define MS_RDONLY 1)
2c071ce9
LC
400(define MS_NOSUID 2)
401(define MS_NODEV 4)
402(define MS_NOEXEC 8)
83bcd0b8 403(define MS_BIND 4096)
1d462832 404(define MS_MOVE 8192)
4919d684 405
89bf140b
LC
406(define (bind-mount source target)
407 "Bind-mount SOURCE at TARGET."
89bf140b
LC
408 (mount source target "" MS_BIND))
409
88840f02
LC
410(define (load-linux-module* file)
411 "Load Linux module from FILE, the name of a `.ko' file."
412 (define (slurp module)
413 (call-with-input-file file get-bytevector-all))
414
415 (load-linux-module (slurp file)))
416
417(define (device-number major minor)
418 "Return the device number for the device with MAJOR and MINOR, for use as
419the last argument of `mknod'."
420 (+ (* major 256) minor))
421
7d57cfd3
LC
422(define (pidof program)
423 "Return the PID of the first presumed instance of PROGRAM."
424 (let ((program (basename program)))
425 (find (lambda (pid)
426 (let ((exe (format #f "/proc/~a/exe" pid)))
427 (and=> (false-if-exception (readlink exe))
428 (compose (cut string=? program <>) basename))))
429 (filter-map string->number (scandir "/proc")))))
430
83bcd0b8 431(define* (mount-root-file-system root type
3c05b4bc 432 #:key volatile-root? (unionfs "unionfs"))
83bcd0b8
LC
433 "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT?
434is true, mount ROOT read-only and make it a union with a writable tmpfs using
435UNIONFS."
7d57cfd3
LC
436 (define (mark-as-not-killable pid)
437 ;; Tell the 'user-processes' dmd service that PID must be kept alive when
438 ;; shutting down.
439 (mkdir-p "/root/etc/dmd")
440 (let ((port (open-file "/root/etc/dmd/do-not-kill" "a")))
441 (chmod port #o600)
442 (write pid port)
443 (newline port)
444 (close-port port)))
445
83bcd0b8
LC
446 (catch #t
447 (lambda ()
448 (if volatile-root?
449 (begin
450 (mkdir-p "/real-root")
451 (mount root "/real-root" type MS_RDONLY)
452 (mkdir-p "/rw-root")
453 (mount "none" "/rw-root" "tmpfs")
454
455 ;; We want read-write /dev nodes.
456 (make-essential-device-nodes #:root "/rw-root")
457
9b9148d8
LC
458 ;; Make /root a union of the tmpfs and the actual root. Use
459 ;; 'max_files' to set a high RLIMIT_NOFILE for the unionfs process
460 ;; itself. Failing to do that, we quickly run out of file
461 ;; descriptors; see <http://bugs.gnu.org/17827>.
83bcd0b8 462 (unless (zero? (system* unionfs "-o"
9b9148d8 463 "cow,allow_other,use_ino,suid,dev,max_files=65536"
83bcd0b8
LC
464 "/rw-root=RW:/real-root=RO"
465 "/root"))
7d57cfd3
LC
466 (error "unionfs failed"))
467
468 ;; Make sure unionfs remains alive till the end. Because
469 ;; 'fuse_daemonize' doesn't tell the PID of the forked daemon, we
470 ;; have to resort to 'pidof' here.
471 (mark-as-not-killable (pidof unionfs)))
3c05b4bc
LC
472 (begin
473 (check-file-system root type)
474 (mount root "/root" type))))
83bcd0b8
LC
475 (lambda args
476 (format (current-error-port) "exception while mounting '~a': ~s~%"
477 root args)
b1995341
LC
478 (start-repl)))
479
480 (copy-file "/proc/mounts" "/root/etc/mtab"))
83bcd0b8 481
3c05b4bc
LC
482(define (check-file-system device type)
483 "Run a file system check of TYPE on DEVICE."
484 (define fsck
485 (string-append "fsck." type))
486
487 (let ((status (system* fsck "-v" "-p" device)))
488 (match (status:exit-val status)
489 (0
490 #t)
491 (1
492 (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
493 fsck device))
494 (2
495 (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
496 fsck device)
497 (sleep 3)
498 (reboot))
499 (code
500 (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
501 fsck code device)
502 (start-repl)))))
503
2c071ce9
LC
504(define (mount-flags->bit-mask flags)
505 "Return the number suitable for the 'flags' argument of 'mount' that
506corresponds to the symbols listed in FLAGS."
507 (let loop ((flags flags))
508 (match flags
509 (('read-only rest ...)
510 (logior MS_RDONLY (loop rest)))
511 (('bind-mount rest ...)
512 (logior MS_BIND (loop rest)))
513 (('no-suid rest ...)
514 (logior MS_NOSUID (loop rest)))
515 (('no-dev rest ...)
516 (logior MS_NODEV (loop rest)))
517 (('no-exec rest ...)
518 (logior MS_NOEXEC (loop rest)))
519 (()
520 0))))
521
83bcd0b8
LC
522(define* (mount-file-system spec #:key (root "/root"))
523 "Mount the file system described by SPEC under ROOT. SPEC must have the
524form:
525
d4c87617 526 (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
83bcd0b8
LC
527
528DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
3c05b4bc
LC
529FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
530run a file system check."
83bcd0b8 531 (match spec
d4c87617
LC
532 ((source title mount-point type (flags ...) options check?)
533 (let ((source (canonicalize-device-spec source title))
85a83edb 534 (mount-point (string-append root "/" mount-point)))
3c05b4bc
LC
535 (when check?
536 (check-file-system source type))
83bcd0b8 537 (mkdir-p mount-point)
2c071ce9 538 (mount source mount-point type (mount-flags->bit-mask flags)
83bcd0b8
LC
539 (if options
540 (string->pointer options)
b1995341
LC
541 %null-pointer))
542
543 ;; Update /etc/mtab.
544 (mkdir-p (string-append root "/etc"))
02139eb9 545 (let ((port (open-file (string-append root "/etc/mtab") "a")))
b1995341 546 (format port "~a ~a ~a ~a 0 0~%"
2c071ce9 547 source mount-point type (or options ""))
b1995341 548 (close-port port))))))
83bcd0b8 549
1d462832
LC
550(define (switch-root root)
551 "Switch to ROOT as the root file system, in a way similar to what
552util-linux' switch_root(8) does."
553 (move-essential-file-systems root)
554 (chdir root)
26a728eb
LC
555
556 ;; Since we're about to 'rm -rf /', try to make sure we're on an initrd.
557 ;; TODO: Use 'statfs' to check the fs type, like klibc does.
558 (when (or (not (file-exists? "/init")) (directory-exists? "/home"))
559 (format (current-error-port)
560 "The root file system is probably not an initrd; \
561bailing out.~%root contents: ~s~%" (scandir "/"))
562 (force-output (current-error-port))
563 (exit 1))
564
565 ;; Delete files from the old root, without crossing mount points (assuming
566 ;; there are no mount points in sub-directories.) That means we're leaving
567 ;; the empty ROOT directory behind us, but that's OK.
568 (let ((root-device (stat:dev (stat "/"))))
569 (for-each (lambda (file)
570 (unless (member file '("." ".."))
571 (let* ((file (string-append "/" file))
572 (device (stat:dev (lstat file))))
573 (when (= device root-device)
574 (delete-file-recursively file)))))
575 (scandir "/")))
576
577 ;; Make ROOT the new root.
1d462832 578 (mount root "/" "" MS_MOVE)
26a728eb
LC
579 (chroot ".")
580 (chdir "/")
581
582 (when (file-exists? "/dev/console")
583 ;; Close the standard file descriptors since they refer to the old
474b832d
LC
584 ;; /dev/console, and reopen them.
585 (let ((console (open-file "/dev/console" "r+b0")))
586 (for-each close-fdes '(0 1 2))
587
588 (dup2 (fileno console) 0)
589 (dup2 (fileno console) 1)
590 (dup2 (fileno console) 2)
591
592 (close-port console))))
1d462832 593
85a83edb 594\f
d4254711
LC
595(define* (boot-system #:key
596 (linux-modules '())
597 qemu-guest-networking?
598 guile-modules-in-chroot?
3c05b4bc 599 volatile-root?
d4254711
LC
600 (mounts '()))
601 "This procedure is meant to be called from an initrd. Boot a system by
602first loading LINUX-MODULES, then setting up QEMU guest networking if
603QEMU-GUEST-NETWORKING? is true, mounting the file systems specified in MOUNTS,
604and finally booting into the new root if any. The initrd supports kernel
605command-line options '--load', '--root', and '--repl'.
606
3c05b4bc
LC
607Mount the root file system, specified by the '--root' command-line argument,
608if any.
03ddfaf5 609
83bcd0b8 610MOUNTS must be a list suitable for 'mount-file-system'.
d4254711
LC
611
612When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
44ddf33e
LC
613the new root.
614
615When VOLATILE-ROOT? is true, the root file system is writable but any changes
616to it are lost."
3c05b4bc
LC
617 (define root-mount-point?
618 (match-lambda
d4c87617 619 ((device _ "/" _ ...) #t)
3c05b4bc
LC
620 (_ #f)))
621
622 (define root-fs-type
623 (or (any (match-lambda
d4c87617 624 ((device _ "/" type _ ...) type)
3c05b4bc
LC
625 (_ #f))
626 mounts)
627 "ext4"))
628
d4254711
LC
629 (display "Welcome, this is GNU's early boot Guile.\n")
630 (display "Use '--repl' for an initrd REPL.\n\n")
631
e3ced65a
LC
632 (call-with-error-handling
633 (lambda ()
634 (mount-essential-file-systems)
635 (let* ((args (linux-command-line))
636 (to-load (find-long-option "--load" args))
637 (root (find-long-option "--root" args)))
638
639 (when (member "--repl" args)
640 (start-repl))
641
642 (display "loading kernel modules...\n")
643 (for-each (compose load-linux-module*
644 (cut string-append "/modules/" <>))
645 linux-modules)
646
647 (when qemu-guest-networking?
648 (unless (configure-qemu-networking)
649 (display "network interface is DOWN\n")))
650
651 ;; Make /dev nodes.
652 (make-essential-device-nodes)
653
654 ;; Prepare the real root file system under /root.
655 (unless (file-exists? "/root")
656 (mkdir "/root"))
657 (if root
658 (mount-root-file-system (canonicalize-device-spec root)
659 root-fs-type
660 #:volatile-root? volatile-root?)
661 (mount "none" "/root" "tmpfs"))
662
663 (unless (file-exists? "/root/dev")
664 (mkdir "/root/dev")
665 (make-essential-device-nodes #:root "/root"))
666
667 ;; Mount the specified file systems.
668 (for-each mount-file-system
669 (remove root-mount-point? mounts))
670
671 (when guile-modules-in-chroot?
672 ;; Copy the directories that contain .scm and .go files so that the
673 ;; child process in the chroot can load modules (we would bind-mount
674 ;; them but for some reason that fails with EINVAL -- XXX).
675 (mkdir-p "/root/share")
676 (mkdir-p "/root/lib")
677 (mount "none" "/root/share" "tmpfs")
678 (mount "none" "/root/lib" "tmpfs")
679 (copy-recursively "/share" "/root/share"
680 #:log (%make-void-port "w"))
681 (copy-recursively "/lib" "/root/lib"
682 #:log (%make-void-port "w")))
683
684 (if to-load
685 (begin
686 (switch-root "/root")
687 (format #t "loading '~a'...\n" to-load)
688
e3ced65a
LC
689 ;; TODO: Remove /lib, /share, and /loader.go.
690 (primitive-load to-load)
691
692 (format (current-error-port)
693 "boot program '~a' terminated, rebooting~%"
694 to-load)
695 (sleep 2)
696 (reboot))
697 (begin
698 (display "no boot file passed via '--load'\n")
699 (display "entering a warm and cozy REPL\n")
700 (start-repl)))))))
d4254711 701
88840f02 702;;; linux-initrd.scm ends here