gnu/build/linux-initrd.scm

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