gnu/build/linux-initrd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2018 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 build linux-initrd)
  20   #:use-module ((guix cpio) #:prefix cpio:)
  21   #:use-module (guix build utils)
  22   #:use-module (guix build store-copy)
  23   #:use-module (system base compile)
  24   #:use-module (rnrs bytevectors)
  25   #:use-module ((system foreign) #:select (sizeof))
  26   #:use-module (ice-9 ftw)
  27   #:export (write-cpio-archive
  28             build-initrd))
  29
  30 ;;; Commentary:
  31 ;;;
  32 ;;; Tools to create Linux initial RAM disks ("initrds").  Initrds are
  33 ;;; essentially gzipped cpio archives, with a '/init' executable that the
  34 ;;; kernel runs at boot time.
  35 ;;;
  36 ;;; Code:
  37
  38 (define* (write-cpio-archive output directory
  39                              #:key
  40                              (compress? #t)
  41                              (gzip "gzip"))
  42   "Write a cpio archive containing DIRECTORY to file OUTPUT.  When
  43 COMPRESS? is true, compress it using GZIP.  On success, return OUTPUT."
  44
  45   ;; Note: as per `ramfs-rootfs-initramfs.txt', always add directory entries
  46   ;; before the files that are inside of it: "The Linux kernel cpio
  47   ;; extractor won't create files in a directory that doesn't exist, so the
  48   ;; directory entries must go before the files that go in those
  49   ;; directories."
  50
  51   (define files
  52     ;; Use 'sort' so that (1) the order of files is deterministic, and (2)
  53     ;; directories appear before the files they contain.
  54     (sort (file-system-fold (const #t)                 ;enter?
  55                             (lambda (file stat result) ;leaf
  56                               (cons file result))
  57                             (lambda (dir stat result)  ;down
  58                               (if (string=? dir directory)
  59                                   result
  60                                   (cons dir result)))
  61                             (lambda (file stat result)
  62                               result)
  63                             (const #f)                 ;skip
  64                             (const #f)                 ;error
  65                             '()
  66                             directory)
  67           string<?))
  68
  69   (call-with-output-file output
  70     (lambda (port)
  71       (cpio:write-cpio-archive files port
  72                                #:file->header cpio:file->cpio-header*)))
  73
  74   (or (not compress?)
  75
  76       ;; Gzip insists on adding a '.gz' suffix and does nothing if the input
  77       ;; file already has that suffix.  Shuffle files around to placate it.
  78       (let* ((gz-suffix? (string-suffix? ".gz" output))
  79              (sans-gz    (if gz-suffix?
  80                              (string-drop-right output 3)
  81                              output)))
  82         (when gz-suffix?
  83           (rename-file output sans-gz))
  84         ;; Use '--no-name' so that gzip records neither a file name nor a time
  85         ;; stamp in its output.
  86         (and (zero? (system* gzip "--best" "--no-name" sans-gz))
  87              (begin
  88                (unless gz-suffix?
  89                  (rename-file (string-append output ".gz") output))
  90                output)))
  91
  92       output))
  93
  94 (define (cache-compiled-file-name file)
  95   "Return the file name of the in-cache .go file for FILE, relative to the
  96 current directory.
  97
  98 This is similar to what 'compiled-file-name' in (system base compile) does."
  99   (let loop ((file file))
 100     (let ((target (false-if-exception (readlink file))))
 101      (if target
 102          (loop target)
 103          (format #f ".cache/guile/ccache/~a-~a-~a-~a/~a"
 104                  (effective-version)
 105                  (if (eq? (native-endianness) (endianness little))
 106                      "LE"
 107                      "BE")
 108                  (sizeof '*)
 109                  (effective-version)
 110                  file)))))
 111
 112 (define (compile-to-cache file)
 113   "Compile FILE to the cache."
 114   (let ((compiled-file (cache-compiled-file-name file)))
 115     (mkdir-p (dirname compiled-file))
 116     (compile-file file
 117                   #:opts %auto-compilation-options
 118                   #:output-file compiled-file)))
 119
 120 (define* (build-initrd output
 121                        #:key
 122                        guile init
 123                        (references-graphs '())
 124                        (gzip "gzip"))
 125   "Write an initial RAM disk (initrd) to OUTPUT.  The initrd starts the script
 126 at INIT, running GUILE.  It contains all the items referred to by
 127 REFERENCES-GRAPHS."
 128   (mkdir "contents")
 129
 130   ;; Copy the closures of all the items referenced in REFERENCES-GRAPHS.
 131   (populate-store references-graphs "contents")
 132
 133   (with-directory-excursion "contents"
 134     ;; Make '/init'.
 135     (symlink init "init")
 136
 137     ;; Compile it.
 138     (compile-to-cache "init")
 139
 140     ;; Allow Guile to find out where it is (XXX).  See
 141     ;; 'guile-relocatable.patch'.
 142     (mkdir-p "proc/self")
 143     (symlink (string-append guile "/bin/guile") "proc/self/exe")
 144     (readlink "proc/self/exe")
 145
 146     ;; Reset the timestamps of all the files that will make it in the initrd.
 147     (for-each (lambda (file)
 148                 (unless (eq? 'symlink (stat:type (lstat file)))
 149                   (utime file 0 0 0 0)))
 150               (find-files "." ".*"))
 151
 152     (write-cpio-archive output "." #:gzip gzip))
 153
 154   ;; Make sure directories are writable so we can delete files.
 155   (for-each make-file-writable
 156             (find-files "contents"
 157                         (lambda (file stat)
 158                           (eq? 'directory (stat:type stat)))
 159                         #:directories? #t))
 160   (delete-file-recursively "contents"))
 161
 162 ;;; linux-initrd.scm ends here