gnu/system/linux-initrd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu system linux-initrd)
  20   #:use-module (guix monads)
  21   #:use-module (guix gexp)
  22   #:use-module (guix utils)
  23   #:use-module ((guix store)
  24                 #:select (%store-prefix))
  25   #:use-module ((guix derivations)
  26                 #:select (derivation->output-path))
  27   #:use-module (gnu packages cpio)
  28   #:use-module (gnu packages compression)
  29   #:use-module (gnu packages linux)
  30   #:use-module (gnu packages guile)
  31   #:use-module ((gnu packages make-bootstrap)
  32                 #:select (%guile-static-stripped))
  33   #:use-module (gnu system file-systems)
  34   #:use-module (ice-9 match)
  35   #:use-module (ice-9 regex)
  36   #:use-module (srfi srfi-1)
  37   #:export (expression->initrd
  38             base-initrd))
  39
  40 \f
  41 ;;; Commentary:
  42 ;;;
  43 ;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in
  44 ;;; particular initrd's that run Guile.
  45 ;;;
  46 ;;; Code:
  47
  48
  49 (define* (expression->initrd exp
  50                              #:key
  51                              (guile %guile-static-stripped)
  52                              (cpio cpio)
  53                              (gzip gzip)
  54                              (name "guile-initrd")
  55                              (system (%current-system))
  56                              (modules '())
  57                              (to-copy '())
  58                              (linux #f)
  59                              (linux-modules '()))
  60   "Return a derivation that builds a Linux initrd (a gzipped cpio archive)
  61 containing GUILE and that evaluates EXP, a G-expression, upon booting.
  62
  63 LINUX-MODULES is a list of '.ko' file names to be copied from LINUX into the
  64 initrd.  TO-COPY is a list of additional derivations or packages to copy to
  65 the initrd.  MODULES is a list of Guile module names to be embedded in the
  66 initrd."
  67
  68   ;; General Linux overview in `Documentation/early-userspace/README' and
  69   ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.
  70
  71   (define (string->regexp str)
  72     ;; Return a regexp that matches STR exactly.
  73     (string-append "^" (regexp-quote str) "$"))
  74
  75   (mlet* %store-monad ((source   (imported-modules modules))
  76                        (compiled (compiled-modules modules)))
  77     (define builder
  78       ;; TODO: Move most of this code to (gnu build linux-boot).
  79       #~(begin
  80           (use-modules (guix build utils)
  81                        (ice-9 pretty-print)
  82                        (ice-9 popen)
  83                        (ice-9 match)
  84                        (ice-9 ftw)
  85                        (srfi srfi-26)
  86                        (system base compile)
  87                        (rnrs bytevectors)
  88                        ((system foreign) #:select (sizeof)))
  89
  90           (let ((cpio    (string-append #$cpio "/bin/cpio"))
  91                 (gzip    (string-append #$gzip "/bin/gzip"))
  92                 (modules #$source)
  93                 (gos     #$compiled)
  94                 (scm-dir (string-append "share/guile/" (effective-version)))
  95                 (go-dir  (format #f ".cache/guile/ccache/~a-~a-~a-~a"
  96                                  (effective-version)
  97                                  (if (eq? (native-endianness) (endianness little))
  98                                      "LE"
  99                                      "BE")
 100                                  (sizeof '*)
 101                                  (effective-version))))
 102             (mkdir #$output)
 103             (mkdir "contents")
 104             (with-directory-excursion "contents"
 105               (copy-recursively #$guile ".")
 106               (call-with-output-file "init"
 107                 (lambda (p)
 108                   (format p "#!/bin/guile -ds~%!#~%" #$guile)
 109                   (pretty-print '#$exp p)))
 110               (chmod "init" #o555)
 111               (chmod "bin/guile" #o555)
 112
 113               ;; Copy Guile modules.
 114               (chmod scm-dir #o777)
 115               (copy-recursively modules scm-dir
 116                                 #:follow-symlinks? #t)
 117               (copy-recursively gos (string-append "lib/guile/"
 118                                                    (effective-version) "/ccache")
 119                                 #:follow-symlinks? #t)
 120
 121               ;; Compile `init'.
 122               (mkdir-p go-dir)
 123               (set! %load-path (cons modules %load-path))
 124               (set! %load-compiled-path (cons gos %load-compiled-path))
 125               (compile-file "init"
 126                             #:opts %auto-compilation-options
 127                             #:output-file (string-append go-dir "/init.go"))
 128
 129               ;; Copy Linux modules.
 130               (let* ((linux      #$linux)
 131                      (module-dir (and linux
 132                                       (string-append linux "/lib/modules"))))
 133                 (mkdir "modules")
 134                 #$@(map (lambda (module)
 135                           #~(match (find-files module-dir
 136                                                #$(string->regexp module))
 137                               ((file)
 138                                (format #t "copying '~a'...~%" file)
 139                                (copy-file file (string-append "modules/"
 140                                                               #$module)))
 141                               (()
 142                                (error "module not found" #$module module-dir))
 143                               ((_ ...)
 144                                (error "several modules by that name"
 145                                       #$module module-dir))))
 146                         linux-modules))
 147
 148               (let ((store   #$(string-append "." (%store-prefix)))
 149                     (to-copy '#$to-copy))
 150                 (unless (null? to-copy)
 151                   (mkdir-p store))
 152                 ;; XXX: Should we do export-references-graph?
 153                 (for-each (lambda (input)
 154                             (let ((target
 155                                    (string-append store "/"
 156                                                   (basename input))))
 157                               (copy-recursively input target)))
 158                           to-copy))
 159
 160               ;; Reset the timestamps of all the files that will make it in the
 161               ;; initrd.
 162               (for-each (cut utime <> 0 0 0 0)
 163                         (find-files "." ".*"))
 164
 165               (system* cpio "--version")
 166               (let ((pipe (open-pipe* OPEN_WRITE cpio "-o"
 167                                       "-O" (string-append #$output "/initrd")
 168                                       "-H" "newc" "--null")))
 169                 (define print0
 170                   (let ((len (string-length "./")))
 171                     (lambda (file)
 172                       (format pipe "~a\0" (string-drop file len)))))
 173
 174                 ;; Note: as per `ramfs-rootfs-initramfs.txt', always add
 175                 ;; directory entries before the files that are inside of it: "The
 176                 ;; Linux kernel cpio extractor won't create files in a directory
 177                 ;; that doesn't exist, so the directory entries must go before
 178                 ;; the files that go in those directories."
 179                 (file-system-fold (const #t)
 180                                   (lambda (file stat result) ; leaf
 181                                     (print0 file))
 182                                   (lambda (dir stat result) ; down
 183                                     (unless (string=? dir ".")
 184                                       (print0 dir)))
 185                                   (const #f)         ; up
 186                                   (const #f)         ; skip
 187                                   (const #f)
 188                                   #f
 189                                   ".")
 190
 191                 (and (zero? (close-pipe pipe))
 192                      (with-directory-excursion #$output
 193                        (and (zero? (system* gzip "--best" "initrd"))
 194                             (rename-file "initrd.gz" "initrd")))))))))
 195
 196    (gexp->derivation name builder
 197                      #:modules '((guix build utils)))))
 198
 199 (define (file-system->spec fs)
 200   "Return a list corresponding to file-system FS that can be passed to the
 201 initrd code."
 202   (match fs
 203     (($ <file-system> device title mount-point type flags options _ check?)
 204      (list device title mount-point type flags options check?))))
 205
 206 (define* (base-initrd file-systems
 207                       #:key
 208                       qemu-networking?
 209                       virtio?
 210                       volatile-root?
 211                       (extra-modules '())
 212                       guile-modules-in-chroot?)
 213   "Return a monadic derivation that builds a generic initrd.  FILE-SYSTEMS is
 214 a list of file-systems to be mounted by the initrd, possibly in addition to
 215 the root file system specified on the kernel command line via '--root'.
 216
 217 When QEMU-NETWORKING? is true, set up networking with the standard QEMU
 218 parameters.  When VIRTIO? is true, load additional modules so the initrd can
 219 be used as a QEMU guest with para-virtualized I/O drivers.
 220
 221 When VOLATILE-ROOT? is true, the root file system is writable but any changes
 222 to it are lost.
 223
 224 The initrd is automatically populated with all the kernel modules necessary
 225 for FILE-SYSTEMS and for the given options.  However, additional kernel
 226 modules can be listed in EXTRA-MODULES.  They will be added to the initrd, and
 227 loaded at boot time in the order in which they appear.
 228
 229 When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
 230 the new root.  This is necessary is the file specified as '--load' needs
 231 access to these modules (which is the case if it wants to even just print an
 232 exception and backtrace!)."
 233   (define virtio-modules
 234     ;; Modules for Linux para-virtualized devices, for use in QEMU guests.
 235     '("virtio.ko" "virtio_ring.ko" "virtio_pci.ko"
 236       "virtio_balloon.ko" "virtio_blk.ko" "virtio_net.ko"))
 237
 238   (define cifs-modules
 239     ;; Modules needed to mount CIFS file systems.
 240     '("md4.ko" "ecb.ko" "cifs.ko"))
 241
 242   (define virtio-9p-modules
 243     ;; Modules for the 9p paravirtualized file system.
 244     '("fscache.ko" "9pnet.ko" "9p.ko" "9pnet_virtio.ko"))
 245
 246   (define (file-system-type-predicate type)
 247     (lambda (fs)
 248       (string=? (file-system-type fs) type)))
 249
 250   (define linux-modules
 251     ;; Modules added to the initrd and loaded from the initrd.
 252     `("libahci.ko" "ahci.ko" ; modules for SATA controllers
 253       ,@(if (or virtio? qemu-networking?)
 254             virtio-modules
 255             '())
 256       ,@(if (find (file-system-type-predicate "cifs") file-systems)
 257             cifs-modules
 258             '())
 259       ,@(if (find (file-system-type-predicate "9p") file-systems)
 260             virtio-9p-modules
 261             '())
 262       ,@(if volatile-root?
 263             '("fuse.ko")
 264             '())
 265       ,@extra-modules))
 266
 267   (define helper-packages
 268     ;; Packages to be copied on the initrd.
 269     `(,@(if (find (lambda (fs)
 270                     (string-prefix? "ext" (file-system-type fs)))
 271                   file-systems)
 272             (list e2fsck/static)
 273             '())
 274       ,@(if volatile-root?
 275             (list unionfs-fuse/static)
 276             '())))
 277
 278   (expression->initrd
 279    #~(begin
 280        (use-modules (gnu build linux-boot)
 281                     (guix build utils)
 282                     (srfi srfi-26))
 283
 284        (with-output-to-port (%make-void-port "w")
 285          (lambda ()
 286            (set-path-environment-variable "PATH" '("bin" "sbin")
 287                                           '#$helper-packages)))
 288
 289        (boot-system #:mounts '#$(map file-system->spec file-systems)
 290                     #:linux-modules '#$linux-modules
 291                     #:qemu-guest-networking? #$qemu-networking?
 292                     #:guile-modules-in-chroot? '#$guile-modules-in-chroot?
 293                     #:volatile-root? '#$volatile-root?))
 294    #:name "base-initrd"
 295    #:modules '((guix build utils)
 296                (gnu build linux-boot)
 297                (gnu build file-systems))
 298    #:to-copy helper-packages
 299    #:linux linux-libre
 300    #:linux-modules linux-modules))
 301
 302 ;;; linux-initrd.scm ends here