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