gnu/system/linux-initrd.scm

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