gnu/build/linux-initrd.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2018, 2020 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, with reset
  43 timestamps in the archive.  When COMPRESS? is true, compress it using GZIP.
  44 On success, return OUTPUT."
  45
  46   ;; Note: as per `ramfs-rootfs-initramfs.txt', always add directory entries
  47   ;; before the files that are inside of it: "The Linux kernel cpio
  48   ;; extractor won't create files in a directory that doesn't exist, so the
  49   ;; directory entries must go before the files that go in those
  50   ;; directories."
  51
  52   (define files
  53     ;; Use 'sort' so that (1) the order of files is deterministic, and (2)
  54     ;; directories appear before the files they contain.
  55     (sort (file-system-fold (const #t)                 ;enter?
  56                             (lambda (file stat result) ;leaf
  57                               (cons file result))
  58                             (lambda (dir stat result)  ;down
  59                               (if (string=? dir directory)
  60                                   result
  61                                   (cons dir result)))
  62                             (lambda (file stat result)
  63                               result)
  64                             (const #f)                 ;skip
  65                             (const #f)                 ;error
  66                             '()
  67                             directory)
  68           string<?))
  69
  70   (call-with-output-file output
  71     (lambda (port)
  72       (cpio:write-cpio-archive files port
  73                                #:file->header cpio:file->cpio-header*)))
  74
  75   (if compress?
  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       output))
  92
  93 (define (cache-compiled-file-name file)
  94   "Return the file name of the in-cache .go file for FILE, relative to the
  95 current directory.
  96
  97 This is similar to what 'compiled-file-name' in (system base compile) does."
  98   (let loop ((file file))
  99     (let ((target (false-if-exception (readlink file))))
 100      (if target
 101          (loop target)
 102          (format #f ".cache/guile/ccache/~a-~a-~a-~a/~a"
 103                  (effective-version)
 104                  (if (eq? (native-endianness) (endianness little))
 105                      "LE"
 106                      "BE")
 107                  (sizeof '*)
 108                  (effective-version)
 109                  file)))))
 110
 111 (define (compile-to-cache file)
 112   "Compile FILE to the cache."
 113   (let ((compiled-file (cache-compiled-file-name file)))
 114     (mkdir-p (dirname compiled-file))
 115     (compile-file file
 116                   #:opts %auto-compilation-options
 117                   #:output-file compiled-file)))
 118
 119 (define* (build-initrd output
 120                        #:key
 121                        guile init
 122                        (references-graphs '())
 123                        (gzip "gzip"))
 124   "Write an initial RAM disk (initrd) to OUTPUT.  The initrd starts the script
 125 at INIT, running GUILE.  It contains all the items referred to by
 126 REFERENCES-GRAPHS."
 127   (mkdir "contents")
 128
 129   ;; Copy the closures of all the items referenced in REFERENCES-GRAPHS.
 130   (populate-store references-graphs "contents"
 131                   #:deduplicate? #f)
 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     (write-cpio-archive output "." #:gzip gzip))
 147
 148   ;; Make sure directories are writable so we can delete files.
 149   (for-each make-file-writable
 150             (find-files "contents"
 151                         (lambda (file stat)
 152                           (eq? 'directory (stat:type stat)))
 153                         #:directories? #t))
 154   (delete-file-recursively "contents"))
 155
 156 ;;; linux-initrd.scm ends here