projects/guix·blob python-team · refs

156 lines · 5.9 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013, 2014, 2015, 2018, 2020 Ludovic Courtès <[email protected]>
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;;; Commentary:
20;;;
21;;; Tools to create Linux initial RAM disks ("initrds"). Initrds are
22;;; essentially gzipped cpio archives, with a '/init' executable that the
23;;; kernel runs at boot time.
24;;;
25;;; Code:
26
27(define-module (gnu build linux-initrd)
28 #:use-module ((guix cpio) #:prefix cpio:)
29 #:use-module (guix build utils)
30 #:use-module (guix build store-copy)
31 #:use-module (system base compile)
32 #:use-module (rnrs bytevectors)
33 #:use-module ((system foreign) #:select (sizeof))
34 #:use-module (ice-9 ftw)
35 #:export (write-cpio-archive
36 build-initrd))
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, with reset
43timestamps in the archive. When COMPRESS? is true, compress it using GZIP.
44On success, return OUTPUT."
45
46 ;; Note: as per `ramfs-rootfs-initramfs.txt', always add directory entries
47 ;; before the files that are inside of it: "The Linux kernel cpio
48 ;; extractor won't create files in a directory that doesn't exist, so the
49 ;; directory entries must go before the files that go in those
50 ;; directories."
51
52 (define files
53 ;; Use 'sort' so that (1) the order of files is deterministic, and (2)
54 ;; directories appear before the files they contain.
55 (sort (file-system-fold (const #t) ;enter?
56 (lambda (file stat result) ;leaf
57 (cons file result))
58 (lambda (dir stat result) ;down
59 (if (string=? dir directory)
60 result
61 (cons dir result)))
62 (lambda (file stat result)
63 result)
64 (const #f) ;skip
65 (const #f) ;error
66 '()
67 directory)
68 string<?))
69
70 (call-with-output-file output
71 (lambda (port)
72 (cpio:write-cpio-archive files port
73 #:file->header cpio:file->cpio-header*)))
74
75 (if compress?
76 ;; Gzip insists on adding a '.gz' suffix and does nothing if the input
77 ;; file already has that suffix. Shuffle files around to placate it.
78 (let* ((gz-suffix? (string-suffix? ".gz" output))
79 (sans-gz (if gz-suffix?
80 (string-drop-right output 3)
81 output)))
82 (when gz-suffix?
83 (rename-file output sans-gz))
84 ;; Use '--no-name' so that gzip records neither a file name nor a time
85 ;; stamp in its output.
86 (and (zero? (system* gzip "--best" "--no-name" sans-gz))
87 (begin
88 (unless gz-suffix?
89 (rename-file (string-append output ".gz") output))
90 output)))
91 output))
92
93(define (cache-compiled-file-name file)
94 "Return the file name of the in-cache .go file for FILE, relative to the
95current directory.
96
97This is similar to what 'compiled-file-name' in (system base compile) does."
98 (let loop ((file file))
99 (let ((target (false-if-exception (readlink file))))
100 (if target
101 (loop target)
102 (format #f ".cache/guile/ccache/~a-~a-~a-~a/~a"
103 (effective-version)
104 (if (eq? (native-endianness) (endianness little))
105 "LE"
106 "BE")
107 (sizeof '*)
108 (effective-version)
109 file)))))
110
111(define (compile-to-cache file)
112 "Compile FILE to the cache."
113 (let ((compiled-file (cache-compiled-file-name file)))
114 (mkdir-p (dirname compiled-file))
115 (compile-file file
116 #:opts %auto-compilation-options
117 #:output-file compiled-file)))
118
119(define* (build-initrd output
120 #:key
121 guile init
122 (references-graphs '())
123 (gzip "gzip"))
124 "Write an initial RAM disk (initrd) to OUTPUT. The initrd starts the script
125at INIT, running GUILE. It contains all the items referred to by
126REFERENCES-GRAPHS."
127 (mkdir "contents")
128
129 ;; Copy the closures of all the items referenced in REFERENCES-GRAPHS.
130 (populate-store references-graphs "contents"
131 #:deduplicate? #f)
132
133 (with-directory-excursion "contents"
134 ;; Make '/init'.
135 (symlink init "init")
136
137 ;; Compile it.
138 (compile-to-cache "init")
139
140 ;; Allow Guile to find out where it is (XXX). See
141 ;; 'guile-relocatable.patch'.
142 (mkdir-p "proc/self")
143 (symlink (string-append guile "/bin/guile") "proc/self/exe")
144 (readlink "proc/self/exe")
145
146 (write-cpio-archive output "." #:gzip gzip))
147
148 ;; Make sure directories are writable so we can delete files.
149 (for-each make-file-writable
150 (find-files "contents"
151 (lambda (file stat)
152 (eq? 'directory (stat:type stat)))
153 #:directories? #t))
154 (delete-file-recursively "contents"))
155
156;;; linux-initrd.scm ends here