gnu/system/linux-initrd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu system linux-initrd)
  22   #:use-module (guix monads)
  23   #:use-module (guix store)
  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 guile)
  35   #:use-module ((gnu packages make-bootstrap)
  36                 #:select (%guile-static-stripped))
  37   #:use-module (gnu system file-systems)
  38   #:use-module (gnu system mapped-devices)
  39   #:use-module (ice-9 match)
  40   #:use-module (ice-9 regex)
  41   #:use-module (srfi srfi-1)
  42   #:use-module (srfi srfi-26)
  43   #:export (expression->initrd
  44             base-initrd))
  45
  46 \f
  47 ;;; Commentary:
  48 ;;;
  49 ;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in
  50 ;;; particular initrd's that run Guile.
  51 ;;;
  52 ;;; Code:
  53
  54
  55 (define* (expression->initrd exp
  56                              #:key
  57                              (guile %guile-static-stripped)
  58                              (gzip gzip)
  59                              (name "guile-initrd")
  60                              (system (%current-system)))
  61   "Return a derivation that builds a Linux initrd (a gzipped cpio archive)
  62 containing GUILE and that evaluates EXP, a G-expression, upon booting.  All
  63 the derivations referenced by EXP are automatically copied to the initrd."
  64
  65   ;; General Linux overview in `Documentation/early-userspace/README' and
  66   ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
  67
  68   (mlet %store-monad ((init (gexp->script "init" exp
  69                                           #:guile guile)))
  70     (define builder
  71       (with-imported-modules (source-module-closure
  72                               '((gnu build linux-initrd)))
  73         #~(begin
  74             (use-modules (gnu build linux-initrd))
  75
  76             (mkdir #$output)
  77             (build-initrd (string-append #$output "/initrd")
  78                           #:guile #$guile
  79                           #:init #$init
  80                           ;; Copy everything INIT refers to into the initrd.
  81                           #:references-graphs '("closure")
  82                           #:gzip (string-append #$gzip "/bin/gzip")))))
  83
  84     (gexp->derivation name builder
  85                       #:references-graphs `(("closure" ,init)))))
  86
  87 (define (flat-linux-module-directory linux modules)
  88   "Return a flat directory containing the Linux kernel modules listed in
  89 MODULES and taken from LINUX."
  90   (define build-exp
  91     (with-imported-modules (source-module-closure
  92                             '((guix build utils)
  93                               (gnu build linux-modules)))
  94       #~(begin
  95           (use-modules (ice-9 match) (ice-9 regex)
  96                        (srfi srfi-1)
  97                        (guix build utils)
  98                        (gnu build linux-modules))
  99
 100           (define (string->regexp str)
 101             ;; Return a regexp that matches STR exactly.
 102             (string-append "^" (regexp-quote str) "$"))
 103
 104           (define module-dir
 105             (string-append #$linux "/lib/modules"))
 106
 107           (define (lookup module)
 108             (let ((name (ensure-dot-ko module)))
 109               (match (find-files module-dir (string->regexp name))
 110                 ((file)
 111                  file)
 112                 (()
 113                  (error "module not found" name module-dir))
 114                 ((_ ...)
 115                  (error "several modules by that name"
 116                         name module-dir)))))
 117
 118           (define modules
 119             (let ((modules (map lookup '#$modules)))
 120               (append modules
 121                       (recursive-module-dependencies modules
 122                                                      #:lookup-module lookup))))
 123
 124           (mkdir #$output)
 125           (for-each (lambda (module)
 126                       (format #t "copying '~a'...~%" module)
 127                       (copy-file module
 128                                  (string-append #$output "/"
 129                                                 (basename module))))
 130                     (delete-duplicates modules)))))
 131
 132   (gexp->derivation "linux-modules" build-exp))
 133
 134 (define* (base-initrd file-systems
 135                       #:key
 136                       (linux linux-libre)
 137                       (mapped-devices '())
 138                       qemu-networking?
 139                       (virtio? #t)
 140                       volatile-root?
 141                       (extra-modules '()))
 142   "Return a monadic derivation that builds a generic initrd, with kernel
 143 modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
 144 mounted by the initrd, possibly in addition to the root file system specified
 145 on the kernel command line via '--root'.  MAPPED-DEVICES is a list of device
 146 mappings to realize before FILE-SYSTEMS are mounted.
 147
 148 When QEMU-NETWORKING? is true, set up networking with the standard QEMU
 149 parameters.  When VIRTIO? is true, load additional modules so the initrd can
 150 be used as a QEMU guest with the root file system on a para-virtualized block
 151 device.
 152
 153 When VOLATILE-ROOT? is true, the root file system is writable but any changes
 154 to it are lost.
 155
 156 The initrd is automatically populated with all the kernel modules necessary
 157 for FILE-SYSTEMS and for the given options.  However, additional kernel
 158 modules can be listed in EXTRA-MODULES.  They will be added to the initrd, and
 159 loaded at boot time in the order in which they appear."
 160   (define virtio-modules
 161     ;; Modules for Linux para-virtualized devices, for use in QEMU guests.
 162     '("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net"
 163       "virtio_console"))
 164
 165   (define cifs-modules
 166     ;; Modules needed to mount CIFS file systems.
 167     '("md4" "ecb" "cifs"))
 168
 169   (define virtio-9p-modules
 170     ;; Modules for the 9p paravirtualized file system.
 171     '("9p" "9pnet_virtio"))
 172
 173   (define (file-system-type-predicate type)
 174     (lambda (fs)
 175       (string=? (file-system-type fs) type)))
 176
 177   (define linux-modules
 178     ;; Modules added to the initrd and loaded from the initrd.
 179     `("ahci"                                  ;for SATA controllers
 180       "usb-storage" "uas"                     ;for the installation image etc.
 181       "usbhid" "hid-generic" "hid-apple"      ;keyboards during early boot
 182       "dm-crypt" "xts" "serpent_generic" "wp512" ;for encrypted root partitions
 183       "nvme"                                     ;for new SSD NVMe devices
 184       ,@(if (string-match "^(x86_64|i[3-6]86)-" (%current-system))
 185             '("pata_acpi" "pata_atiixp"    ;for ATA controllers
 186               "isci")                      ;for SAS controllers like Intel C602
 187             '())
 188       ,@(if (or virtio? qemu-networking?)
 189             virtio-modules
 190             '())
 191       ,@(if (find (file-system-type-predicate "cifs") file-systems)
 192             cifs-modules
 193             '())
 194       ,@(if (find (file-system-type-predicate "9p") file-systems)
 195             virtio-9p-modules
 196             '())
 197       ,@(if (find (file-system-type-predicate "vfat") file-systems)
 198             '("nls_iso8859-1")
 199             '())
 200       ,@(if volatile-root?
 201             '("fuse")
 202             '())
 203       ,@extra-modules))
 204
 205   (define helper-packages
 206     ;; Packages to be copied on the initrd.
 207     `(,@(if (find (lambda (fs)
 208                     (string-prefix? "ext" (file-system-type fs)))
 209                   file-systems)
 210             (list e2fsck/static)
 211             '())
 212       ,@(if (find (lambda (fs)
 213                     (string-suffix? "fat" (file-system-type fs)))
 214                   file-systems)
 215             (list fatfsck/static)
 216             '())
 217       ,@(if volatile-root?
 218             (list unionfs-fuse/static)
 219             '())))
 220
 221   (define device-mapping-commands
 222     ;; List of gexps to open the mapped devices.
 223     (map (lambda (md)
 224            (let* ((source (mapped-device-source md))
 225                   (target (mapped-device-target md))
 226                   (type   (mapped-device-type md))
 227                   (open   (mapped-device-kind-open type)))
 228              (open source target)))
 229          mapped-devices))
 230
 231   (mlet %store-monad ((kodir (flat-linux-module-directory linux
 232                                                           linux-modules)))
 233     (expression->initrd
 234      (with-imported-modules (source-module-closure
 235                              '((gnu build linux-boot)
 236                                (guix build utils)
 237                                (guix build bournish)
 238                                (gnu build file-systems)))
 239        #~(begin
 240            (use-modules (gnu build linux-boot)
 241                         (guix build utils)
 242                         (guix build bournish) ;add the 'bournish' meta-command
 243                         (srfi srfi-26)
 244
 245                         ;; FIXME: The following modules are for
 246                         ;; LUKS-DEVICE-MAPPING.  We should instead propagate
 247                         ;; this info via gexps.
 248                         ((gnu build file-systems)
 249                          #:select (find-partition-by-luks-uuid))
 250                         (rnrs bytevectors))
 251
 252            (with-output-to-port (%make-void-port "w")
 253              (lambda ()
 254                (set-path-environment-variable "PATH" '("bin" "sbin")
 255                                               '#$helper-packages)))
 256
 257            (boot-system #:mounts '#$(map file-system->spec file-systems)
 258                         #:pre-mount (lambda ()
 259                                       (and #$@device-mapping-commands))
 260                         #:linux-modules '#$linux-modules
 261                         #:linux-module-directory '#$kodir
 262                         #:qemu-guest-networking? #$qemu-networking?
 263                         #:volatile-root? '#$volatile-root?)))
 264      #:name "base-initrd")))
 265
 266 ;;; linux-initrd.scm ends here