guix/build/linux-initrd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014 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 (guix build linux-initrd)
  20   #:use-module (rnrs io ports)
  21   #:use-module (system foreign)
  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   #:export (mount-essential-file-systems
  30             linux-command-line
  31             make-essential-device-nodes
  32             configure-qemu-networking
  33             mount-file-system
  34             bind-mount
  35             load-linux-module*
  36             device-number
  37             boot-system))
  38
  39 ;;; Commentary:
  40 ;;;
  41 ;;; Utility procedures useful in a Linux initial RAM disk (initrd).  Note that
  42 ;;; many of these use procedures not yet available in vanilla Guile (`mount',
  43 ;;; `load-linux-module', etc.); these are provided by a Guile patch used in
  44 ;;; the GNU distribution.
  45 ;;;
  46 ;;; Code:
  47
  48 (define* (mount-essential-file-systems #:key (root "/"))
  49   "Mount /proc and /sys under ROOT."
  50   (define (scope dir)
  51     (string-append root
  52                    (if (string-suffix? "/" root)
  53                        ""
  54                        "/")
  55                    dir))
  56
  57   (unless (file-exists? (scope "proc"))
  58     (mkdir (scope "proc")))
  59   (mount "none" (scope "proc") "proc")
  60
  61   (unless (file-exists? (scope "sys"))
  62     (mkdir (scope "sys")))
  63   (mount "none" (scope "sys") "sysfs"))
  64
  65 (define (linux-command-line)
  66   "Return the Linux kernel command line as a list of strings."
  67   (string-tokenize
  68    (call-with-input-file "/proc/cmdline"
  69      get-string-all)))
  70
  71 (define* (make-essential-device-nodes #:key (root "/"))
  72   "Make essential device nodes under ROOT/dev."
  73   ;; The hand-made udev!
  74
  75   (define (scope dir)
  76     (string-append root
  77                    (if (string-suffix? "/" root)
  78                        ""
  79                        "/")
  80                    dir))
  81
  82   (unless (file-exists? (scope "dev"))
  83     (mkdir (scope "dev")))
  84
  85   ;; Make the device nodes for SCSI disks.
  86   (mknod (scope "dev/sda") 'block-special #o644 (device-number 8 0))
  87   (mknod (scope "dev/sda1") 'block-special #o644 (device-number 8 1))
  88   (mknod (scope "dev/sda2") 'block-special #o644 (device-number 8 2))
  89
  90   ;; The virtio (para-virtualized) block devices, as supported by QEMU/KVM.
  91   (mknod (scope "dev/vda") 'block-special #o644 (device-number 252 0))
  92   (mknod (scope "dev/vda1") 'block-special #o644 (device-number 252 1))
  93   (mknod (scope "dev/vda2") 'block-special #o644 (device-number 252 2))
  94
  95   ;; Memory (used by Xorg's VESA driver.)
  96   (mknod (scope "dev/mem") 'char-special #o640 (device-number 1 1))
  97   (mknod (scope "dev/kmem") 'char-special #o640 (device-number 1 2))
  98
  99   ;; Inputs (used by Xorg.)
 100   (unless (file-exists? (scope "dev/input"))
 101     (mkdir (scope "dev/input")))
 102   (mknod (scope "dev/input/mice") 'char-special #o640 (device-number 13 63))
 103   (mknod (scope "dev/input/mouse0") 'char-special #o640 (device-number 13 32))
 104   (mknod (scope "dev/input/event0") 'char-special #o640 (device-number 13 64))
 105
 106   ;; TTYs.
 107   (mknod (scope "dev/tty") 'char-special #o600
 108          (device-number 5 0))
 109   (chmod (scope "dev/tty") #o666)
 110   (let loop ((n 0))
 111     (and (< n 50)
 112          (let ((name (format #f "dev/tty~a" n)))
 113            (mknod (scope name) 'char-special #o600
 114                   (device-number 4 n))
 115            (loop (+ 1 n)))))
 116
 117   ;; Pseudo ttys.
 118   (mknod (scope "dev/ptmx") 'char-special #o666
 119          (device-number 5 2))
 120   (chmod (scope "dev/ptmx") #o666)
 121
 122   ;; Create /dev/pts; it will be mounted later, at boot time.
 123   (unless (file-exists? (scope "dev/pts"))
 124     (mkdir (scope "dev/pts")))
 125
 126   ;; Rendez-vous point for syslogd.
 127   (mknod (scope "dev/log") 'socket #o666 0)
 128   (mknod (scope "dev/kmsg") 'char-special #o600 (device-number 1 11))
 129
 130   ;; Other useful nodes, notably relied on by guix-daemon.
 131   (for-each (match-lambda
 132              ((file major minor)
 133               (mknod (scope file) 'char-special #o666
 134                      (device-number major minor))
 135               (chmod (scope file) #o666)))
 136             '(("dev/null" 1 3)
 137               ("dev/zero" 1 5)
 138               ("dev/full" 1 7)
 139               ("dev/random" 1 8)
 140               ("dev/urandom" 1 9)))
 141
 142   (symlink "/proc/self/fd" (scope "dev/fd"))
 143   (symlink "/proc/self/fd/0" (scope "dev/stdin"))
 144   (symlink "/proc/self/fd/1" (scope "dev/stdout"))
 145   (symlink "/proc/self/fd/2" (scope "dev/stderr"))
 146
 147   ;; File systems in user space (FUSE).
 148   (mknod (scope "dev/fuse") 'char-special #o666 (device-number 10 229)))
 149
 150 (define %host-qemu-ipv4-address
 151   (inet-pton AF_INET "10.0.2.10"))
 152
 153 (define* (configure-qemu-networking #:optional (interface "eth0"))
 154   "Setup the INTERFACE network interface and /etc/resolv.conf according to
 155 QEMU's default networking settings (see net/slirp.c in QEMU for default
 156 networking values.)  Return #t if INTERFACE is up, #f otherwise."
 157   (display "configuring QEMU networking...\n")
 158   (let* ((sock    (socket AF_INET SOCK_STREAM 0))
 159          (address (make-socket-address AF_INET %host-qemu-ipv4-address 0))
 160          (flags   (network-interface-flags sock interface)))
 161     (set-network-interface-address sock interface address)
 162     (set-network-interface-flags sock interface (logior flags IFF_UP))
 163
 164     (unless (file-exists? "/etc")
 165       (mkdir "/etc"))
 166     (call-with-output-file "/etc/resolv.conf"
 167       (lambda (p)
 168         (display "nameserver 10.0.2.3\n" p)))
 169
 170     (logand (network-interface-flags sock interface) IFF_UP)))
 171
 172 ;; Linux mount flags, from libc's <sys/mount.h>.
 173 (define MS_RDONLY 1)
 174 (define MS_BIND 4096)
 175
 176 (define (bind-mount source target)
 177   "Bind-mount SOURCE at TARGET."
 178   (mount source target "" MS_BIND))
 179
 180 (define (load-linux-module* file)
 181   "Load Linux module from FILE, the name of a `.ko' file."
 182   (define (slurp module)
 183     (call-with-input-file file get-bytevector-all))
 184
 185   (load-linux-module (slurp file)))
 186
 187 (define (device-number major minor)
 188   "Return the device number for the device with MAJOR and MINOR, for use as
 189 the last argument of `mknod'."
 190   (+ (* major 256) minor))
 191
 192 (define* (mount-root-file-system root type
 193                                  #:key volatile-root? (unionfs "unionfs"))
 194   "Mount the root file system of type TYPE at device ROOT.  If VOLATILE-ROOT?
 195 is true, mount ROOT read-only and make it a union with a writable tmpfs using
 196 UNIONFS."
 197   (catch #t
 198     (lambda ()
 199       (if volatile-root?
 200           (begin
 201             (mkdir-p "/real-root")
 202             (mount root "/real-root" type MS_RDONLY)
 203             (mkdir-p "/rw-root")
 204             (mount "none" "/rw-root" "tmpfs")
 205
 206             ;; We want read-write /dev nodes.
 207             (make-essential-device-nodes #:root "/rw-root")
 208
 209             ;; Make /root a union of the tmpfs and the actual root.
 210             (unless (zero? (system* unionfs "-o"
 211                                     "cow,allow_other,use_ino,suid,dev"
 212                                     "/rw-root=RW:/real-root=RO"
 213                                     "/root"))
 214               (error "unionfs failed")))
 215           (begin
 216             (check-file-system root type)
 217             (mount root "/root" type))))
 218     (lambda args
 219       (format (current-error-port) "exception while mounting '~a': ~s~%"
 220               root args)
 221       (start-repl))))
 222
 223 (define (check-file-system device type)
 224   "Run a file system check of TYPE on DEVICE."
 225   (define fsck
 226     (string-append "fsck." type))
 227
 228   (let ((status (system* fsck "-v" "-p" device)))
 229     (match (status:exit-val status)
 230       (0
 231        #t)
 232       (1
 233        (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
 234                fsck device))
 235       (2
 236        (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
 237                fsck device)
 238        (sleep 3)
 239        (reboot))
 240       (code
 241        (format (current-error-port) "'~a' exited with code ~a on ~a; spawning REPL~%"
 242                fsck code device)
 243        (start-repl)))))
 244
 245 (define* (mount-file-system spec #:key (root "/root"))
 246   "Mount the file system described by SPEC under ROOT.  SPEC must have the
 247 form:
 248
 249   (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
 250
 251 DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
 252 FLAGS must be a list of symbols.  CHECK? is a Boolean indicating whether to
 253 run a file system check."
 254   (define flags->bit-mask
 255     (match-lambda
 256      (('read-only rest ...)
 257       (or MS_RDONLY (flags->bit-mask rest)))
 258      (('bind-mount rest ...)
 259       (or MS_BIND (flags->bit-mask rest)))
 260      (()
 261       0)))
 262
 263   (match spec
 264     ((source mount-point type (flags ...) options check?)
 265      (let ((mount-point (string-append root "/" mount-point)))
 266        (when check?
 267          (check-file-system source type))
 268        (mkdir-p mount-point)
 269        (mount source mount-point type (flags->bit-mask flags)
 270               (if options
 271                   (string->pointer options)
 272                   %null-pointer))))))
 273
 274 (define* (boot-system #:key
 275                       (linux-modules '())
 276                       qemu-guest-networking?
 277                       guile-modules-in-chroot?
 278                       volatile-root?
 279                       (mounts '()))
 280   "This procedure is meant to be called from an initrd.  Boot a system by
 281 first loading LINUX-MODULES, then setting up QEMU guest networking if
 282 QEMU-GUEST-NETWORKING? is true, mounting the file systems specified in MOUNTS,
 283 and finally booting into the new root if any.  The initrd supports kernel
 284 command-line options '--load', '--root', and '--repl'.
 285
 286 Mount the root file system, specified by the '--root' command-line argument,
 287 if any.
 288
 289 MOUNTS must be a list suitable for 'mount-file-system'.
 290
 291 When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
 292 the new root.
 293
 294 When VOLATILE-ROOT? is true, the root file system is writable but any changes
 295 to it are lost."
 296   (define (resolve file)
 297     ;; If FILE is a symlink to an absolute file name, resolve it as if we were
 298     ;; under /root.
 299     (let ((st (lstat file)))
 300       (if (eq? 'symlink (stat:type st))
 301           (let ((target (readlink file)))
 302             (resolve (string-append "/root" target)))
 303           file)))
 304
 305   (define root-mount-point?
 306     (match-lambda
 307      ((device "/" _ ...) #t)
 308      (_ #f)))
 309
 310   (define root-fs-type
 311     (or (any (match-lambda
 312               ((device "/" type _ ...) type)
 313               (_ #f))
 314              mounts)
 315         "ext4"))
 316
 317   (display "Welcome, this is GNU's early boot Guile.\n")
 318   (display "Use '--repl' for an initrd REPL.\n\n")
 319
 320   (mount-essential-file-systems)
 321   (let* ((args    (linux-command-line))
 322          (option  (lambda (opt)
 323                     (let ((opt (string-append opt "=")))
 324                       (and=> (find (cut string-prefix? opt <>)
 325                                    args)
 326                              (lambda (arg)
 327                                (substring arg (+ 1 (string-index arg #\=))))))))
 328          (to-load (option "--load"))
 329          (root    (option "--root")))
 330
 331     (when (member "--repl" args)
 332       (start-repl))
 333
 334     (display "loading kernel modules...\n")
 335     (for-each (compose load-linux-module*
 336                        (cut string-append "/modules/" <>))
 337               linux-modules)
 338
 339     (when qemu-guest-networking?
 340       (unless (configure-qemu-networking)
 341         (display "network interface is DOWN\n")))
 342
 343     ;; Make /dev nodes.
 344     (make-essential-device-nodes)
 345
 346     ;; Prepare the real root file system under /root.
 347     (unless (file-exists? "/root")
 348       (mkdir "/root"))
 349     (if root
 350         (mount-root-file-system root root-fs-type
 351                                 #:volatile-root? volatile-root?)
 352         (mount "none" "/root" "tmpfs"))
 353
 354     (mount-essential-file-systems #:root "/root")
 355
 356     (unless (file-exists? "/root/dev")
 357       (mkdir "/root/dev")
 358       (make-essential-device-nodes #:root "/root"))
 359
 360     ;; Mount the specified file systems.
 361     (for-each mount-file-system
 362               (remove root-mount-point? mounts))
 363
 364     (when guile-modules-in-chroot?
 365       ;; Copy the directories that contain .scm and .go files so that the
 366       ;; child process in the chroot can load modules (we would bind-mount
 367       ;; them but for some reason that fails with EINVAL -- XXX).
 368       (mkdir-p "/root/share")
 369       (mkdir-p "/root/lib")
 370       (mount "none" "/root/share" "tmpfs")
 371       (mount "none" "/root/lib" "tmpfs")
 372       (copy-recursively "/share" "/root/share"
 373                         #:log (%make-void-port "w"))
 374       (copy-recursively "/lib" "/root/lib"
 375                         #:log (%make-void-port "w")))
 376
 377     (if to-load
 378         (begin
 379           (format #t "loading '~a'...\n" to-load)
 380           (chdir "/root")
 381           (chroot "/root")
 382
 383           ;; Obviously this has to be done each time we boot.  Do it from here
 384           ;; so that statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3)
 385           ;; expects (and thus openpty(3) and its users, such as xterm.)
 386           (mount "none" "/dev/pts" "devpts")
 387
 388           ;; TODO: Remove /lib, /share, and /loader.go.
 389           (catch #t
 390             (lambda ()
 391               (primitive-load to-load))
 392             (lambda args
 393               (format (current-error-port) "'~a' raised an exception: ~s~%"
 394                       to-load args)
 395               (start-repl)))
 396           (format (current-error-port)
 397                   "boot program '~a' terminated, rebooting~%"
 398                   to-load)
 399           (sleep 2)
 400           (reboot))
 401         (begin
 402           (display "no boot file passed via '--load'\n")
 403           (display "entering a warm and cozy REPL\n")
 404           (start-repl)))))
 405
 406 ;;; linux-initrd.scm ends here