gnu/system/linux-initrd.scm

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