Commit | Line | Data |
---|---|---|
fbb35558 | 1 | ;;; GNU Guix --- Functional package management for GNU |
e8277f90 | 2 | ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> |
fbb35558 LC |
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) | |
e8277f90 | 20 | #:use-module ((guix cpio) #:prefix cpio:) |
1621cf97 LC |
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)) | |
fbb35558 | 26 | #:use-module (ice-9 ftw) |
1621cf97 LC |
27 | #:export (write-cpio-archive |
28 | build-initrd)) | |
fbb35558 LC |
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) | |
e8277f90 LC |
41 | (gzip "gzip")) |
42 | "Write a cpio archive containing DIRECTORY to file OUTPUT. When | |
fbb35558 | 43 | COMPRESS? is true, compress it using GZIP. On success, return OUTPUT." |
84da4ad4 | 44 | |
e8277f90 LC |
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." | |
fbb35558 | 50 | |
e8277f90 | 51 | (define files |
583323ca LC |
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<?)) | |
e8277f90 LC |
68 | |
69 | (call-with-output-file output | |
70 | (lambda (port) | |
eae5b3ff LC |
71 | (cpio:write-cpio-archive files port |
72 | #:file->header cpio:file->cpio-header*))) | |
e8277f90 LC |
73 | |
74 | (or (not compress?) | |
0334ef2a LC |
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)) | |
e8277f90 LC |
78 | (rename-file (string-append output ".gz") |
79 | output)) | |
80 | output)) | |
fbb35558 | 81 | |
1621cf97 LC |
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 | |
1621cf97 | 111 | (references-graphs '()) |
1621cf97 LC |
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 | |
42d10464 | 115 | REFERENCES-GRAPHS." |
1621cf97 LC |
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" | |
1621cf97 LC |
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 | ||
e8277f90 | 140 | (write-cpio-archive output "." #:gzip gzip)) |
1621cf97 LC |
141 | |
142 | (delete-file-recursively "contents")) | |
143 | ||
fbb35558 | 144 | ;;; linux-initrd.scm ends here |