gnu/system/linux-initrd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
   6 ;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (gnu system linux-initrd)
  24   #:use-module (guix gexp)
  25   #:use-module (guix utils)
  26   #:use-module ((guix store)
  27                 #:select (%store-prefix))
  28   #:use-module ((guix derivations)
  29                 #:select (derivation->output-path))
  30   #:use-module (guix modules)
  31   #:use-module (gnu packages compression)
  32   #:use-module (gnu packages disk)
  33   #:use-module (gnu packages linux)
  34   #:use-module (gnu packages file-systems)
  35   #:use-module (gnu packages guile)
  36   #:use-module ((gnu packages xorg)
  37                 #:select (console-setup xkeyboard-config))
  38   #:use-module ((gnu packages make-bootstrap)
  39                 #:select (%guile-static-stripped))
  40   #:use-module (gnu system file-systems)
  41   #:use-module (gnu system mapped-devices)
  42   #:use-module (gnu system keyboard)
  43   #:use-module (ice-9 match)
  44   #:use-module (ice-9 regex)
  45   #:use-module (ice-9 vlist)
  46   #:use-module (srfi srfi-1)
  47   #:use-module (srfi srfi-26)
  48   #:export (expression->initrd
  49             %base-initrd-modules
  50             raw-initrd
  51             file-system-packages
  52             base-initrd))
  53
  54 \f
  55 ;;; Commentary:
  56 ;;;
  57 ;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in
  58 ;;; particular initrd's that run Guile.
  59 ;;;
  60 ;;; Code:
  61
  62
  63 (define* (expression->initrd exp
  64                              #:key
  65                              (guile %guile-static-stripped)
  66                              (gzip gzip)
  67                              (name "guile-initrd")
  68                              (system (%current-system)))
  69   "Return as a file-like object a Linux initrd (a gzipped cpio archive)
  70 containing GUILE and that evaluates EXP, a G-expression, upon booting.  All
  71 the derivations referenced by EXP are automatically copied to the initrd."
  72
  73   ;; General Linux overview in `Documentation/early-userspace/README' and
  74   ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
  75
  76   (define init
  77     (program-file "init" exp #:guile guile))
  78
  79   (define (import-module? module)
  80     ;; Since we don't use deduplication support in 'populate-store', don't
  81     ;; import (guix store deduplication) and its dependencies, which includes
  82     ;; Guile-Gcrypt.  That way we can run tests with '--bootstrap'.
  83     (and (guix-module-name? module)
  84          (not (equal? module '(guix store deduplication)))))
  85
  86   (define builder
  87     ;; Do not use "guile-zlib" extension here, otherwise it would drag the
  88     ;; non-static "zlib" package to the initrd closure.  It is not needed
  89     ;; anyway because the modules are stored uncompressed within the initrd.
  90     (with-imported-modules (source-module-closure
  91                             '((gnu build linux-initrd))
  92                             #:select? import-module?)
  93       #~(begin
  94           (use-modules (gnu build linux-initrd))
  95
  96           (mkdir #$output)
  97
  98           ;; The guile used in the initrd must be present in the store, so
  99           ;; that module loading works once the root is switched.
 100           ;;
 101           ;; To ensure that is the case, add an explicit reference to the
 102           ;; guile package used in the initrd to the output.
 103           ;;
 104           ;; This fixes guix-patches bug #28399, "Fix mysql activation, and
 105           ;; add a basic test".
 106           (call-with-output-file (string-append #$ output "/references")
 107             (lambda (port)
 108               (simple-format port "~A\n" #$guile)))
 109
 110           (build-initrd (string-append #$output "/initrd.cpio.gz")
 111                         #:guile #$guile
 112                         #:init #$init
 113                         ;; Copy everything INIT refers to into the initrd.
 114                         #:references-graphs '("closure")
 115                         #:gzip (string-append #+gzip "/bin/gzip")))))
 116
 117   (file-append (computed-file name builder
 118                               #:options
 119                               `(#:references-graphs (("closure" ,init))))
 120                "/initrd.cpio.gz"))
 121
 122 (define (flat-linux-module-directory linux modules)
 123   "Return a flat directory containing the Linux kernel modules listed in
 124 MODULES and taken from LINUX."
 125   (define imported-modules
 126     (source-module-closure '((gnu build linux-modules)
 127                              (guix build utils))))
 128
 129   (define build-exp
 130     (with-imported-modules imported-modules
 131       (with-extensions (list guile-zlib)
 132         #~(begin
 133             (use-modules (gnu build linux-modules)
 134                          (guix build utils)
 135                          (srfi srfi-1)
 136                          (srfi srfi-26))
 137
 138             (define module-dir
 139               (string-append #$linux "/lib/modules"))
 140
 141             (define modules
 142               (let* ((lookup  (cut find-module-file module-dir <>))
 143                      (modules (map lookup '#$modules)))
 144                 (append modules
 145                         (recursive-module-dependencies
 146                          modules
 147                          #:lookup-module lookup))))
 148
 149             (define (maybe-uncompress file)
 150               ;; If FILE is a compressed module, uncompress it, as the initrd
 151               ;; is already gzipped as a whole.
 152               (cond
 153                ((string-contains file ".ko.gz")
 154                 (invoke #+(file-append gzip "/bin/gunzip") file))))
 155
 156             (mkdir #$output)
 157             (for-each (lambda (module)
 158                         (let ((out-module
 159                                (string-append #$output "/"
 160                                               (basename module))))
 161                           (format #t "copying '~a'...~%" module)
 162                           (copy-file module out-module)
 163                           (maybe-uncompress out-module)))
 164                       (delete-duplicates modules))
 165
 166             ;; Hyphen or underscore?  This database tells us.
 167             (write-module-name-database #$output)))))
 168
 169   (computed-file "linux-modules" build-exp))
 170
 171 (define* (raw-initrd file-systems
 172                       #:key
 173                       (linux linux-libre)
 174                       (linux-modules '())
 175                       (pre-mount #t)
 176                       (mapped-devices '())
 177                       (keyboard-layout #f)
 178                       (helper-packages '())
 179                       qemu-networking?
 180                       volatile-root?
 181                       (on-error 'debug))
 182   "Return as a file-like object a raw initrd, with kernel
 183 modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
 184 mounted by the initrd, possibly in addition to the root file system specified
 185 on the kernel command line via 'root'.  LINUX-MODULES is a list of kernel
 186 modules to be loaded at boot time. MAPPED-DEVICES is a list of device
 187 mappings to realize before FILE-SYSTEMS are mounted. PRE-MOUNT is a
 188 G-expression to evaluate before realizing MAPPED-DEVICES.
 189 HELPER-PACKAGES is a list of packages to be copied in the initrd. It may include
 190 e2fsck/static or other packages needed by the initrd to check root partition.
 191
 192 When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired
 193 console keyboard layout.  This is done before MAPPED-DEVICES are set up and
 194 before FILE-SYSTEMS are mounted such that, should the user need to enter a
 195 passphrase or use the REPL, this happens using the intended keyboard layout.
 196
 197 When QEMU-NETWORKING? is true, set up networking with the standard QEMU
 198 parameters.
 199
 200 When VOLATILE-ROOT? is true, the root file system is writable but any changes
 201 to it are lost.
 202
 203 ON-ERROR is passed to 'call-with-error-handling'; it determines what happens
 204 upon error."
 205   (define device-mapping-commands
 206     ;; List of gexps to open the mapped devices.
 207     (map (lambda (md)
 208            (let* ((source  (mapped-device-source md))
 209                   (targets (mapped-device-targets md))
 210                   (type    (mapped-device-type md))
 211                   (open    (mapped-device-kind-open type)))
 212              (open source targets)))
 213          mapped-devices))
 214
 215   (define file-system-scan-commands
 216     ;; File systems like btrfs need help to assemble multi-device file systems
 217     ;; but do not use manually-specified <mapped-devices>.
 218     (let ((file-system-types (map file-system-type file-systems)))
 219       (if (member "btrfs" file-system-types)
 220           ;; Ignore errors: if the system manages to boot anyway, the better.
 221           #~((system* (string-append #$btrfs-progs/static "/bin/btrfs")
 222                       "device" "scan"))
 223           #~())))
 224
 225   (define kodir
 226     (flat-linux-module-directory linux linux-modules))
 227
 228   (expression->initrd
 229    (with-imported-modules (source-module-closure
 230                            '((gnu build linux-boot)
 231                              (guix build utils)
 232                              (guix build bournish)
 233                              (gnu system file-systems)
 234                              (gnu build file-systems)))
 235      #~(begin
 236          (use-modules (gnu build linux-boot)
 237                       (gnu system file-systems)
 238                       ((guix build utils) #:hide (delete))
 239                       (guix build bournish)   ;add the 'bournish' meta-command
 240                       (srfi srfi-1)           ;for lvm-device-mapping
 241                       (srfi srfi-26)
 242
 243                       ;; FIXME: The following modules are for
 244                       ;; LUKS-DEVICE-MAPPING.  We should instead propagate
 245                       ;; this info via gexps.
 246                       ((gnu build file-systems)
 247                        #:select (find-partition-by-luks-uuid))
 248                       (rnrs bytevectors))
 249
 250          (with-output-to-port (%make-void-port "w")
 251            (lambda ()
 252              (set-path-environment-variable "PATH" '("bin" "sbin")
 253                                             '#$helper-packages)))
 254
 255          (parameterize ((current-warning-port (%make-void-port "w")))
 256            (boot-system #:mounts
 257                         (map spec->file-system
 258                              '#$(map file-system->spec file-systems))
 259                         #:pre-mount (lambda ()
 260                                       (and #$pre-mount
 261                                            #$@device-mapping-commands
 262                                            #$@file-system-scan-commands))
 263                         #:linux-modules '#$linux-modules
 264                         #:linux-module-directory '#$kodir
 265                         #:keymap-file #+(and=> keyboard-layout
 266                                                keyboard-layout->console-keymap)
 267                         #:qemu-guest-networking? #$qemu-networking?
 268                         #:volatile-root? '#$volatile-root?
 269                         #:on-error '#$on-error))))
 270    #:name "raw-initrd"))
 271
 272 (define* (file-system-packages file-systems #:key (volatile-root? #f))
 273   "Return the list of statically-linked, stripped packages to check
 274 FILE-SYSTEMS."
 275   `(,@(if (find (lambda (fs)
 276                   (string-prefix? "ext" (file-system-type fs)))
 277                 file-systems)
 278           (list e2fsck/static)
 279           '())
 280     ,@(if (find (lambda (fs)
 281                   (string-suffix? "fat" (file-system-type fs)))
 282                 file-systems)
 283           (list fatfsck/static)
 284           '())
 285     ,@(if (find (file-system-type-predicate "bcachefs") file-systems)
 286           (list bcachefs/static)
 287           '())
 288     ,@(if (find (file-system-type-predicate "btrfs") file-systems)
 289           (list btrfs-progs/static)
 290           '())
 291     ,@(if (find (file-system-type-predicate "jfs") file-systems)
 292           (list jfs_fsck/static)
 293           '())
 294     ,@(if (find (file-system-type-predicate "ntfs") file-systems)
 295           (list ntfsfix/static)
 296           '())
 297     ,@(if (find (file-system-type-predicate "f2fs") file-systems)
 298           (list f2fs-fsck/static)
 299           '())
 300     ,@(if (find (file-system-type-predicate "xfs") file-systems)
 301           (list xfs_repair/static)
 302           '())))
 303
 304 (define-syntax vhash                              ;TODO: factorize
 305   (syntax-rules (=>)
 306     "Build a vhash with the given key/value mappings."
 307     ((_)
 308      vlist-null)
 309     ((_ (key others ... => value) rest ...)
 310      (vhash-cons key value
 311                  (vhash (others ... => value) rest ...)))
 312     ((_ (=> value) rest ...)
 313      (vhash rest ...))))
 314
 315 (define-syntax lookup-procedure
 316   (syntax-rules (else)
 317     "Return a procedure that lookups keys in the given dictionary."
 318     ((_ mapping ... (else default))
 319      (let ((table (vhash mapping ...)))
 320        (lambda (key)
 321          (match (vhash-assoc key table)
 322            (#f            default)
 323            ((key . value) value)))))))
 324
 325 (define file-system-type-modules
 326   ;; Given a file system type, return the list of modules it needs.
 327   (lookup-procedure ("cifs" => '("md4" "ecb" "cifs"))
 328                     ("9p" => '("9p" "9pnet_virtio"))
 329                     ("bcachefs" => '("bcachefs"))
 330                     ("btrfs" => '("btrfs"))
 331                     ("iso9660" => '("isofs"))
 332                     ("jfs" => '("jfs"))
 333                     ("f2fs" => '("f2fs" "crc32_generic"))
 334                     ("xfs" => '("xfs"))
 335                     (else '())))
 336
 337 (define (file-system-modules file-systems)
 338   "Return the list of Linux modules needed to mount FILE-SYSTEMS."
 339   (append-map (compose file-system-type-modules file-system-type)
 340               file-systems))
 341
 342 (define* (default-initrd-modules
 343            #:optional
 344            (system (or (%current-target-system)
 345                        (%current-system))))
 346   "Return the list of modules included in the initrd by default."
 347   (define virtio-modules
 348     ;; Modules for Linux para-virtualized devices, for use in QEMU guests.
 349     '("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net"
 350       "virtio_console" "virtio-rng"))
 351
 352   `("ahci"                                  ;for SATA controllers
 353     "usb-storage" "uas"                     ;for the installation image etc.
 354     "usbhid" "hid-generic" "hid-apple"      ;keyboards during early boot
 355     "dm-crypt" "xts" "serpent_generic" "wp512" ;for encrypted root partitions
 356     "nls_iso8859-1"                            ;for `mkfs.fat`, et.al
 357     ,@(if (string-match "^(x86_64|i[3-6]86)-" system)
 358           '("pata_acpi" "pata_atiixp"    ;for ATA controllers
 359             "isci")                      ;for SAS controllers like Intel C602
 360           '())
 361
 362     ,@virtio-modules))
 363
 364 (define-syntax %base-initrd-modules
 365   ;; This more closely matches our naming convention.
 366   (identifier-syntax (default-initrd-modules)))
 367
 368 (define* (base-initrd file-systems
 369                       #:key
 370                       (linux linux-libre)
 371                       (linux-modules '())
 372                       (mapped-devices '())
 373                       (keyboard-layout #f)
 374                       qemu-networking?
 375                       volatile-root?
 376                       (extra-modules '())         ;deprecated
 377                       (on-error 'debug))
 378   "Return as a file-like object a generic initrd, with kernel
 379 modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
 380 mounted by the initrd, possibly in addition to the root file system specified
 381 on the kernel command line via 'root'.  MAPPED-DEVICES is a list of device
 382 mappings to realize before FILE-SYSTEMS are mounted.
 383
 384 When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired
 385 console keyboard layout.  This is done before MAPPED-DEVICES are set up and
 386 before FILE-SYSTEMS are mounted such that, should the user need to enter a
 387 passphrase or use the REPL, this happens using the intended keyboard layout.
 388
 389 QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd.
 390
 391 The initrd is automatically populated with all the kernel modules necessary
 392 for FILE-SYSTEMS and for the given options.  Additional kernel
 393 modules can be listed in LINUX-MODULES.  They will be added to the initrd, and
 394 loaded at boot time in the order in which they appear."
 395   (define linux-modules*
 396     ;; Modules added to the initrd and loaded from the initrd.
 397     `(,@linux-modules
 398       ,@(file-system-modules file-systems)
 399       ,@(if volatile-root?
 400             '("overlay")
 401             '())
 402       ,@extra-modules))
 403
 404   (define helper-packages
 405     (append (file-system-packages file-systems
 406                                   #:volatile-root? volatile-root?)
 407             (if keyboard-layout
 408                 (list loadkeys-static)
 409                 '())))
 410
 411   (raw-initrd file-systems
 412               #:linux linux
 413               #:linux-modules linux-modules*
 414               #:mapped-devices mapped-devices
 415               #:helper-packages helper-packages
 416               #:keyboard-layout keyboard-layout
 417               #:qemu-networking? qemu-networking?
 418               #:volatile-root? volatile-root?
 419               #:on-error on-error))
 420
 421 ;;; linux-initrd.scm ends here