projects/guix·blob java-team · refs

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