gnu/system/linux-initrd.scm

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