projects/guix·blob python-team · refs

313 lines · 12.3 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013-2020, 2022 Ludovic Courtès <[email protected]>
3;;; Copyright © 2016 Chris Marusich <[email protected]>
4;;; Copyright © 2022 Maxim Cournoyer <[email protected]>
5;;; Copyright © 2024 Nicolas Graves <[email protected]>
6;;;
7;;; This file is part of GNU Guix.
8;;;
9;;; GNU Guix is free software; you can redistribute it and/or modify it
10;;; under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 3 of the License, or (at
12;;; your option) any later version.
13;;;
14;;; GNU Guix is distributed in the hope that it will be useful, but
15;;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;;
24;;; This module supports the installation of the GNU system on a hard disk.
25;;; It is meant to be used both in a build environment (in derivations that
26;;; build VM images), and on the bare metal (when really installing the
27;;; system.)
28;;;
29;;; Code:
30
31(define-module (gnu build install)
32 #:use-module (guix build syscalls)
33 #:use-module (guix build utils)
34 #:use-module (guix build store-copy)
35 #:use-module (srfi srfi-26)
36 #:use-module (ice-9 match)
37 #:export (install-boot-config
38 evaluate-populate-directive
39 populate-root-file-system
40 install-database-and-gc-roots
41 populate-single-profile-directory
42 mount-cow-store
43 unmount-cow-store))
44
45(define (install-boot-config bootcfg bootcfg-location mount-point)
46 "Atomically copy BOOTCFG into BOOTCFG-LOCATION on the MOUNT-POINT. Note
47that the caller must make sure that BOOTCFG is registered as a GC root so
48that the fonts, background images, etc. referred to by BOOTCFG are not GC'd."
49 (let* ((target (string-append mount-point bootcfg-location))
50 (pivot (string-append target ".new")))
51 (mkdir-p (dirname target))
52
53 ;; Copy BOOTCFG instead of just symlinking it, because symlinks won't
54 ;; work when /boot is on a separate partition. Do that atomically.
55 (copy-file bootcfg pivot)
56 (rename-file pivot target)))
57
58(define* (evaluate-populate-directive directive target
59 #:key
60 (default-gid 0)
61 (default-uid 0)
62 (error-on-dangling-symlink? #t))
63 "Evaluate DIRECTIVE, an sexp describing a file or directory to create under
64directory TARGET. DEFAULT-UID and DEFAULT-GID are the default UID and GID in
65the context of the caller. If the directive matches those defaults then,
66'chown' won't be run. When ERROR-ON-DANGLING-SYMLINK? is true, abort with an
67error when a dangling symlink would be created."
68 (define target* (if (string-suffix? "/" target)
69 target
70 (string-append target "/")))
71 (let loop ((directive directive))
72 (catch 'system-error
73 (lambda ()
74 (match directive
75 (('directory name)
76 (mkdir-p (string-append target* name)))
77 (('directory name uid gid)
78 (let ((dir (string-append target* name)))
79 (mkdir-p dir)
80 ;; If called from a context without "root" permissions, "chown"
81 ;; to root will fail. In that case, do not try to run "chown"
82 ;; and assume that the file will be chowned elsewhere (when
83 ;; interned in the store for instance).
84 (or (and (= uid default-uid) (= gid default-gid))
85 (chown dir uid gid))))
86 (('directory name uid gid mode)
87 (loop `(directory ,name ,uid ,gid))
88 (chmod (string-append target* name) mode))
89 (('file name)
90 (call-with-output-file (string-append target* name)
91 (const #t)))
92 (('file name (? string? content))
93 (call-with-output-file (string-append target* name)
94 (lambda (port)
95 (display content port))))
96 ((new '-> old)
97 (let ((new* (string-append target* new)))
98 (let try ()
99 (catch 'system-error
100 (lambda ()
101 (when error-on-dangling-symlink?
102 ;; When the symbolic link points to a relative path,
103 ;; checking if its target exists must be done relatively
104 ;; to the link location.
105 (unless (if (string-prefix? "/" old)
106 (file-exists? old)
107 (with-directory-excursion (dirname new*)
108 (file-exists? old)))
109 (error (format #f "symlink `~a' points to nonexistent \
110file `~a'" new* old))))
111 (symlink old new*))
112 (lambda args
113 ;; When doing 'guix system init' on the current '/', some
114 ;; symlinks may already exists. Override them.
115 (if (= EEXIST (system-error-errno args))
116 (begin
117 (delete-file new*)
118 (try))
119 (apply throw args)))))))))
120 (lambda args
121 ;; Usually we can only get here when installing to an existing root,
122 ;; as with 'guix system init foo.scm /'.
123 (format (current-error-port)
124 "error: failed to evaluate directive: ~s~%"
125 directive)
126 (apply throw args)))))
127
128(define (directives store)
129 "Return a list of directives to populate the root file system that will host
130STORE."
131 `((directory ,store 0 0 #o1775)
132
133 (directory "/etc")
134 (directory "/var/log") ; for shepherd
135 (directory "/var/guix/gcroots")
136 (directory "/var/empty") ; for no-login accounts
137 (directory "/var/db") ; for dhcpcd, etc.
138 (directory "/mnt")
139 (directory "/var/guix/profiles/per-user/root" 0 0)
140
141 ;; Link to the initial system generation.
142 ("/var/guix/profiles/system" -> "system-1-link")
143
144 ("/var/guix/gcroots/booted-system" -> "/run/booted-system")
145 ("/var/guix/gcroots/current-system" -> "/run/current-system")
146 ("/var/guix/gcroots/profiles" -> "/var/guix/profiles")
147
148 (directory "/bin")
149 (directory "/tmp" 0 0 #o1777) ; sticky bit
150 (directory "/var/tmp" 0 0 #o1777)
151 (directory "/var/lock" 0 0 #o1777)
152
153 (directory "/home" 0 0)))
154
155(define* (populate-root-file-system system target
156 #:key (extras '()))
157 "Make the essential non-store files and directories on TARGET. This
158includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM.
159EXTRAS is a list of directives appended to the built-in directives to populate
160TARGET."
161 ;; It's expected that some symbolic link targets do not exist yet, so do not
162 ;; error on dangling links.
163 (for-each (cut evaluate-populate-directive <> target
164 #:error-on-dangling-symlink? #f)
165 (append (directives (%store-directory)) extras))
166
167 ;; Add system generation 1.
168 (let ((generation-1 (string-append target
169 "/var/guix/profiles/system-1-link")))
170 (let try ()
171 (catch 'system-error
172 (lambda ()
173 (symlink system generation-1))
174 (lambda args
175 ;; If GENERATION-1 already exists, overwrite it.
176 (if (= EEXIST (system-error-errno args))
177 (begin
178 (delete-file generation-1)
179 (try))
180 (apply throw args)))))))
181
182(define %root-profile
183 "/var/guix/profiles/per-user/root")
184
185(define* (install-database-and-gc-roots root database profile
186 #:key (profile-name "guix-profile"))
187 "Install DATABASE, the store database, under directory ROOT. Create
188PROFILE-NAME and have it link to PROFILE, a store item."
189 (define (scope file)
190 (string-append root "/" file))
191
192 (define (mkdir-p* dir)
193 (mkdir-p (scope dir)))
194
195 (define (symlink* old new)
196 (symlink old (scope new)))
197
198 (install-file database (scope "/var/guix/db/"))
199 (chmod (scope "/var/guix/db/db.sqlite") #o644)
200 (mkdir-p* "/var/guix/profiles")
201 (mkdir-p* "/var/guix/gcroots")
202 (symlink* "/var/guix/profiles" "/var/guix/gcroots/profiles")
203
204 ;; Make root's profile, which makes it a GC root.
205 (mkdir-p* %root-profile)
206 (symlink* profile
207 (string-append %root-profile "/" profile-name "-1-link"))
208 (symlink* (string-append profile-name "-1-link")
209 (string-append %root-profile "/" profile-name)))
210
211(define* (populate-single-profile-directory directory
212 #:key profile closure
213 (profile-name "guix-profile")
214 database)
215 "Populate DIRECTORY with a store containing PROFILE, whose closure is given
216in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY
217is initialized to contain a single profile under /root pointing to PROFILE.
218
219When DATABASE is true, copy it to DIRECTORY/var/guix/db and create
220DIRECTORY/var/guix/gcroots and friends.
221
222PROFILE-NAME is the name of the profile being created under
223/var/guix/profiles, typically either \"guix-profile\" or \"current-guix\".
224
225This is used to create the self-contained tarballs with 'guix pack'."
226 (define (scope file)
227 (string-append directory "/" file))
228
229 (define (mkdir-p* dir)
230 (mkdir-p (scope dir)))
231
232 (define (symlink* old new)
233 (symlink old (scope new)))
234
235 ;; Populate the store.
236 (populate-store (list closure) directory
237 #:deduplicate? #f)
238
239 (when database
240 (install-database-and-gc-roots directory database profile
241 #:profile-name profile-name))
242
243 (match profile-name
244 ("guix-profile"
245 (mkdir-p* "/root")
246 (symlink* (string-append %root-profile "/guix-profile")
247 "/root/.guix-profile"))
248 ("current-guix"
249 (mkdir-p* "/root/.config/guix")
250 (symlink* (string-append %root-profile "/current-guix")
251 "/root/.config/guix/current"))
252 (_
253 #t)))
254
255(define (mount-cow-store target backing-directory)
256 "Make the store copy-on-write, using TARGET as the backing store. This is
257useful when TARGET is on a hard disk, whereas the current store is on a RAM
258disk."
259 (define (set-store-permissions directory)
260 "Set the right perms on DIRECTORY to use it as the store."
261 (chown directory 0 30000) ;use the fixed 'guixbuild' GID
262 (chmod directory #o1775))
263
264 (let ((tmpdir (string-append target "/tmp")))
265 (mkdir-p tmpdir)
266 (mount tmpdir "/tmp" "none" MS_BIND))
267
268 (let* ((rw-dir (string-append target backing-directory))
269 (work-dir (string-append rw-dir "/../.overlayfs-workdir")))
270 (mkdir-p rw-dir)
271 (mkdir-p work-dir)
272 (mkdir-p "/.rw-store")
273 (set-store-permissions rw-dir)
274 (set-store-permissions "/.rw-store")
275
276 ;; Mount the overlay, then atomically make it the store.
277 (mount "none" "/.rw-store" "overlay" 0
278 (string-append "lowerdir=" (%store-directory) ","
279 "upperdir=" rw-dir ","
280 "workdir=" work-dir))
281 (mount "/.rw-store" (%store-directory) "" MS_MOVE)
282 (rmdir "/.rw-store")))
283
284(define (umount* directory)
285 "Unmount DIRECTORY, but retry a few times upon EBUSY."
286 (let loop ((attempts 5))
287 (catch 'system-error
288 (lambda ()
289 (umount directory))
290 (lambda args
291 (if (and (= EBUSY (system-error-errno args))
292 (> attempts 0))
293 (begin
294 (sleep 1)
295 (loop (- attempts 1)))
296 (apply throw args))))))
297
298(define (unmount-cow-store target backing-directory)
299 "Unmount copy-on-write store."
300 (let ((tmp-dir "/remove"))
301 (mkdir-p tmp-dir)
302 (mount (%store-directory) tmp-dir "" MS_MOVE)
303
304 ;; We might get EBUSY at this point, possibly because of lingering
305 ;; processes with open file descriptors. Use 'umount*' to retry upon
306 ;; EBUSY, leaving a bit of time. See <https://issues.guix.gnu.org/59884>.
307 (umount* tmp-dir)
308
309 (rmdir tmp-dir)
310 (delete-file-recursively
311 (string-append target backing-directory))))
312
313;;; install.scm ends here