projects/guix·blob 3bccc5ed · refs

264 lines · 10.8 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2019 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(define-module (gnu system bootstrap)
20 #:use-module (guix gexp)
21 #:use-module (guix modules)
22 #:use-module ((guix packages) #:select (default-guile))
23 #:use-module ((guix self) #:select (make-config.scm))
24 #:use-module ((guix utils)
25 #:select (version-major+minor substitute-keyword-arguments))
26 #:use-module (guix packages)
27 #:use-module (guix build-system trivial)
28 #:use-module (gnu packages commencement)
29 #:use-module (gnu packages guile)
30 #:use-module (gnu packages guile-xyz)
31 #:use-module (gnu system)
32 #:use-module (gnu system shadow)
33 #:use-module (gnu system file-systems)
34 #:use-module (gnu system linux-initrd)
35 #:use-module (gnu bootloader)
36 #:use-module (gnu bootloader grub)
37 #:use-module (ice-9 match))
38
39;;; Commentary:
40;;;
41;;; This file provides tooling to build an operating system image that builds
42;;; a set of derivations straight from the initrd. This allows us to perform
43;;; builds in an environment where the trusted computing base (TCB) has been
44;;; stripped from guix-daemon, shepherd, and other things.
45;;;
46;;; Run "guix system vm gnu/system/bootstrap.scm" to get a VM that runs this
47;;; OS (pass "-m 5000" or so so it has enough memory), or use "guix system
48;;; disk-image", write it to a USB stick, and get it running on the bare
49;;; metal!
50;;;
51;;; Code:
52
53(define* (hash-script obj #:key (guile (default-guile)))
54 "Return a derivation that computes the SHA256 hash of OBJ, using Guile and
55only pure Guile code."
56 (define hashing
57 (package
58 (inherit guile-hashing)
59 (arguments
60 `(#:guile ,guile
61 ,@(package-arguments guile-hashing)))
62 (native-inputs `(("guile" ,guile)))))
63
64 (define build
65 ;; Compute and display the SHA256 of OBJ. Do that in pure Scheme: it's
66 ;; slower, but removes the need for a full-blown C compiler and GNU
67 ;; userland to get libgcrypt, etc.
68 (with-extensions (list hashing)
69 (with-imported-modules (source-module-closure
70 '((guix serialization)))
71 #~(begin
72 (use-modules (hashing sha-2)
73 (guix serialization)
74 (rnrs io ports)
75 (rnrs bytevectors)
76 (ice-9 match))
77
78 (define (port-sha256 port)
79 ;; Return the SHA256 of the data read from PORT.
80 (define bv (make-bytevector 65536))
81 (define hash (make-sha-256))
82
83 (let loop ()
84 (match (get-bytevector-n! port bv 0
85 (bytevector-length bv))
86 ((? eof-object?)
87 (sha-256-finish! hash)
88 hash)
89 (n
90 (sha-256-update! hash bv 0 n)
91 (loop)))))
92
93 (define (file-sha256 file)
94 ;; Return the SHA256 of FILE.
95 (call-with-input-file file port-sha256))
96
97 ;; Serialize OBJ as a nar. XXX: We should avoid writing to disk
98 ;; as this might be a tmpfs.
99 (call-with-output-file "nar"
100 (lambda (port)
101 (write-file #$obj port)))
102
103 ;; Compute, display, and store the hash of OBJ.
104 (let ((hash (file-sha256 "nar")))
105 (call-with-output-file #$output
106 (lambda (result)
107 (for-each (lambda (port)
108 (format port "~a\t~a~%"
109 (sha-256->string hash)
110 #$obj))
111 (list (current-output-port)
112 result)))))))))
113
114 (computed-file "build-result-hashes" build
115 #:guile guile
116 #:options
117 `(#:effective-version
118 ,(version-major+minor (package-version guile)))))
119
120(define* (build-script obj #:key (guile (default-guile)))
121 "Return a build script that builds OBJ, an arbitrary lowerable object such
122as a package, and all its dependencies. The script essentially unrolls the
123build loop normally performed by 'guix-daemon'."
124 (define select?
125 ;; Select every module but (guix config) and non-Guix modules.
126 (match-lambda
127 (('guix 'config) #f)
128 (('guix _ ...) #t)
129 (_ #f)))
130
131 (define fake-gcrypt-hash
132 ;; Fake (gcrypt hash) module: since (gcrypt hash) is pulled in and not
133 ;; actually used, plus GUILE may be a statically-linked Guile not capable
134 ;; of loading libgcrypt, it's OK to just provide a phony module.
135 (scheme-file "hash.scm"
136 #~(define-module (gcrypt hash)
137 #:export (sha1 sha256))))
138
139 (define emit-script
140 (with-imported-modules `(((guix config) => ,(make-config.scm))
141 ((gcrypt hash) => ,fake-gcrypt-hash)
142
143 ,@(source-module-closure
144 `((guix derivations))
145 #:select? select?))
146 #~(begin
147 (use-modules (guix derivations)
148 (srfi srfi-1)
149 (ice-9 match)
150 (ice-9 pretty-print))
151
152 (define drv
153 ;; Load the derivation for OBJ.
154 (read-derivation-from-file #$(raw-derivation-file obj)))
155
156 (define (derivation->script drv)
157 ;; Return a snippet that "manually" builds DRV.
158 `(begin
159 ;; XXX: Drop part of DRV's file name to not cause the
160 ;; daemon to detect the reference and go wrong ("path `%1%'
161 ;; is not valid").
162 (format #t "~%~%build-started ...~a~%~%"
163 ,(string-drop (basename
164 (derivation-file-name
165 drv))
166 10))
167
168 ;; XXX: Use the same directory name as the daemon?
169 (mkdir-p "/tmp/guix-build")
170 (chdir "/tmp/guix-build")
171 (environ ',(map (match-lambda
172 ((key . value)
173 (string-append key "=" value)))
174 (derivation-builder-environment-vars drv)))
175 (let ((result (system* ,(derivation-builder drv)
176 ,@(derivation-builder-arguments
177 drv))))
178 (chdir "/")
179 (delete-file-recursively "/tmp/guix-build")
180 (zero? result))))
181
182 (define graph
183 ;; Closure of the derivation for OBJ. This does _not_ contain
184 ;; fixed-output derivations, but it contains sources.
185 (filter-map (lambda (file)
186 (and (string-suffix? ".drv" file)
187 (let* ((drv (read-derivation-from-file file))
188 (out (derivation->output-path drv)))
189 ;; GUILE itself is already in the initrd
190 ;; because it's executing this program.
191 ;; Thus, don't try to "build" it again.
192 (and (not (string=? out #$guile))
193 drv))))
194 (call-with-input-file #$(raw-derivation-closure obj)
195 read)))
196
197 ;; Emit a script that builds OBJ and all its
198 ;; dependencies sequentially.
199 (call-with-output-file #$output
200 (lambda (port)
201 (format port "#!~a/bin/guile --no-auto-compile~%!#~%" #$guile)
202 (pretty-print '(begin
203 (use-modules (srfi srfi-1)
204 (ice-9 rdelim))
205
206 ;; Ensure the script refers to all the
207 ;; sources of OBJ.
208 (define these-are-the-sources-we-need
209 '#$(object-sources obj))
210 (primitive-load
211 #$(local-file "../../guix/build/utils.scm")))
212 port)
213 (newline port)
214 (pretty-print `(and ,@(map derivation->script graph)
215 (begin
216 (format #t "~%Congratulations!~%")
217 (sleep 3600)))
218 port)
219 (chmod port #o555))))))
220
221 (computed-file "build.scm" emit-script
222 #:guile guile))
223
224(define (bootstrapping-os obj)
225 "Return an operating system that starts building OBJ and all its
226dependencies, from scratch, as it boots."
227 (operating-system
228 (host-name "komputilo")
229 (timezone "Africa/Casablanca")
230 (locale "en_US.UTF-8")
231
232 (bootloader (bootloader-configuration
233 (bootloader grub-bootloader)
234 (target "/dev/sdX")))
235 ;; TODO: Use a minimal Linux-libre kernel.
236 (file-systems (cons (file-system
237 (device (file-system-label "my-root"))
238 (mount-point "/")
239 (type "ext4"))
240 %base-file-systems))
241
242 ;; Network access and all that are not needed.
243 (firmware '())
244
245 (users (cons (user-account
246 (name "vagneke")
247 (comment "The Bootstrapper")
248 (group "users"))
249 %base-user-accounts))
250
251 ;; Use a special initrd that builds it all! The initrd contains the
252 ;; script returned by 'build-script' and all its dependencies, which
253 ;; includes all the source code (tarballs) necessary to build them.
254 (initrd (lambda (fs . rest)
255 (expression->initrd
256 (let ((obj (hash-script obj #:guile %bootstrap-guile+guild)))
257 #~(execl #$(build-script obj #:guile %bootstrap-guile+guild)
258 "build"))
259 #:guile %bootstrap-guile+guild)))))
260
261;; This operating system builds MES-BOOT from scratch. That currently
262;; requires ~5 GiB of RAM. TODO: Should we mount a root file system on a hard
263;; disk or...?
264(bootstrapping-os (@@ (gnu packages commencement) mes-boot))