Commit | Line | Data |
---|---|---|
fbb35558 | 1 | ;;; GNU Guix --- Functional package management for GNU |
970c9993 | 2 | ;;; Copyright © 2013, 2014, 2015, 2018 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 | 73 | |
91e633f0 | 74 | (if compress? |
d422cbb3 LC |
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))) | |
e8277f90 | 90 | output)) |
fbb35558 | 91 | |
1621cf97 LC |
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 | |
1621cf97 | 121 | (references-graphs '()) |
1621cf97 LC |
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 | |
42d10464 | 125 | REFERENCES-GRAPHS." |
1621cf97 LC |
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" | |
1621cf97 LC |
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 | ||
e8277f90 | 150 | (write-cpio-archive output "." #:gzip gzip)) |
1621cf97 | 151 | |
970c9993 LC |
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)) | |
1621cf97 LC |
158 | (delete-file-recursively "contents")) |
159 | ||
fbb35558 | 160 | ;;; linux-initrd.scm ends here |