projects/guix·blob python-team · refs

253 lines · 10.7 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2018, 2020 Mathieu Othacehe <[email protected]>
3;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <[email protected]>
4;;; Copyright © 2024,2026 Janneke Nieuwenhuizen <[email protected]>
5;;;
6;;; This file is part of GNU Guix.
7;;;
8;;; GNU Guix is free software; you can redistribute it and/or modify it
9;;; under the terms of the GNU General Public License as published by
10;;; the Free Software Foundation; either version 3 of the License, or (at
11;;; your option) any later version.
12;;;
13;;; GNU Guix is distributed in the hope that it will be useful, but
14;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;;; GNU General Public License for more details.
17;;;
18;;; You should have received a copy of the GNU General Public License
19;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20
21(define-module (gnu installer final)
22 #:use-module (gnu installer newt page)
23 #:use-module (gnu installer steps)
24 #:use-module (gnu installer utils)
25 #:use-module (gnu installer user)
26 #:use-module (gnu services herd)
27 #:use-module (guix build syscalls)
28 #:use-module (guix build utils)
29 #:use-module (guix utils)
30 #:use-module (gnu build accounts)
31 #:use-module (gnu build install)
32 #:use-module (gnu build linux-container)
33 #:use-module ((gnu system shadow) #:prefix sys:)
34 #:use-module (rnrs io ports)
35 #:use-module (srfi srfi-1)
36 #:use-module (ice-9 ftw)
37 #:use-module (ice-9 popen)
38 #:use-module (ice-9 match)
39 #:use-module (ice-9 format)
40 #:use-module (ice-9 rdelim)
41 #:export (install-system))
42
43(define %seed
44 (seed->random-state
45 (logxor (getpid) (car (gettimeofday)))))
46
47(define (integer->alphanumeric-char n)
48 "Map N, an integer in the [0..62] range, to an alphanumeric character."
49 (cond ((< n 10)
50 (integer->char (+ (char->integer #\0) n)))
51 ((< n 36)
52 (integer->char (+ (char->integer #\A) (- n 10))))
53 ((< n 62)
54 (integer->char (+ (char->integer #\a) (- n 36))))
55 (else
56 (error "integer out of bounds" n))))
57
58(define (random-string len)
59 "Compute a random string of size LEN where each character is alphanumeric."
60 (let loop ((chars '())
61 (len len))
62 (if (zero? len)
63 (list->string chars)
64 (let ((n (random 62 %seed)))
65 (loop (cons (integer->alphanumeric-char n) chars)
66 (- len 1))))))
67
68(define (create-user-database users root)
69 "Create /etc/passwd, /etc/shadow, and /etc/group under ROOT for the given
70USERS."
71 (define etc
72 (string-append root "/etc"))
73
74 (define (salt)
75 ;; "$6" gives us a SHA512 password hash; the random string must be taken
76 ;; from the './0-9A-Za-z' alphabet (info "(libc) Passphrase Storage").
77 (string-append "$6$" (random-string 10)))
78
79 (define users*
80 (map (lambda (user)
81 (define root?
82 (string=? "root" (user-name user)))
83
84 (sys:user-account (name (user-name user))
85 (comment (user-real-name user))
86 (group "users")
87 (uid (if root? 0 #f))
88 (home-directory
89 (user-home-directory user))
90 (password (crypt
91 (secret-content (user-password user))
92 (salt)))
93
94 ;; We need a string here, not a file-like, hence
95 ;; this choice.
96 (shell
97 "/run/current-system/profile/bin/bash")))
98 users))
99
100 (define-values (group password shadow)
101 (user+group-databases users* sys:%base-groups
102 #:current-passwd '()
103 #:current-groups '()
104 #:current-shadow '()))
105
106 (mkdir-p etc)
107 (write-group group (string-append etc "/group"))
108 (write-passwd password (string-append etc "/passwd"))
109 (write-shadow shadow (string-append etc "/shadow")))
110
111(define (call-with-mnt-container thunk)
112 "This is a variant of call-with-container. Run THUNK in a new container
113process, within a separate MNT namespace. The container is not jailed so that
114it can interact with the rest of the system."
115 (let ((pid (run-container "/" '() '(mnt) 1 thunk)))
116 ;; Catch SIGINT and kill the container process.
117 (sigaction SIGINT
118 (lambda (signum)
119 ;: FIXME: Use of SIGKILL prevents the dynamic-wind exit handler of
120 ;; THUNK to run.
121 (false-if-exception
122 (kill pid SIGKILL))))
123
124 (match (waitpid pid)
125 ((_ . status) status))))
126
127(define (install-locale locale)
128 "Install the given LOCALE or the en_US.utf8 locale as a fallback."
129 (let ((supported? (false-if-exception
130 (setlocale LC_ALL locale))))
131 (if supported?
132 (begin
133 (installer-log-line "install supported locale ~a." locale)
134 (setenv "LC_ALL" locale))
135 (begin
136 ;; If the selected locale is not supported, install a default UTF-8
137 ;; locale. This is required to copy some files with UTF-8
138 ;; characters, in the nss-certs package notably. Set LANGUAGE
139 ;; anyways, to have translated messages if possible.
140 (installer-log-line "~a locale is not supported, installing \
141en_US.utf8 locale instead." locale)
142 (setlocale LC_ALL "en_US.utf8")
143 (setenv "LC_ALL" "en_US.utf8")
144 (setenv "LANGUAGE"
145 (string-take locale
146 (or (string-index locale #\_)
147 (string-length locale))))))))
148
149(define* (install-system locale #:key (users '()))
150 "Create /etc/shadow and /etc/passwd on the installation target for USERS.
151Start COW-STORE service on target directory and launch guix install command in
152a subshell. LOCALE must be the locale name under which that command will run,
153or #f. Return #t on success and #f on failure."
154 (define backing-directory
155 ;; Sub-directory used as the backing store for copy-on-write.
156 "/tmp/guix-inst")
157
158 (define (assert-exit x)
159 (primitive-exit (if x 0 1)))
160
161 (let* ((options (catch 'system-error
162 (lambda ()
163 ;; If this file exists, it can provide
164 ;; additional command-line options.
165 (call-with-input-file
166 "/tmp/installer-system-init-options"
167 read))
168 (const '())))
169 (install-command (append `( "guix" "system" "init"
170 "--fallback"
171 ,@(if (%current-target-system)
172 `(,(string-append
173 "--target="
174 (%current-target-system)))
175 '()))
176 options
177 (list (%installer-configuration-file)
178 (%installer-target-dir))))
179 (database-dir "/var/guix/db")
180 (database-file (string-append database-dir "/db.sqlite"))
181 (saved-database (string-append database-dir "/db.save"))
182 (ret #f))
183 (mkdir-p (%installer-target-dir))
184
185 ;; We want to initialize user passwords but we don't want to store them in
186 ;; the config file since the password hashes would end up world-readable
187 ;; in the store. Thus, create /etc/shadow & co. here such that, on the
188 ;; first boot, the activation snippet that creates accounts will reuse the
189 ;; passwords that we've put in there.
190 (create-user-database users (%installer-target-dir))
191
192 ;; When the store overlay is mounted, other processes such as kmscon, udev
193 ;; and guix-daemon may open files from the store, preventing the
194 ;; underlying install support from being umounted. See:
195 ;; https://lists.gnu.org/archive/html/guix-devel/2018-12/msg00161.html.
196 ;;
197 ;; To avoid this situation, mount the store overlay inside a container,
198 ;; and run the installation from within that container.
199 (zero?
200 (call-with-mnt-container
201 (lambda ()
202 (dynamic-wind
203 (lambda ()
204 ;; Install the locale before mounting the cow-store, otherwise
205 ;; the loaded cow-store locale files will prevent umounting.
206 (install-locale locale)
207
208 ;; Stop the daemon and save the database, so that it can be
209 ;; restored once the cow-store is umounted.
210 (stop-service 'guix-daemon)
211 (copy-file database-file saved-database)
212
213 (installer-log-line "mounting copy-on-write store")
214 (mount-cow-store (%installer-target-dir) backing-directory))
215 (lambda ()
216 ;; We need to drag the guix-daemon to the container MNT
217 ;; namespace, so that it can operate on the cow-store.
218 (start-service 'guix-daemon (list (number->string (getpid))))
219
220 (setvbuf (current-output-port) 'none)
221 (setvbuf (current-error-port) 'none)
222
223 (setenv "PATH" "/run/current-system/profile/bin/")
224
225 (for-each (lambda (line)
226 (installer-log-line "~a" line))
227 (with-input-from-file (%installer-configuration-file)
228 read-lines))
229
230 (set! ret (run-command install-command #:tty? #t)))
231 (lambda ()
232 ;; Stop guix-daemon so that it does no keep the MNT namespace
233 ;; alive.
234 (stop-service 'guix-daemon)
235
236 ;; Restore the database and restart it. As part of restoring the
237 ;; database, remove the WAL and shm files in case they were left
238 ;; behind after guix-daemon was stopped. Failing to do so,
239 ;; sqlite might behave as if transactions that appear in the WAL
240 ;; file were committed. (See <https://www.sqlite.org/wal.html>.)
241 (installer-log-line "restoring store database from '~a'"
242 saved-database)
243 (copy-file saved-database database-file)
244 (for-each (lambda (suffix)
245 (false-if-exception
246 (delete-file (string-append database-file suffix))))
247 '("-wal" "-shm"))
248 (start-service 'guix-daemon)
249
250 ;; Finally umount the cow-store and exit the container.
251 (installer-log-line "unmounting copy-on-write store")
252 (unmount-cow-store (%installer-target-dir) backing-directory)
253 (assert-exit ret))))))))