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   (if compress?
  75       ;; Gzip insists on adding a '.gz' suffix and does nothing if the input
  76       ;; file already has that suffix.  Shuffle files around to placate it.
  77       (let* ((gz-suffix? (string-suffix? ".gz" output))
  78              (sans-gz    (if gz-suffix?
  79                              (string-drop-right output 3)
  80                              output)))
  81         (when gz-suffix?
  82           (rename-file output sans-gz))
  83         ;; Use '--no-name' so that gzip records neither a file name nor a time
  84         ;; stamp in its output.
  85         (and (zero? (system* gzip "--best" "--no-name" sans-gz))
  86              (begin
  87                (unless gz-suffix?
  88                  (rename-file (string-append output ".gz") output))
  89                output)))
  90       output))
  91
  92 (define (cache-compiled-file-name file)
  93   "Return the file name of the in-cache .go file for FILE, relative to the
  94 current directory.
  95
  96 This is similar to what 'compiled-file-name' in (system base compile) does."
  97   (let loop ((file file))
  98     (let ((target (false-if-exception (readlink file))))
  99      (if target
 100          (loop target)
 101          (format #f ".cache/guile/ccache/~a-~a-~a-~a/~a"
 102                  (effective-version)
 103                  (if (eq? (native-endianness) (endianness little))
 104                      "LE"
 105                      "BE")
 106                  (sizeof '*)
 107                  (effective-version)
 108                  file)))))
 109
 110 (define (compile-to-cache file)
 111   "Compile FILE to the cache."
 112   (let ((compiled-file (cache-compiled-file-name file)))
 113     (mkdir-p (dirname compiled-file))
 114     (compile-file file
 115                   #:opts %auto-compilation-options
 116                   #:output-file compiled-file)))
 117
 118 (define* (build-initrd output
 119                        #:key
 120                        guile init
 121                        (references-graphs '())
 122                        (gzip "gzip"))
 123   "Write an initial RAM disk (initrd) to OUTPUT.  The initrd starts the script
 124 at INIT, running GUILE.  It contains all the items referred to by
 125 REFERENCES-GRAPHS."
 126   (mkdir "contents")
 127
 128   ;; Copy the closures of all the items referenced in REFERENCES-GRAPHS.
 129   (populate-store references-graphs "contents")
 130
 131   (with-directory-excursion "contents"
 132     ;; Make '/init'.
 133     (symlink init "init")
 134
 135     ;; Compile it.
 136     (compile-to-cache "init")
 137
 138     ;; Allow Guile to find out where it is (XXX).  See
 139     ;; 'guile-relocatable.patch'.
 140     (mkdir-p "proc/self")
 141     (symlink (string-append guile "/bin/guile") "proc/self/exe")
 142     (readlink "proc/self/exe")
 143
 144     ;; Reset the timestamps of all the files that will make it in the initrd.
 145     (for-each (lambda (file)
 146                 (unless (eq? 'symlink (stat:type (lstat file)))
 147                   (utime file 0 0 0 0)))
 148               (find-files "." ".*"))
 149
 150     (write-cpio-archive output "." #:gzip gzip))
 151
 152   ;; Make sure directories are writable so we can delete files.
 153   (for-each make-file-writable
 154             (find-files "contents"
 155                         (lambda (file stat)
 156                           (eq? 'directory (stat:type stat)))
 157                         #:directories? #t))
 158   (delete-file-recursively "contents"))
 159
 160 ;;; linux-initrd.scm ends here