projects/guix·blob python-team · refs

438 lines · 17.3 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2020-2022 Ludovic Courtès <[email protected]>
3;;; Copyright © 2020, 2023 Janneke Nieuwenhuizen <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20;;; Commentary:
21;;;
22;;; This modules provides tools to deal with disk partitions, and to mount and
23;;; check file systems.
24;;;
25;;; Code:
26
27(define-module (gnu build hurd-boot)
28 #:use-module (system repl error-handling)
29 #:autoload (system repl repl) (start-repl)
30 #:use-module (srfi srfi-1)
31 #:use-module (srfi srfi-26)
32 #:use-module (ice-9 match)
33 #:use-module (guix build utils)
34 #:use-module ((guix build syscalls)
35 #:hide (file-system-type))
36 #:export (make-hurd-device-nodes
37 boot-hurd-system))
38
39;; XXX FIXME c&p from linux-boot.scm
40(define (find-long-option option arguments)
41 "Find OPTION among ARGUMENTS, where OPTION is something like \"--load\".
42Return the value associated with OPTION, or #f on failure."
43 (let ((opt (string-append option "=")))
44 (and=> (find (cut string-prefix? opt <>)
45 arguments)
46 (lambda (arg)
47 (substring arg (+ 1 (string-index arg #\=)))))))
48
49;; XXX FIXME c&p from guix/utils.scm
50(define (readlink* file)
51 "Call 'readlink' until the result is not a symlink."
52 (define %max-symlink-depth 50)
53
54 (let loop ((file file)
55 (depth 0))
56 (define (absolute target)
57 (if (absolute-file-name? target)
58 target
59 (string-append (dirname file) "/" target)))
60
61 (if (>= depth %max-symlink-depth)
62 file
63 (call-with-values
64 (lambda ()
65 (catch 'system-error
66 (lambda ()
67 (values #t (readlink file)))
68 (lambda args
69 (let ((errno (system-error-errno args)))
70 (if (or (= errno EINVAL))
71 (values #f file)
72 (apply throw args))))))
73 (lambda (success? target)
74 (if success?
75 (loop (absolute target) (+ depth 1))
76 file))))))
77
78(define* (make-hurd-device-nodes #:key (root "/") (hurd "/hurd"))
79 "Make some of the nodes needed on GNU/Hurd."
80 (define (scope dir)
81 (in-vicinity root dir))
82
83 (define scope-set-translator
84 (match-lambda
85 ((file-name command)
86 (scope-set-translator (list file-name command #o600)))
87 ((file-name command mode)
88 (let ((mount-point (scope file-name)))
89 (set-translator mount-point command mode)))))
90
91 (mkdir-p (scope "dev"))
92 ;; XXX: We must have `/dev/console` otherwise `console-run` tries to
93 ;; create it while the file-system is still read-only.
94 (for-each (lambda (file)
95 (call-with-output-file (scope file)
96 (lambda (port)
97 (display file port) ;avoid hard-linking
98 (chmod port #o666))))
99 '("dev/console"
100 ;; XXX What about vcs?
101 ;; Don't create /dev/null etc just yet; the store
102 ;; messes-up the permission bits.
103 ;; "dev/null"
104 ;; "dev/zero"
105 ;; "dev/full"
106 ;; "dev/random"
107 ;; "dev/urandom"
108 ))
109
110 (mkdir-p (scope "servers"))
111 (for-each (lambda (file)
112 (call-with-output-file (scope (string-append "servers/" file))
113 (lambda (port)
114 (display file port) ;avoid hard-linking
115 (chmod port #o444))))
116 '("startup"
117 "exec"
118 "proc"
119 "password"
120 "default-pager"
121 "crash-dump-core"
122 "kill"
123 "suspend"))
124
125 (mkdir-p (scope "servers/socket"))
126 (mkdir-p (scope "servers/bus/pci"))
127
128 ;; Set the 'gnu.translator' extended attribute for passive translator
129 ;; settings for pipes (servers/socet/1) and mount information (proc/mounts).
130 ;; Pipes are needed for guile-3.0.11 to startup, this enables moving
131 ;; "runsystem" to guile.
132 ;; XXX TODO: Set more passive xattr translators?
133 (define servers
134 `(
135 ;; ("servers/bus/pci" ("/hurd/pci-arbiter"))
136 ;; ("servers/crash-dump-core" ("/hurd/crash" "--dump-core"))
137 ;; ("servers/crash-kill" ("/hurd/crash" "--kill"))
138 ;; ("servers/crash-suspend" ("/hurd/crash" "--suspend"))
139 ;; ("servers/password" ("/hurd/password"))
140 ;; PIPE -- for running runsystem as Guile
141 ("servers/socket/1" (,(in-vicinity hurd "pflocal")))
142 ;; /servers/socket/2 and /26 are created by 'static-networking-service'.
143 ;; XXX: Spawn pfinet without arguments on these nodes so that a DHCP
144 ;; client has someone to talk to?
145 ("proc" (,(in-vicinity hurd "procfs") "--stat-mode=444"))))
146
147 (for-each scope-set-translator servers)
148
149 (define devices
150 '())
151 (for-each scope-set-translator devices))
152
153(define (passive-translator-xattr? file-name)
154 "Return true if FILE-NAME has an extended @code{gnu.translator} attribute
155set.
156
157Note that reading \"gnu.*\" xattrs on Linux only work with ext4; for tmpfs,
158used during image creation, linux-7.0 with linux-shmem-hurd-xattr patch is
159needed."
160 (and (file-exists? file-name)
161 (catch 'system-error
162 (lambda _ (not (string-null? (getxattr file-name "gnu.translator"))))
163 (lambda args
164 (if (= ENODATA (system-error-errno args))
165 #f
166 (apply throw args))))))
167
168(define (passive-translator-installed? file-name)
169 "Return true if @file{showtrans} finds a translator installed on FILE-NAME."
170 (with-output-to-port (%make-void-port "w")
171 (lambda _
172 (with-error-to-port (%make-void-port "w")
173 (lambda _
174 (zero? (system* "showtrans" "--silent" file-name)))))))
175
176(define (translated? file-name)
177 "Return true if a translator is installed on FILE-NAME."
178 ;; On GNU/Hurd, 'getxattr' in glibc opens the file without O_NOTRANS, and
179 ;; then, for "gnu.translator", it calls 'file_get_translator', resulting in
180 ;; EOPNOTSUPP (conversely, 'showtrans' opens the file with O_NOTRANS).
181 (if (string-contains %host-type "linux-gnu")
182 (passive-translator-xattr? file-name)
183 (passive-translator-installed? file-name)))
184
185(define* (set-translator file-name command #:optional (mode #o600))
186 "Setup translator COMMAND on FILE-NAME.
187
188Note that setting \"gnu.*\" xattrs on Linux only work with ext4; for tmpfs,
189used during image creation, linux-7.0 with linux-shmem-hurd-xattr patch is
190needed."
191 (unless (translated? file-name)
192 (let ((dir (dirname file-name)))
193 (unless (directory-exists? dir)
194 (mkdir-p dir))
195 (unless (file-exists? file-name)
196 (call-with-output-file file-name
197 (lambda (port)
198 (display file-name port) ;avoid hard-linking
199 (chmod port mode)))))
200 (catch 'system-error
201 (lambda _
202 (setxattr file-name "gnu.translator" (string-join command "\0" 'suffix)))
203 (lambda (key . args)
204 (let ((errno (system-error-errno (cons key args))))
205 (format (current-error-port) "~a: ~a\n"
206 (strerror errno) file-name)
207 (format (current-error-port) "Ignoring...Good Luck!\n"))))))
208
209(define-syntax-rule (false-if-EEXIST exp)
210 "Evaluate EXP but return #f if it raises to 'system-error with EEXIST."
211 (catch 'system-error
212 (lambda () exp)
213 (lambda args
214 (if (= EEXIST (system-error-errno args))
215 #f
216 (apply throw args)))))
217
218(define* (set-hurd-device-translators #:optional (root "/"))
219 "Make some of the device nodes needed on GNU/Hurd."
220
221 (define (scope dir)
222 (in-vicinity root dir))
223
224 (define scope-set-translator
225 (match-lambda
226 ((file-name command)
227 (scope-set-translator (list file-name command #o600)))
228 ((file-name command mode)
229 (let ((mount-point (scope file-name)))
230 (set-translator mount-point command mode)))))
231
232 (define (mkdir* dir)
233 (let ((dir (scope dir)))
234 (unless (file-exists? dir)
235 (mkdir-p dir))))
236
237 ;; (define random-seed "/var/lib/random-seed")
238
239 ;; ;; Create seed file to avoid
240 ;; ;; /gnu/store/...-hurd-x.y.z/hurd/random: Warning: Failed to read random seed file /var/lib/random-seed: No such file or directory
241 ;; (let ((file (scope random-seed)))
242 ;; (mkdir-p (dirname file))
243 ;; (call-with-output-file file
244 ;; (lambda (port)
245 ;; (display (iota 1000) port)
246 ;; (chmod port #o600))))
247
248 (define servers
249 '(("servers/bus/pci" ("/hurd/pci-arbiter"))
250 ("servers/crash-dump-core" ("/hurd/crash" "--dump-core"))
251 ("servers/crash-kill" ("/hurd/crash" "--kill"))
252 ("servers/crash-suspend" ("/hurd/crash" "--suspend"))
253 ("servers/password" ("/hurd/password"))
254 ("servers/socket/1" ("/hurd/pflocal"))
255 ;; /servers/socket/2 and /26 are created by 'static-networking-service'.
256 ;; XXX: Spawn pfinet without arguments on these nodes so that a DHCP
257 ;; client has someone to talk to?
258 ("proc" ("/hurd/procfs" "--stat-mode=444"))))
259
260 (define devices
261 `(("dev/full" ("/hurd/null" "--full") #o666)
262 ("dev/null" ("/hurd/null") #o666)
263 ;; The random translators, especially /dev/urandom, need to be non-passive
264 ;; When they exist in the file-system and reference /var/lib/random-seed
265 ;; while / is read-only. console-run will hang.
266 ;; ("dev/random" ("/hurd/random" "--seed-file" ,random-seed)
267 ;; #o644)
268 ;; ("dev/urandom" ("/hurd/random" "--seed-file" ,random-seed
269 ;; "--fast")
270 ;; #o644)
271 ("dev/zero" ("/hurd/storeio" "--store-type=zero") #o666)
272
273 ("dev/console" ("/hurd/term" "/dev/console" "device" "console"))
274
275 ("dev/klog" ("/hurd/streamio" "kmsg"))
276 ("dev/mem" ("/hurd/storeio" "--no-cache" "mem") #o660)
277 ("dev/shm" ("/hurd/tmpfs" "--mode=1777" "50%") #o644)
278 ("dev/time" ("/hurd/storeio" "--no-cache" "time") #o644)
279
280 ("dev/vcs" ("/hurd/console"))
281 ("dev/tty" ("/hurd/magic" "tty") #o666)
282
283 ;; 'fd_to_filename' in libc expects it.
284 ("dev/fd" ("/hurd/magic" "--directory" "fd") #o555)
285
286 ("dev/rumpdisk" ("/hurd/rumpdisk") #o660)
287 ("dev/netdde" ("/hurd/netdde") #o660)
288 ("dev/eth0" ("/hurd/devnode" "--master-device=/dev/net"
289 "eth0")
290 #o660)
291 ("dev/eth1" ("/hurd/devnode" "--master-device=/dev/net"
292 "eth1")
293 #o660)
294
295 ;; Create a number of ttys; syslogd writes to tty12 by default.
296 ;; FIXME: Creating /dev/tty12 leads the console client to switch to
297 ;; tty12 when syslogd starts, which is confusing for users. Thus, do
298 ;; not create tty12.
299 ,@(map (lambda (n)
300 (let ((n (number->string n)))
301 `(,(string-append "dev/tty" n)
302 ("/hurd/term" ,(string-append "/dev/tty" n)
303 "hurdio" ,(string-append "/dev/vcs/" n "/console"))
304 #o666)))
305 (iota 11 1))
306
307 ,@(append-map (lambda (n)
308 (let ((n (number->string n)))
309 `((,(string-append "dev/ptyp" n)
310 ("/hurd/term" ,(string-append "/dev/ptyp" n)
311 "pty-master" ,(string-append "/dev/ttyp" n))
312 #o666)
313
314 (,(string-append "dev/ttyp" n)
315 ("/hurd/term" ,(string-append "/dev/ttyp" n)
316 "pty-slave" ,(string-append "/dev/ptyp" n))
317 #o666))))
318 (iota 10 0))
319 ,@(append-map (lambda (n)
320 (let* ((n (number->string n))
321 (disk (string-append "hd" n))
322 (drive (string-append "dev/" disk)))
323 `((,drive ("/hurd/storeio" ,disk) #o600)
324 ,@(map (lambda (p)
325 (let ((p (number->string p)))
326 `(,(string-append drive "s" p)
327 ("/hurd/storeio"
328 ,(string-append disk "s" p))
329 #o660)))
330 (iota 4 1)))))
331 (iota 4 0))
332 ,@(append-map (lambda (n)
333 (let* ((n (number->string n))
334 (drive (string-append "dev/wd" n))
335 (disk (string-append "@/dev/disk:wd" n)))
336 `((,drive ("/hurd/storeio" ,disk) #o600)
337 ,@(map (lambda (p)
338 (let ((p (number->string p)))
339 `(,(string-append drive "s" p)
340 ("/hurd/storeio"
341 "--store-type=typed"
342 ,(string-append
343 "part:" p ":device:" disk))
344 #o660)))
345 (iota 4 1)))))
346 (iota 4 0))))
347
348 (for-each scope-set-translator servers)
349 (mkdir* "dev/vcs/1")
350 (mkdir* "dev/vcs/2")
351 (when (file-exists? (scope "dev/console"))
352 (rename-file (scope "dev/console") (scope "dev/console-")))
353 (for-each scope-set-translator devices)
354
355 (false-if-EEXIST (symlink "/dev/fd/0" (scope "dev/stdin")))
356 (false-if-EEXIST (symlink "/dev/fd/1" (scope "dev/stdout")))
357 (false-if-EEXIST (symlink "/dev/fd/2" (scope "dev/stderr")))
358 (false-if-EEXIST (symlink "crash-dump-core" (scope "servers/crash")))
359 (false-if-EEXIST (symlink "/dev/rumpdisk" (scope "dev/disk")))
360 (false-if-EEXIST (symlink "/dev/netdde" (scope "dev/net")))
361 (false-if-EEXIST (symlink "/servers/socket/2" (scope "servers/socket/inet")))
362 (false-if-EEXIST (symlink "/servers/socket/26" (scope "servers/socket/inet6")))
363
364 ;; Make sure /var/run/mtab is a symlink to /proc/mounts.
365 (false-if-exception (delete-file (scope "var/run/mtab")))
366 (mkdir* (scope "var/run"))
367 (symlink "/proc/mounts" (scope "var/run/mtab")))
368
369
370(define* (boot-hurd-system #:key (on-error 'debug))
371 "This procedure is meant to be called from an early RC script.
372
373Install the relevant passive translators on the first boot. Then, run system
374activation by using the kernel command-line options 'gnu.system' and 'gnu.load';
375starting the Shepherd.
376
377XXX TODO: see linux-boot.scm:boot-system.
378XXX TODO: add proper file-system checking, mounting
379XXX TODO: move bits to (new?) (hurd?) (activation?) services
380XXX TODO: use Linux xattr/setxattr to remove (settrans in) /libexec/RUNSYSTEM
381
382"
383
384 (display "Welcome, this is GNU's early boot Guile.\n")
385 (display "Use 'gnu.repl' for an initrd REPL.\n\n")
386
387 (call-with-error-handling
388 (lambda ()
389
390 (let* ((args (command-line))
391 (system (find-long-option "gnu.system" args))
392 (to-load (find-long-option "gnu.load" args))
393 (profile (string-append system "/profile"))
394 (bin (string-append profile "/bin"))
395 (sbin (string-append profile "/sbin")))
396
397 (setenv "PATH" (string-append bin ":" sbin))
398
399 (when (file-exists? "/var/run/shepherd/socket")
400 (format #t "Removing stale shepherd socket...\n")
401 (delete-file "/var/run/shepherd/socket"))
402
403 (unless (file-exists? "/servers/startup")
404 (format #t "Creating essential device nodes...\n")
405 (make-hurd-device-nodes))
406
407 (let ((profile/hurd (readlink* (string-append profile "/hurd"))))
408 (when (file-exists? "/hurd")
409 (format #t "Removing stale /hurd link\n")
410 (delete-file "/hurd"))
411 (format #t "Linking /hurd from ~a...\n" profile/hurd)
412 (symlink profile/hurd "/hurd"))
413
414 (format #t "Setting-up essential translators...\n")
415 (set-hurd-device-translators)
416
417 (format #t "Starting pager...\n")
418 (unless (zero? (system* "/hurd/mach-defpager"))
419 (format #t "FAILED...Good luck!\n"))
420
421 (cond ((member "gnu.repl" args)
422 (format #t "Starting repl...\n")
423 (start-repl))
424 (to-load
425 (format #t "loading '~a'...\n" to-load)
426 (primitive-load to-load)
427 (format (current-error-port)
428 "boot program '~a' terminated, rebooting~%"
429 to-load)
430 (sleep 2)
431 (reboot))
432 (else
433 (display "no boot file passed via 'gnu.load'\n")
434 (display "entering a warm and cozy REPL\n")
435 (start-repl)))))
436 #:on-error on-error))
437
438;;; hurd-boot.scm ends here