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 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-3.0-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-3.0-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 builder
  80     ;; Do not use "guile-zlib" extension here, otherwise it would drag the
  81     ;; non-static "zlib" package to the initrd closure.  It is not needed
  82     ;; anyway because the modules are stored uncompressed within the initrd.
  83     (with-imported-modules (source-module-closure
  84                             '((gnu build linux-initrd)))
  85       #~(begin
  86           (use-modules (gnu build linux-initrd))
  87
  88           (mkdir #$output)
  89
  90           ;; The guile used in the initrd must be present in the store, so
  91           ;; that module loading works once the root is switched.
  92           ;;
  93           ;; To ensure that is the case, add an explicit reference to the
  94           ;; guile package used in the initrd to the output.
  95           ;;
  96           ;; This fixes guix-patches bug #28399, "Fix mysql activation, and
  97           ;; add a basic test".
  98           (call-with-output-file (string-append #$ output "/references")
  99             (lambda (port)
 100               (simple-format port "~A\n" #$guile)))
 101
 102           (build-initrd (string-append #$output "/initrd.cpio.gz")
 103                         #:guile #$guile
 104                         #:init #$init
 105                         ;; Copy everything INIT refers to into the initrd.
 106                         #:references-graphs '("closure")
 107                         #:gzip (string-append #+gzip "/bin/gzip")))))
 108
 109   (file-append (computed-file name builder
 110                               #:options
 111                               `(#:references-graphs (("closure" ,init))))
 112                "/initrd.cpio.gz"))
 113
 114 (define (flat-linux-module-directory linux modules)
 115   "Return a flat directory containing the Linux kernel modules listed in
 116 MODULES and taken from LINUX."
 117   (define imported-modules
 118     (source-module-closure '((gnu build linux-modules)
 119                              (guix build utils))))
 120
 121   (define build-exp
 122     (with-imported-modules imported-modules
 123       (with-extensions (list guile-zlib)
 124         #~(begin
 125             (use-modules (gnu build linux-modules)
 126                          (guix build utils)
 127                          (srfi srfi-1)
 128                          (srfi srfi-26))
 129
 130             (define module-dir
 131               (string-append #$linux "/lib/modules"))
 132
 133             (define modules
 134               (let* ((lookup  (cut find-module-file module-dir <>))
 135                      (modules (map lookup '#$modules)))
 136                 (append modules
 137                         (recursive-module-dependencies
 138                          modules
 139                          #:lookup-module lookup))))
 140
 141             (define (maybe-uncompress file)
 142               ;; If FILE is a compressed module, uncompress it, as the initrd
 143               ;; is already gzipped as a whole.
 144               (cond
 145                ((string-contains file ".ko.gz")
 146                 (invoke #+(file-append gzip "/bin/gunzip") file))))
 147
 148             (mkdir #$output)
 149             (for-each (lambda (module)
 150                         (let ((out-module
 151                                (string-append #$output "/"
 152                                               (basename module))))
 153                           (format #t "copying '~a'...~%" module)
 154                           (copy-file module out-module)
 155                           (maybe-uncompress out-module)))
 156                       (delete-duplicates modules))
 157
 158             ;; Hyphen or underscore?  This database tells us.
 159             (write-module-name-database #$output)))))
 160
 161   (computed-file "linux-modules" build-exp))
 162
 163 (define* (raw-initrd file-systems
 164                       #:key
 165                       (linux linux-libre)
 166                       (linux-modules '())
 167                       (mapped-devices '())
 168                       (keyboard-layout #f)
 169                       (helper-packages '())
 170                       qemu-networking?
 171                       volatile-root?
 172                       (on-error 'debug))
 173   "Return as a file-like object a raw initrd, with kernel
 174 modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
 175 mounted by the initrd, possibly in addition to the root file system specified
 176 on the kernel command line via '--root'. LINUX-MODULES is a list of kernel
 177 modules to be loaded at boot time. MAPPED-DEVICES is a list of device
 178 mappings to realize before FILE-SYSTEMS are mounted.
 179 HELPER-PACKAGES is a list of packages to be copied in the initrd. It may include
 180 e2fsck/static or other packages needed by the initrd to check root partition.
 181
 182 When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired
 183 console keyboard layout.  This is done before MAPPED-DEVICES are set up and
 184 before FILE-SYSTEMS are mounted such that, should the user need to enter a
 185 passphrase or use the REPL, this happens using the intended keyboard layout.
 186
 187 When QEMU-NETWORKING? is true, set up networking with the standard QEMU
 188 parameters.
 189
 190 When VOLATILE-ROOT? is true, the root file system is writable but any changes
 191 to it are lost.
 192
 193 ON-ERROR is passed to 'call-with-error-handling'; it determines what happens
 194 upon error."
 195   (define device-mapping-commands
 196     ;; List of gexps to open the mapped devices.
 197     (map (lambda (md)
 198            (let* ((source (mapped-device-source md))
 199                   (target (mapped-device-target md))
 200                   (type   (mapped-device-type md))
 201                   (open   (mapped-device-kind-open type)))
 202              (open source target)))
 203          mapped-devices))
 204
 205   (define kodir
 206     (flat-linux-module-directory linux linux-modules))
 207
 208   (expression->initrd
 209    (with-imported-modules (source-module-closure
 210                            '((gnu build linux-boot)
 211                              (guix build utils)
 212                              (guix build bournish)
 213                              (gnu system file-systems)
 214                              (gnu build file-systems)))
 215      #~(begin
 216          (use-modules (gnu build linux-boot)
 217                       (gnu system file-systems)
 218                       ((guix build utils) #:hide (delete))
 219                       (guix build bournish)   ;add the 'bournish' meta-command
 220                       (srfi srfi-26)
 221
 222                       ;; FIXME: The following modules are for
 223                       ;; LUKS-DEVICE-MAPPING.  We should instead propagate
 224                       ;; this info via gexps.
 225                       ((gnu build file-systems)
 226                        #:select (find-partition-by-luks-uuid))
 227                       (rnrs bytevectors))
 228
 229          (with-output-to-port (%make-void-port "w")
 230            (lambda ()
 231              (set-path-environment-variable "PATH" '("bin" "sbin")
 232                                             '#$helper-packages)))
 233
 234          (parameterize ((current-warning-port (%make-void-port "w")))
 235            (boot-system #:mounts
 236                         (map spec->file-system
 237                              '#$(map file-system->spec file-systems))
 238                         #:pre-mount (lambda ()
 239                                       (and #$@device-mapping-commands))
 240                         #:linux-modules '#$linux-modules
 241                         #:linux-module-directory '#$kodir
 242                         #:keymap-file #+(and=> keyboard-layout
 243                                                keyboard-layout->console-keymap)
 244                         #:qemu-guest-networking? #$qemu-networking?
 245                         #:volatile-root? '#$volatile-root?
 246                         #:on-error '#$on-error))))
 247    #:name "raw-initrd"))
 248
 249 (define* (file-system-packages file-systems #:key (volatile-root? #f))
 250   "Return the list of statically-linked, stripped packages to check
 251 FILE-SYSTEMS."
 252   `(,@(if (find (lambda (fs)
 253                   (string-prefix? "ext" (file-system-type fs)))
 254                 file-systems)
 255           (list e2fsck/static)
 256           '())
 257     ,@(if (find (lambda (fs)
 258                   (string-suffix? "fat" (file-system-type fs)))
 259                 file-systems)
 260           (list fatfsck/static)
 261           '())
 262     ,@(if (find (file-system-type-predicate "btrfs") file-systems)
 263           (list btrfs-progs/static)
 264           '())
 265     ,@(if (find (file-system-type-predicate "jfs") file-systems)
 266           (list jfs_fsck/static)
 267           '())
 268     ,@(if (find (file-system-type-predicate "f2fs") file-systems)
 269           (list f2fs-fsck/static)
 270           '())))
 271
 272 (define-syntax vhash                              ;TODO: factorize
 273   (syntax-rules (=>)
 274     "Build a vhash with the given key/value mappings."
 275     ((_)
 276      vlist-null)
 277     ((_ (key others ... => value) rest ...)
 278      (vhash-cons key value
 279                  (vhash (others ... => value) rest ...)))
 280     ((_ (=> value) rest ...)
 281      (vhash rest ...))))
 282
 283 (define-syntax lookup-procedure
 284   (syntax-rules (else)
 285     "Return a procedure that lookups keys in the given dictionary."
 286     ((_ mapping ... (else default))
 287      (let ((table (vhash mapping ...)))
 288        (lambda (key)
 289          (match (vhash-assoc key table)
 290            (#f            default)
 291            ((key . value) value)))))))
 292
 293 (define file-system-type-modules
 294   ;; Given a file system type, return the list of modules it needs.
 295   (lookup-procedure ("cifs" => '("md4" "ecb" "cifs"))
 296                     ("9p" => '("9p" "9pnet_virtio"))
 297                     ("btrfs" => '("btrfs"))
 298                     ("iso9660" => '("isofs"))
 299                     ("jfs" => '("jfs"))
 300                     ("f2fs" => '("f2fs" "crc32_generic"))
 301                     (else '())))
 302
 303 (define (file-system-modules file-systems)
 304   "Return the list of Linux modules needed to mount FILE-SYSTEMS."
 305   (append-map (compose file-system-type-modules file-system-type)
 306               file-systems))
 307
 308 (define* (default-initrd-modules
 309            #:optional
 310            (system (or (%current-target-system)
 311                        (%current-system))))
 312   "Return the list of modules included in the initrd by default."
 313   (define virtio-modules
 314     ;; Modules for Linux para-virtualized devices, for use in QEMU guests.
 315     '("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net"
 316       "virtio_console" "virtio-rng"))
 317
 318   `("ahci"                                  ;for SATA controllers
 319     "usb-storage" "uas"                     ;for the installation image etc.
 320     "usbhid" "hid-generic" "hid-apple"      ;keyboards during early boot
 321     "dm-crypt" "xts" "serpent_generic" "wp512" ;for encrypted root partitions
 322     "nls_iso8859-1"                            ;for `mkfs.fat`, et.al
 323     ,@(if (string-match "^(x86_64|i[3-6]86)-" system)
 324           '("pata_acpi" "pata_atiixp"    ;for ATA controllers
 325             "isci")                      ;for SAS controllers like Intel C602
 326           '())
 327
 328     ,@virtio-modules))
 329
 330 (define-syntax %base-initrd-modules
 331   ;; This more closely matches our naming convention.
 332   (identifier-syntax (default-initrd-modules)))
 333
 334 (define* (base-initrd file-systems
 335                       #:key
 336                       (linux linux-libre)
 337                       (linux-modules '())
 338                       (mapped-devices '())
 339                       (keyboard-layout #f)
 340                       qemu-networking?
 341                       volatile-root?
 342                       (extra-modules '())         ;deprecated
 343                       (on-error 'debug))
 344   "Return as a file-like object a generic initrd, with kernel
 345 modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
 346 mounted by the initrd, possibly in addition to the root file system specified
 347 on the kernel command line via '--root'.  MAPPED-DEVICES is a list of device
 348 mappings to realize before FILE-SYSTEMS are mounted.
 349
 350 When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired
 351 console keyboard layout.  This is done before MAPPED-DEVICES are set up and
 352 before FILE-SYSTEMS are mounted such that, should the user need to enter a
 353 passphrase or use the REPL, this happens using the intended keyboard layout.
 354
 355 QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd.
 356
 357 The initrd is automatically populated with all the kernel modules necessary
 358 for FILE-SYSTEMS and for the given options.  Additional kernel
 359 modules can be listed in LINUX-MODULES.  They will be added to the initrd, and
 360 loaded at boot time in the order in which they appear."
 361   (define linux-modules*
 362     ;; Modules added to the initrd and loaded from the initrd.
 363     `(,@linux-modules
 364       ,@(file-system-modules file-systems)
 365       ,@(if volatile-root?
 366             '("overlay")
 367             '())
 368       ,@extra-modules))
 369
 370   (define helper-packages
 371     (append (file-system-packages file-systems
 372                                   #:volatile-root? volatile-root?)
 373             (if keyboard-layout
 374                 (list loadkeys-static)
 375                 '())))
 376
 377   (raw-initrd file-systems
 378               #:linux linux
 379               #:linux-modules linux-modules*
 380               #:mapped-devices mapped-devices
 381               #:helper-packages helper-packages
 382               #:keyboard-layout keyboard-layout
 383               #:qemu-networking? qemu-networking?
 384               #:volatile-root? volatile-root?
 385               #:on-error on-error))
 386
 387 ;;; linux-initrd.scm ends here