gnu/build/linux-boot.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   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
  19 (define-module (gnu build linux-boot)
  20   #:use-module (rnrs io ports)
  21   #:use-module (system repl error-handling)
  22   #:autoload   (system repl repl) (start-repl)
  23   #:autoload   (system base compile) (compile-file)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-26)
  26   #:use-module (ice-9 match)
  27   #:use-module (ice-9 ftw)
  28   #:use-module (guix build utils)
  29   #:use-module (gnu build linux-modules)
  30   #:use-module (gnu build file-systems)
  31   #:export (mount-essential-file-systems
  32             linux-command-line
  33             find-long-option
  34             make-essential-device-nodes
  35             configure-qemu-networking
  36
  37             bind-mount
  38             device-number
  39             boot-system))
  40
  41 ;;; Commentary:
  42 ;;;
  43 ;;; Utility procedures useful in a Linux initial RAM disk (initrd).  Note that
  44 ;;; many of these use procedures not yet available in vanilla Guile (`mount',
  45 ;;; `load-linux-module', etc.); these are provided by a Guile patch used in
  46 ;;; the GNU distribution.
  47 ;;;
  48 ;;; Code:
  49
  50 (define* (mount-essential-file-systems #:key (root "/"))
  51   "Mount /proc and /sys under ROOT."
  52   (define (scope dir)
  53     (string-append root
  54                    (if (string-suffix? "/" root)
  55                        ""
  56                        "/")
  57                    dir))
  58
  59   (unless (file-exists? (scope "proc"))
  60     (mkdir (scope "proc")))
  61   (mount "none" (scope "proc") "proc")
  62
  63   (unless (file-exists? (scope "sys"))
  64     (mkdir (scope "sys")))
  65   (mount "none" (scope "sys") "sysfs"))
  66
  67 (define (move-essential-file-systems root)
  68   "Move currently mounted essential file systems to ROOT."
  69   (for-each (lambda (dir)
  70               (let ((target (string-append root dir)))
  71                 (unless (file-exists? target)
  72                   (mkdir target))
  73                 (mount dir target "" MS_MOVE)))
  74             '("/proc" "/sys")))
  75
  76 (define (linux-command-line)
  77   "Return the Linux kernel command line as a list of strings."
  78   (string-tokenize
  79    (call-with-input-file "/proc/cmdline"
  80      get-string-all)))
  81
  82 (define (find-long-option option arguments)
  83   "Find OPTION among ARGUMENTS, where OPTION is something like \"--load\".
  84 Return the value associated with OPTION, or #f on failure."
  85   (let ((opt (string-append option "=")))
  86     (and=> (find (cut string-prefix? opt <>)
  87                  arguments)
  88            (lambda (arg)
  89              (substring arg (+ 1 (string-index arg #\=)))))))
  90
  91 (define* (make-disk-device-nodes base major #:optional (minor 0))
  92   "Make the block device nodes around BASE (something like \"/root/dev/sda\")
  93 with the given MAJOR number, starting with MINOR."
  94   (mknod base 'block-special #o644 (device-number major minor))
  95   (let loop ((i 1))
  96     (when (< i 16)
  97       (mknod (string-append base (number->string i))
  98              'block-special #o644 (device-number major (+ minor i)))
  99       (loop (+ i 1)))))
 100
 101 (define* (make-essential-device-nodes #:key (root "/"))
 102   "Make essential device nodes under ROOT/dev."
 103   ;; The hand-made udev!
 104
 105   (define (scope dir)
 106     (string-append root
 107                    (if (string-suffix? "/" root)
 108                        ""
 109                        "/")
 110                    dir))
 111
 112   (unless (file-exists? (scope "dev"))
 113     (mkdir (scope "dev")))
 114
 115   ;; Make the device nodes for SCSI disks.
 116   (make-disk-device-nodes (scope "dev/sda") 8)
 117   (make-disk-device-nodes (scope "dev/sdb") 8 16)
 118   (make-disk-device-nodes (scope "dev/sdc") 8 32)
 119   (make-disk-device-nodes (scope "dev/sdd") 8 48)
 120
 121   ;; SCSI CD-ROM devices (aka. "/dev/sr0" etc.).
 122   (mknod (scope "dev/scd0") 'block-special #o644 (device-number 11 0))
 123   (mknod (scope "dev/scd1") 'block-special #o644 (device-number 11 1))
 124
 125   ;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM.
 126   (make-disk-device-nodes (scope "dev/vda") 252)
 127
 128   ;; Memory (used by Xorg's VESA driver.)
 129   (mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1))
 130   (mknod (scope "dev/kmem") 'char-special #o640 (device-number 1 2))
 131
 132   ;; Inputs (used by Xorg.)
 133   (unless (file-exists? (scope "dev/input"))
 134     (mkdir (scope "dev/input")))
 135   (mknod (scope "dev/input/mice") 'char-special #o640 (device-number 13 63))
 136   (mknod (scope "dev/input/mouse0") 'char-special #o640 (device-number 13 32))
 137   (mknod (scope "dev/input/event0") 'char-special #o640 (device-number 13 64))
 138
 139   ;; System console.  This node is magically created by the kernel on the
 140   ;; initrd's root, so don't try to create it in that case.
 141   (unless (string=? root "/")
 142     (mknod (scope "dev/console") 'char-special #o600
 143            (device-number 5 1)))
 144
 145   ;; TTYs.
 146   (mknod (scope "dev/tty") 'char-special #o600
 147          (device-number 5 0))
 148   (chmod (scope "dev/tty") #o666)
 149   (let loop ((n 0))
 150     (and (< n 50)
 151          (let ((name (format #f "dev/tty~a" n)))
 152            (mknod (scope name) 'char-special #o600
 153                   (device-number 4 n))
 154            (loop (+ 1 n)))))
 155
 156   ;; Serial line.
 157   (mknod (scope "dev/ttyS0") 'char-special #o660
 158          (device-number 4 64))
 159
 160   ;; Pseudo ttys.
 161   (mknod (scope "dev/ptmx") 'char-special #o666
 162          (device-number 5 2))
 163   (chmod (scope "dev/ptmx") #o666)
 164
 165   ;; Create /dev/pts; it will be mounted later, at boot time.
 166   (unless (file-exists? (scope "dev/pts"))
 167     (mkdir (scope "dev/pts")))
 168
 169   ;; Rendez-vous point for syslogd.
 170   (mknod (scope "dev/log") 'socket #o666 0)
 171   (mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11))
 172
 173   ;; Other useful nodes, notably relied on by guix-daemon.
 174   (for-each (match-lambda
 175              ((file major minor)
 176               (mknod (scope file) 'char-special #o666
 177                      (device-number major minor))
 178               (chmod (scope file) #o666)))
 179             '(("dev/null" 1 3)
 180               ("dev/zero" 1 5)
 181               ("dev/full" 1 7)
 182               ("dev/random" 1 8)
 183               ("dev/urandom" 1 9)))
 184
 185   (symlink "/proc/self/fd" (scope "dev/fd"))
 186   (symlink "/proc/self/fd/0" (scope "dev/stdin"))
 187   (symlink "/proc/self/fd/1" (scope "dev/stdout"))
 188   (symlink "/proc/self/fd/2" (scope "dev/stderr"))
 189
 190   ;; Loopback devices.
 191   (let loop ((i 0))
 192     (when (< i 8)
 193       (mknod (scope (string-append "dev/loop" (number->string i)))
 194              'block-special #o660
 195              (device-number 7 i))
 196       (loop (+ 1 i))))
 197
 198   ;; File systems in user space (FUSE).
 199   (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229)))
 200
 201 (define %host-qemu-ipv4-address
 202   (inet-pton AF_INET "10.0.2.10"))
 203
 204 (define* (configure-qemu-networking #:optional (interface "eth0"))
 205   "Setup the INTERFACE network interface and /etc/resolv.conf according to
 206 QEMU's default networking settings (see net/slirp.c in QEMU for default
 207 networking values.)  Return #t if INTERFACE is up, #f otherwise."
 208   (display "configuring QEMU networking...\n")
 209   (let* ((sock    (socket AF_INET SOCK_STREAM 0))
 210          (address (make-socket-address AF_INET %host-qemu-ipv4-address 0))
 211          (flags   (network-interface-flags sock interface)))
 212     (set-network-interface-address sock interface address)
 213     (set-network-interface-flags sock interface (logior flags IFF_UP))
 214
 215     ;; Hello!  We used to create /etc/resolv.conf here, with "nameserver
 216     ;; 10.0.2.3\n".  However, with Linux-libre 3.16, we're getting ENOSPC.
 217     ;; And since it's actually unnecessary, it's gone.
 218
 219     (logand (network-interface-flags sock interface) IFF_UP)))
 220
 221 (define (device-number major minor)
 222   "Return the device number for the device with MAJOR and MINOR, for use as
 223 the last argument of `mknod'."
 224   (+ (* major 256) minor))
 225
 226 (define (pidof program)
 227   "Return the PID of the first presumed instance of PROGRAM."
 228   (let ((program (basename program)))
 229     (find (lambda (pid)
 230             (let ((exe (format #f "/proc/~a/exe" pid)))
 231               (and=> (false-if-exception (readlink exe))
 232                      (compose (cut string=? program <>) basename))))
 233           (filter-map string->number (scandir "/proc")))))
 234
 235 (define* (mount-root-file-system root type
 236                                  #:key volatile-root? (unionfs "unionfs"))
 237   "Mount the root file system of type TYPE at device ROOT.  If VOLATILE-ROOT?
 238 is true, mount ROOT read-only and make it a union with a writable tmpfs using
 239 UNIONFS."
 240   (define (mark-as-not-killable pid)
 241     ;; Tell the 'user-processes' dmd service that PID must be kept alive when
 242     ;; shutting down.
 243     (mkdir-p "/root/etc/dmd")
 244     (let ((port (open-file "/root/etc/dmd/do-not-kill" "a")))
 245       (chmod port #o600)
 246       (write pid port)
 247       (newline port)
 248       (close-port port)))
 249
 250   (if volatile-root?
 251       (begin
 252         (mkdir-p "/real-root")
 253         (mount root "/real-root" type MS_RDONLY)
 254         (mkdir-p "/rw-root")
 255         (mount "none" "/rw-root" "tmpfs")
 256
 257         ;; We want read-write /dev nodes.
 258         (make-essential-device-nodes #:root "/rw-root")
 259
 260         ;; Make /root a union of the tmpfs and the actual root.  Use
 261         ;; 'max_files' to set a high RLIMIT_NOFILE for the unionfs process
 262         ;; itself.  Failing to do that, we quickly run out of file
 263         ;; descriptors; see <http://bugs.gnu.org/17827>.
 264         (unless (zero? (system* unionfs "-o"
 265                                 "cow,allow_other,use_ino,suid,dev,max_files=65536"
 266                                 "/rw-root=RW:/real-root=RO"
 267                                 "/root"))
 268           (error "unionfs failed"))
 269
 270         ;; Make sure unionfs remains alive till the end.  Because
 271         ;; 'fuse_daemonize' doesn't tell the PID of the forked daemon, we
 272         ;; have to resort to 'pidof' here.
 273         (mark-as-not-killable (pidof unionfs)))
 274       (begin
 275         (check-file-system root type)
 276         (mount root "/root" type)))
 277
 278   ;; Make sure /root/etc/mtab is a symlink to /proc/self/mounts.
 279   (false-if-exception
 280     (delete-file "/root/etc/mtab"))
 281   (symlink "/proc/self/mounts" "/root/etc/mtab"))
 282
 283 (define (switch-root root)
 284   "Switch to ROOT as the root file system, in a way similar to what
 285 util-linux' switch_root(8) does."
 286   (move-essential-file-systems root)
 287   (chdir root)
 288
 289   ;; Since we're about to 'rm -rf /', try to make sure we're on an initrd.
 290   ;; TODO: Use 'statfs' to check the fs type, like klibc does.
 291   (when (or (not (file-exists? "/init")) (directory-exists? "/home"))
 292     (format (current-error-port)
 293             "The root file system is probably not an initrd; \
 294 bailing out.~%root contents: ~s~%" (scandir "/"))
 295     (force-output (current-error-port))
 296     (exit 1))
 297
 298   ;; Delete files from the old root, without crossing mount points (assuming
 299   ;; there are no mount points in sub-directories.)  That means we're leaving
 300   ;; the empty ROOT directory behind us, but that's OK.
 301   (let ((root-device (stat:dev (stat "/"))))
 302     (for-each (lambda (file)
 303                 (unless (member file '("." ".."))
 304                   (let* ((file   (string-append "/" file))
 305                          (device (stat:dev (lstat file))))
 306                     (when (= device root-device)
 307                       (delete-file-recursively file)))))
 308               (scandir "/")))
 309
 310   ;; Make ROOT the new root.
 311   (mount root "/" "" MS_MOVE)
 312   (chroot ".")
 313   (chdir "/")
 314
 315   (when (file-exists? "/dev/console")
 316     ;; Close the standard file descriptors since they refer to the old
 317     ;; /dev/console, and reopen them.
 318     (let ((console (open-file "/dev/console" "r+b0")))
 319       (for-each close-fdes '(0 1 2))
 320
 321       (dup2 (fileno console) 0)
 322       (dup2 (fileno console) 1)
 323       (dup2 (fileno console) 2)
 324
 325       (close-port console))))
 326
 327 \f
 328 (define* (boot-system #:key
 329                       (linux-modules '())
 330                       linux-module-directory
 331                       qemu-guest-networking?
 332                       volatile-root?
 333                       pre-mount
 334                       (mounts '()))
 335   "This procedure is meant to be called from an initrd.  Boot a system by
 336 first loading LINUX-MODULES (a list of module names) from
 337 LINUX-MODULE-DIRECTORY, then setting up QEMU guest networking if
 338 QEMU-GUEST-NETWORKING? is true, calling PRE-MOUNT, mounting the file systems
 339 specified in MOUNTS, and finally booting into the new root if any.  The initrd
 340 supports kernel command-line options '--load', '--root', and '--repl'.
 341
 342 Mount the root file system, specified by the '--root' command-line argument,
 343 if any.
 344
 345 MOUNTS must be a list suitable for 'mount-file-system'.
 346
 347 When VOLATILE-ROOT? is true, the root file system is writable but any changes
 348 to it are lost."
 349   (define root-mount-point?
 350     (match-lambda
 351      ((device _ "/" _ ...) #t)
 352      (_ #f)))
 353
 354   (define root-fs-type
 355     (or (any (match-lambda
 356               ((device _ "/" type _ ...) type)
 357               (_ #f))
 358              mounts)
 359         "ext4"))
 360
 361   (define (lookup-module name)
 362     (string-append linux-module-directory "/"
 363                    (ensure-dot-ko name)))
 364
 365   (display "Welcome, this is GNU's early boot Guile.\n")
 366   (display "Use '--repl' for an initrd REPL.\n\n")
 367
 368   (call-with-error-handling
 369    (lambda ()
 370      (mount-essential-file-systems)
 371      (let* ((args    (linux-command-line))
 372             (to-load (find-long-option "--load" args))
 373             (root    (find-long-option "--root" args)))
 374
 375        (when (member "--repl" args)
 376          (start-repl))
 377
 378        (display "loading kernel modules...\n")
 379        (current-module-debugging-port (current-output-port))
 380        (for-each (cut load-linux-module* <>
 381                       #:lookup-module lookup-module)
 382                  (map lookup-module linux-modules))
 383
 384        (when qemu-guest-networking?
 385          (unless (configure-qemu-networking)
 386            (display "network interface is DOWN\n")))
 387
 388        ;; Make /dev nodes.
 389        (make-essential-device-nodes)
 390
 391        ;; Prepare the real root file system under /root.
 392        (unless (file-exists? "/root")
 393          (mkdir "/root"))
 394
 395        (when (procedure? pre-mount)
 396          ;; Do whatever actions are needed before mounting the root file
 397          ;; system--e.g., installing device mappings.  Error out when the
 398          ;; return value is false.
 399          (unless (pre-mount)
 400            (error "pre-mount actions failed")))
 401
 402        (if root
 403            (mount-root-file-system (canonicalize-device-spec root)
 404                                    root-fs-type
 405                                    #:volatile-root? volatile-root?)
 406            (mount "none" "/root" "tmpfs"))
 407
 408        (unless (file-exists? "/root/dev")
 409          (mkdir "/root/dev")
 410          (make-essential-device-nodes #:root "/root"))
 411
 412        ;; Mount the specified file systems.
 413        (for-each mount-file-system
 414                  (remove root-mount-point? mounts))
 415
 416        (if to-load
 417            (begin
 418              (switch-root "/root")
 419              (format #t "loading '~a'...\n" to-load)
 420
 421              (primitive-load to-load)
 422
 423              (format (current-error-port)
 424                      "boot program '~a' terminated, rebooting~%"
 425                      to-load)
 426              (sleep 2)
 427              (reboot))
 428            (begin
 429              (display "no boot file passed via '--load'\n")
 430              (display "entering a warm and cozy REPL\n")
 431              (start-repl)))))))
 432
 433 ;;; linux-initrd.scm ends here