gnu/build/linux-boot.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu build linux-boot)
  21   #:use-module (rnrs io ports)
  22   #:use-module (system repl error-handling)
  23   #:autoload   (system repl repl) (start-repl)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-9)
  26   #:use-module (srfi srfi-26)
  27   #:use-module (ice-9 match)
  28   #:use-module (ice-9 rdelim)
  29   #:use-module (ice-9 regex)
  30   #:use-module (ice-9 ftw)
  31   #:use-module (guix build utils)
  32   #:use-module ((guix build syscalls)
  33                 #:hide (file-system-type))
  34   #:use-module (gnu build linux-modules)
  35   #:use-module (gnu build file-systems)
  36   #:use-module (gnu system file-systems)
  37   #:export (mount-essential-file-systems
  38             linux-command-line
  39             find-long-option
  40             make-essential-device-nodes
  41             make-static-device-nodes
  42             configure-qemu-networking
  43
  44             bind-mount
  45             device-number
  46             boot-system))
  47
  48 ;;; Commentary:
  49 ;;;
  50 ;;; Utility procedures useful in a Linux initial RAM disk (initrd).  Note that
  51 ;;; many of these use procedures not yet available in vanilla Guile (`mount',
  52 ;;; `load-linux-module', etc.); these are provided by a Guile patch used in
  53 ;;; the GNU distribution.
  54 ;;;
  55 ;;; Code:
  56
  57 (define* (mount-essential-file-systems #:key (root "/"))
  58   "Mount /dev, /proc, and /sys under ROOT."
  59   (define (scope dir)
  60     (string-append root
  61                    (if (string-suffix? "/" root)
  62                        ""
  63                        "/")
  64                    dir))
  65
  66   (unless (file-exists? (scope "proc"))
  67     (mkdir (scope "proc")))
  68   (mount "none" (scope "proc") "proc")
  69
  70   (unless (file-exists? (scope "dev"))
  71     (mkdir (scope "dev")))
  72   (mount "none" (scope "dev") "devtmpfs")
  73
  74   (unless (file-exists? (scope "sys"))
  75     (mkdir (scope "sys")))
  76   (mount "none" (scope "sys") "sysfs"))
  77
  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             '("/dev" "/proc" "/sys")))
  86
  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
  93 (define (find-long-option option arguments)
  94   "Find OPTION among ARGUMENTS, where OPTION is something like \"--load\".
  95 Return 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
 102 (define* (make-disk-device-nodes base major #:optional (minor 0))
 103   "Make the block device nodes around BASE (something like \"/root/dev/sda\")
 104 with the given MAJOR number, starting with MINOR."
 105   (mknod base 'block-special #o644 (device-number major minor))
 106   (let loop ((i 1))
 107     (when (< i 16)
 108       (mknod (string-append base (number->string i))
 109              'block-special #o644 (device-number major (+ minor i)))
 110       (loop (+ i 1)))))
 111
 112 ;; Representation of a /dev node.
 113 (define-record-type <device-node>
 114   (device-node name type major minor module)
 115   device-node?
 116   (name device-node-name)
 117   (type device-node-type)
 118   (major device-node-major)
 119   (minor device-node-minor)
 120   (module device-node-module))
 121
 122 (define (read-static-device-nodes port)
 123   "Read from PORT a list of <device-node> written in the format used by
 124 /lib/modules/*/*.devname files."
 125   (let loop ((line (read-line port)))
 126     (if (eof-object? line)
 127       '()
 128       (match (string-split line #\space)
 129        (((? (cut string-prefix? "#" <>)) _ ...)
 130         (loop (read-line port)))
 131        ((module-name device-name device-spec)
 132         (let* ((device-parts
 133                (string-match "([bc])([0-9][0-9]*):([0-9][0-9]*)"
 134                              device-spec))
 135                (type-string (match:substring device-parts 1))
 136                (type (match type-string
 137                       ("c" 'char-special)
 138                       ("b" 'block-special)))
 139                (major-string (match:substring device-parts 2))
 140                (major (string->number major-string 10))
 141                (minor-string (match:substring device-parts 3))
 142                (minor (string->number minor-string 10)))
 143           (cons (device-node device-name type major minor module-name)
 144                 (loop (read-line port)))))
 145        (_
 146         (begin
 147           (format (current-error-port)
 148                   "read-static-device-nodes: ignored devname line '~a'~%" line)
 149           (loop (read-line port))))))))
 150
 151 (define* (mkdir-p* dir #:optional (mode #o755))
 152   "This is a variant of 'mkdir-p' that works around
 153 <http://bugs.gnu.org/24659> by passing MODE explicitly in each 'mkdir' call."
 154   (define absolute?
 155     (string-prefix? "/" dir))
 156
 157   (define not-slash
 158     (char-set-complement (char-set #\/)))
 159
 160   (let loop ((components (string-tokenize dir not-slash))
 161              (root       (if absolute?
 162                              ""
 163                              ".")))
 164     (match components
 165       ((head tail ...)
 166        (let ((path (string-append root "/" head)))
 167          (catch 'system-error
 168            (lambda ()
 169              (mkdir path mode)
 170              (loop tail path))
 171            (lambda args
 172              (if (= EEXIST (system-error-errno args))
 173                  (loop tail path)
 174                  (apply throw args))))))
 175       (() #t))))
 176
 177 (define (report-system-error name . args)
 178   "Report a system error for the file NAME."
 179   (let ((errno (system-error-errno args)))
 180     (format (current-error-port) "could not create '~a': ~a~%" name
 181             (strerror errno))))
 182
 183 ;; Catch a system-error, log it and don't die from it.
 184 (define-syntax-rule (catch-system-error name exp)
 185   (catch 'system-error
 186     (lambda ()
 187       exp)
 188     (lambda args
 189       (apply report-system-error name args))))
 190
 191 ;; Create a device node like the <device-node> passed here on the file system.
 192 (define create-device-node
 193   (match-lambda
 194     (($ <device-node> xname type major minor module)
 195      (let ((name (string-append "/dev/" xname)))
 196        (mkdir-p* (dirname name))
 197        (catch-system-error name
 198          (mknod name type #o600 (device-number major minor)))))))
 199
 200 (define* (make-static-device-nodes linux-release-module-directory)
 201   "Create static device nodes required by the given Linux release.
 202 This is required in order to solve a chicken-or-egg problem:
 203 The Linux kernel has a feature to autoload modules when a device is first
 204 accessed.
 205 And udev has a feature to set the permissions of static nodes correctly
 206 when it is starting up and also to automatically create nodes when hardware
 207 is hotplugged. That leaves universal device files which are not linked to
 208 one specific hardware device. These we have to create."
 209   (let ((devname-name (string-append linux-release-module-directory "/"
 210                                      "modules.devname")))
 211     (for-each create-device-node
 212               (call-with-input-file devname-name
 213                                     read-static-device-nodes))))
 214
 215 (define* (make-essential-device-nodes #:key (root "/"))
 216   "Make essential device nodes under ROOT/dev."
 217   ;; The hand-made devtmpfs/udev!
 218
 219   (define (scope dir)
 220     (string-append root
 221                    (if (string-suffix? "/" root)
 222                        ""
 223                        "/")
 224                    dir))
 225
 226   (unless (file-exists? (scope "dev"))
 227     (mkdir (scope "dev")))
 228
 229   ;; Make the device nodes for SCSI disks.
 230   (make-disk-device-nodes (scope "dev/sda") 8)
 231   (make-disk-device-nodes (scope "dev/sdb") 8 16)
 232   (make-disk-device-nodes (scope "dev/sdc") 8 32)
 233   (make-disk-device-nodes (scope "dev/sdd") 8 48)
 234
 235   ;; SCSI CD-ROM devices (aka. "/dev/sr0" etc.).
 236   (mknod (scope "dev/scd0") 'block-special #o644 (device-number 11 0))
 237   (mknod (scope "dev/scd1") 'block-special #o644 (device-number 11 1))
 238
 239   ;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM.
 240   (make-disk-device-nodes (scope "dev/vda") 252)
 241
 242   ;; Memory (used by Xorg's VESA driver.)
 243   (mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1))
 244   (mknod (scope "dev/kmem") 'char-special #o640 (device-number 1 2))
 245
 246   ;; Inputs (used by Xorg.)
 247   (unless (file-exists? (scope "dev/input"))
 248     (mkdir (scope "dev/input")))
 249   (mknod (scope "dev/input/mice") 'char-special #o640 (device-number 13 63))
 250   (mknod (scope "dev/input/mouse0") 'char-special #o640 (device-number 13 32))
 251   (mknod (scope "dev/input/event0") 'char-special #o640 (device-number 13 64))
 252
 253   ;; System console.  This node is magically created by the kernel on the
 254   ;; initrd's root, so don't try to create it in that case.
 255   (unless (string=? root "/")
 256     (mknod (scope "dev/console") 'char-special #o600
 257            (device-number 5 1)))
 258
 259   ;; TTYs.
 260   (mknod (scope "dev/tty") 'char-special #o600
 261          (device-number 5 0))
 262   (chmod (scope "dev/tty") #o666)
 263   (let loop ((n 0))
 264     (and (< n 50)
 265          (let ((name (format #f "dev/tty~a" n)))
 266            (mknod (scope name) 'char-special #o600
 267                   (device-number 4 n))
 268            (loop (+ 1 n)))))
 269
 270   ;; Serial line.
 271   (mknod (scope "dev/ttyS0") 'char-special #o660
 272          (device-number 4 64))
 273
 274   ;; Pseudo ttys.
 275   (mknod (scope "dev/ptmx") 'char-special #o666
 276          (device-number 5 2))
 277   (chmod (scope "dev/ptmx") #o666)
 278
 279   ;; Create /dev/pts; it will be mounted later, at boot time.
 280   (unless (file-exists? (scope "dev/pts"))
 281     (mkdir (scope "dev/pts")))
 282
 283   ;; Rendez-vous point for syslogd.
 284   (mknod (scope "dev/log") 'socket #o666 0)
 285   (mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11))
 286
 287   ;; Other useful nodes, notably relied on by guix-daemon.
 288   (for-each (match-lambda
 289              ((file major minor)
 290               (mknod (scope file) 'char-special #o666
 291                      (device-number major minor))
 292               (chmod (scope file) #o666)))
 293             '(("dev/null" 1 3)
 294               ("dev/zero" 1 5)
 295               ("dev/full" 1 7)
 296               ("dev/random" 1 8)
 297               ("dev/urandom" 1 9)))
 298
 299   (symlink "/proc/self/fd" (scope "dev/fd"))
 300   (symlink "/proc/self/fd/0" (scope "dev/stdin"))
 301   (symlink "/proc/self/fd/1" (scope "dev/stdout"))
 302   (symlink "/proc/self/fd/2" (scope "dev/stderr"))
 303
 304   ;; Loopback devices.
 305   (let loop ((i 0))
 306     (when (< i 8)
 307       (mknod (scope (string-append "dev/loop" (number->string i)))
 308              'block-special #o660
 309              (device-number 7 i))
 310       (loop (+ 1 i))))
 311
 312   ;; File systems in user space (FUSE).
 313   (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229)))
 314
 315 (define %host-qemu-ipv4-address
 316   (inet-pton AF_INET "10.0.2.10"))
 317
 318 (define* (configure-qemu-networking #:optional (interface "eth0"))
 319   "Setup the INTERFACE network interface and /etc/resolv.conf according to
 320 QEMU's default networking settings (see net/slirp.c in QEMU for default
 321 networking values.)  Return #t if INTERFACE is up, #f otherwise."
 322   (display "configuring QEMU networking...\n")
 323   (let* ((sock    (socket AF_INET SOCK_STREAM 0))
 324          (address (make-socket-address AF_INET %host-qemu-ipv4-address 0))
 325          (flags   (network-interface-flags sock interface)))
 326     (set-network-interface-address sock interface address)
 327     (set-network-interface-flags sock interface (logior flags IFF_UP))
 328
 329     ;; Hello!  We used to create /etc/resolv.conf here, with "nameserver
 330     ;; 10.0.2.3\n".  However, with Linux-libre 3.16, we're getting ENOSPC.
 331     ;; And since it's actually unnecessary, it's gone.
 332
 333     (logand (network-interface-flags sock interface) IFF_UP)))
 334
 335 (define (device-number major minor)
 336   "Return the device number for the device with MAJOR and MINOR, for use as
 337 the last argument of `mknod'."
 338   (+ (* major 256) minor))
 339
 340 (define (pidof program)
 341   "Return the PID of the first presumed instance of PROGRAM."
 342   (let ((program (basename program)))
 343     (find (lambda (pid)
 344             (let ((exe (format #f "/proc/~a/exe" pid)))
 345               (and=> (false-if-exception (readlink exe))
 346                      (compose (cut string=? program <>) basename))))
 347           (filter-map string->number (scandir "/proc")))))
 348
 349 (define* (mount-root-file-system root type
 350                                  #:key volatile-root?)
 351   "Mount the root file system of type TYPE at device ROOT.  If VOLATILE-ROOT?
 352 is true, mount ROOT read-only and make it a overlay with a writable tmpfs
 353 using the kernel build-in overlayfs."
 354   (if volatile-root?
 355       (begin
 356         (mkdir-p "/real-root")
 357         (mount root "/real-root" type MS_RDONLY)
 358         (mkdir-p "/rw-root")
 359         (mount "none" "/rw-root" "tmpfs")
 360
 361         ;; Create the upperdir and the workdir of the overlayfs
 362         (mkdir-p "/rw-root/upper")
 363         (mkdir-p "/rw-root/work")
 364
 365         ;; We want read-write /dev nodes.
 366         (mkdir-p "/rw-root/upper/dev")
 367         (mount "none" "/rw-root/upper/dev" "devtmpfs")
 368
 369         ;; Make /root an overlay of the tmpfs and the actual root.
 370         (mount "none" "/root" "overlay" 0
 371                "lowerdir=/real-root,upperdir=/rw-root/upper,workdir=/rw-root/work"))
 372       (begin
 373         (check-file-system root type)
 374         (mount root "/root" type)))
 375
 376   ;; Make sure /root/etc/mtab is a symlink to /proc/self/mounts.
 377   (false-if-exception
 378     (delete-file "/root/etc/mtab"))
 379   (mkdir-p "/root/etc")
 380   (symlink "/proc/self/mounts" "/root/etc/mtab"))
 381
 382 (define (switch-root root)
 383   "Switch to ROOT as the root file system, in a way similar to what
 384 util-linux' switch_root(8) does."
 385   (move-essential-file-systems root)
 386   (chdir root)
 387
 388   ;; Since we're about to 'rm -rf /', try to make sure we're on an initrd.
 389   ;; TODO: Use 'statfs' to check the fs type, like klibc does.
 390   (when (or (not (file-exists? "/init")) (directory-exists? "/home"))
 391     (format (current-error-port)
 392             "The root file system is probably not an initrd; \
 393 bailing out.~%root contents: ~s~%" (scandir "/"))
 394     (force-output (current-error-port))
 395     (exit 1))
 396
 397   ;; Delete files from the old root, without crossing mount points (assuming
 398   ;; there are no mount points in sub-directories.)  That means we're leaving
 399   ;; the empty ROOT directory behind us, but that's OK.
 400   (let ((root-device (stat:dev (stat "/"))))
 401     (for-each (lambda (file)
 402                 (unless (member file '("." ".."))
 403                   (let* ((file   (string-append "/" file))
 404                          (device (stat:dev (lstat file))))
 405                     (when (= device root-device)
 406                       (delete-file-recursively file)))))
 407               (scandir "/")))
 408
 409   ;; Make ROOT the new root.
 410   (mount root "/" "" MS_MOVE)
 411   (chroot ".")
 412   (chdir "/")
 413
 414   (when (file-exists? "/dev/console")
 415     ;; Close the standard file descriptors since they refer to the old
 416     ;; /dev/console, and reopen them.
 417     (let ((console (open-file "/dev/console" "r+b0")))
 418       (for-each close-fdes '(0 1 2))
 419
 420       (dup2 (fileno console) 0)
 421       (dup2 (fileno console) 1)
 422       (dup2 (fileno console) 2)
 423
 424       (close-port console))))
 425
 426 \f
 427 (define* (boot-system #:key
 428                       (linux-modules '())
 429                       linux-module-directory
 430                       qemu-guest-networking?
 431                       volatile-root?
 432                       pre-mount
 433                       (mounts '())
 434                       (on-error 'debug))
 435   "This procedure is meant to be called from an initrd.  Boot a system by
 436 first loading LINUX-MODULES (a list of module names) from
 437 LINUX-MODULE-DIRECTORY, then setting up QEMU guest networking if
 438 QEMU-GUEST-NETWORKING? is true, calling PRE-MOUNT, mounting the file systems
 439 specified in MOUNTS, and finally booting into the new root if any.  The initrd
 440 supports kernel command-line options '--load', '--root', and '--repl'.
 441
 442 Mount the root file system, specified by the '--root' command-line argument,
 443 if any.
 444
 445 MOUNTS must be a list of <file-system> objects.
 446
 447 When VOLATILE-ROOT? is true, the root file system is writable but any changes
 448 to it are lost.
 449
 450 ON-ERROR is passed to 'call-with-error-handling'; it determines what happens
 451 upon error."
 452   (define (root-mount-point? fs)
 453     (string=? (file-system-mount-point fs) "/"))
 454
 455   (define root-fs-type
 456     (or (any (lambda (fs)
 457                (and (root-mount-point? fs)
 458                     (file-system-type fs)))
 459              mounts)
 460         "ext4"))
 461
 462   (define (lookup-module name)
 463     (string-append linux-module-directory "/"
 464                    (ensure-dot-ko name)))
 465
 466   (display "Welcome, this is GNU's early boot Guile.\n")
 467   (display "Use '--repl' for an initrd REPL.\n\n")
 468
 469   (call-with-error-handling
 470    (lambda ()
 471      (mount-essential-file-systems)
 472      (let* ((args    (linux-command-line))
 473             (to-load (find-long-option "--load" args))
 474             (root    (find-long-option "--root" args)))
 475
 476        (when (member "--repl" args)
 477          (start-repl))
 478
 479        (display "loading kernel modules...\n")
 480        (for-each (cut load-linux-module* <>
 481                       #:lookup-module lookup-module)
 482                  (map lookup-module linux-modules))
 483
 484        (when qemu-guest-networking?
 485          (unless (configure-qemu-networking)
 486            (display "network interface is DOWN\n")))
 487
 488        ;; Prepare the real root file system under /root.
 489        (unless (file-exists? "/root")
 490          (mkdir "/root"))
 491
 492        (when (procedure? pre-mount)
 493          ;; Do whatever actions are needed before mounting the root file
 494          ;; system--e.g., installing device mappings.  Error out when the
 495          ;; return value is false.
 496          (unless (pre-mount)
 497            (error "pre-mount actions failed")))
 498
 499        (if root
 500            (mount-root-file-system (canonicalize-device-spec root)
 501                                    root-fs-type
 502                                    #:volatile-root? volatile-root?)
 503            (mount "none" "/root" "tmpfs"))
 504
 505        ;; Mount the specified file systems.
 506        (for-each mount-file-system
 507                  (remove root-mount-point? mounts))
 508
 509        (if to-load
 510            (begin
 511              (switch-root "/root")
 512              (format #t "loading '~a'...\n" to-load)
 513
 514              (primitive-load to-load)
 515
 516              (format (current-error-port)
 517                      "boot program '~a' terminated, rebooting~%"
 518                      to-load)
 519              (sleep 2)
 520              (reboot))
 521            (begin
 522              (display "no boot file passed via '--load'\n")
 523              (display "entering a warm and cozy REPL\n")
 524              (start-repl)))))
 525    #:on-error on-error))
 526
 527 ;;; linux-initrd.scm ends here