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