Commit | Line | Data |
---|---|---|
b37c5441 JN |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> | |
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\". | |
41 | Return 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 #:optional (root "/")) | |
78 | "Make some of the nodes needed on GNU/Hurd." | |
79 | (define (scope dir) | |
80 | (string-append root (if (string-suffix? "/" root) "" "/") dir)) | |
81 | ||
82 | (mkdir (scope "dev")) | |
951847ee JN |
83 | ;; Don't create /dev/null etc just yet; the store |
84 | ;; messes-up the permission bits. | |
b37c5441 JN |
85 | ;; Don't create /dev/console, /dev/vcs, etc.: they are created by |
86 | ;; console-run on first boot. | |
87 | ||
88 | (mkdir (scope "servers")) | |
89 | (for-each (lambda (file) | |
90 | (call-with-output-file (scope (string-append "servers/" file)) | |
91 | (lambda (port) | |
92 | (display file port) ;avoid hard-linking | |
93 | (chmod port #o444)))) | |
94 | '("startup" | |
95 | "exec" | |
96 | "proc" | |
97 | "password" | |
98 | "default-pager" | |
99 | "crash-dump-core" | |
100 | "kill" | |
101 | "suspend")) | |
102 | ||
103 | (mkdir (scope "servers/socket")) | |
104 | ;; Don't create /servers/socket/1 & co: runsystem does that on first boot. | |
105 | ||
106 | ;; TODO: Set the 'gnu.translator' extended attribute for passive translator | |
107 | ;; settings? | |
108 | ) | |
109 | ||
951847ee JN |
110 | (define (passive-translator-xattr? file-name) |
111 | "Return true if FILE-NAME has an extended @code{gnu.translator} attribute | |
112 | set." | |
113 | (catch 'system-error | |
114 | (lambda _ (not (string-null? (getxattr file-name "gnu.translator")))) | |
115 | (lambda args | |
116 | (if (= ENODATA (system-error-errno args)) | |
117 | #f | |
118 | (apply throw args))))) | |
119 | ||
120 | (define (passive-translator-installed? file-name) | |
121 | "Return true if @file{showtrans} finds a translator installed on FILE-NAME." | |
122 | (with-output-to-port (%make-void-port "w") | |
123 | (lambda _ | |
124 | (with-error-to-port (%make-void-port "w") | |
125 | (lambda _ | |
126 | (zero? (system* "showtrans" "--silent" file-name))))))) | |
127 | ||
128 | (define (translated? file-name) | |
129 | "Return true if a translator is installed on FILE-NAME." | |
130 | (if (string-contains %host-type "linux-gnu") | |
131 | (passive-translator-xattr? file-name) | |
132 | (passive-translator-installed? file-name))) | |
133 | ||
134 | (define* (set-translator file-name command #:optional (mode #o600)) | |
135 | "Setup translator COMMAND on FILE-NAME." | |
136 | (unless (translated? file-name) | |
137 | (let ((dir (dirname file-name))) | |
138 | (unless (directory-exists? dir) | |
139 | (mkdir-p dir)) | |
140 | (unless (file-exists? file-name) | |
141 | (call-with-output-file file-name | |
142 | (lambda (port) | |
143 | (display file-name port) ;avoid hard-linking | |
144 | (chmod port mode))))) | |
145 | (catch 'system-error | |
146 | (lambda _ | |
f25e8f76 | 147 | (setxattr file-name "gnu.translator" (string-join command "\0" 'suffix))) |
951847ee JN |
148 | (lambda (key . args) |
149 | (let ((errno (system-error-errno (cons key args)))) | |
150 | (format (current-error-port) "~a: ~a\n" | |
151 | (strerror errno) file-name) | |
152 | (format (current-error-port) "Ignoring...Good Luck!\n")))))) | |
153 | ||
154 | (define-syntax-rule (false-if-EEXIST exp) | |
155 | "Evaluate EXP but return #f if it raises to 'system-error with EEXIST." | |
156 | (catch 'system-error | |
157 | (lambda () exp) | |
158 | (lambda args | |
159 | (if (= EEXIST (system-error-errno args)) | |
160 | #f | |
161 | (apply throw args))))) | |
162 | ||
163 | (define* (set-hurd-device-translators #:optional (root "/")) | |
164 | "Make some of the device nodes needed on GNU/Hurd." | |
165 | ||
166 | (define (scope dir) | |
167 | (string-append root (if (string-suffix? "/" root) "" "/") dir)) | |
168 | ||
169 | (define scope-set-translator | |
170 | (match-lambda | |
171 | ((file-name command) | |
172 | (scope-set-translator (list file-name command #o600))) | |
173 | ((file-name command mode) | |
174 | (let ((mount-point (scope file-name))) | |
175 | (set-translator mount-point command mode))))) | |
176 | ||
177 | (define (mkdir* dir) | |
178 | (let ((dir (scope dir))) | |
179 | (unless (file-exists? dir) | |
180 | (mkdir-p dir)))) | |
181 | ||
182 | (define servers | |
183 | '(("servers/crash-dump-core" ("/hurd/crash" "--dump-core")) | |
184 | ("servers/crash-kill" ("/hurd/crash" "--kill")) | |
185 | ("servers/crash-suspend" ("/hurd/crash" "--suspend")) | |
186 | ("servers/password" ("/hurd/password")) | |
187 | ("servers/socket/1" ("/hurd/pflocal")) | |
188 | ("servers/socket/2" ("/hurd/pfinet" | |
189 | "--interface" "eth0" | |
190 | "--address" | |
191 | "10.0.2.15" ;the default QEMU guest IP | |
192 | "--netmask" "255.255.255.0" | |
193 | "--gateway" "10.0.2.2" | |
65d95e5d JN |
194 | "--ipv6" "/servers/socket/16")) |
195 | ("proc" ("/hurd/procfs" "--stat-mode=444")))) | |
951847ee JN |
196 | |
197 | (define devices | |
198 | '(("dev/full" ("/hurd/null" "--full") #o666) | |
199 | ("dev/null" ("/hurd/null") #o666) | |
200 | ("dev/random" ("/hurd/random" "--seed-file" "/var/lib/random-seed") | |
201 | #o644) | |
202 | ("dev/zero" ("/hurd/storeio" "--store-type=zero") #o666) | |
203 | ||
204 | ("dev/console" ("/hurd/term" "/dev/console" "device" "console")) | |
205 | ||
206 | ("dev/klog" ("/hurd/streamio" "kmsg")) | |
207 | ("dev/mem" ("/hurd/storeio" "--no-cache" "mem") #o660) | |
208 | ("dev/shm" ("/hurd/tmpfs" "--mode=1777" "50%") #o644) | |
209 | ("dev/time" ("/hurd/storeio" "--no-cache" "time") #o644) | |
210 | ||
211 | ("dev/vcs" ("/hurd/console")) | |
212 | ("dev/tty" ("/hurd/magic" "tty") #o666) | |
213 | ||
57a7aa1a LC |
214 | ;; 'fd_to_filename' in libc expects it. |
215 | ("dev/fd" ("/hurd/magic" "--directory" "fd") #o555) | |
216 | ||
951847ee JN |
217 | ("dev/tty1" ("/hurd/term" "/dev/tty1" "hurdio" "/dev/vcs/1/console") |
218 | #o666) | |
219 | ("dev/tty2" ("/hurd/term" "/dev/tty2" "hurdio" "/dev/vcs/2/console") | |
220 | #o666) | |
221 | ("dev/tty3" ("/hurd/term" "/dev/tty3" "hurdio" "/dev/vcs/3/console") | |
222 | #o666) | |
223 | ||
224 | ("dev/ptyp0" ("/hurd/term" "/dev/ptyp0" "pty-master" "/dev/ttyp0") | |
225 | #o666) | |
226 | ("dev/ptyp1" ("/hurd/term" "/dev/ptyp1" "pty-master" "/dev/ttyp1") | |
227 | #o666) | |
228 | ("dev/ptyp2" ("/hurd/term" "/dev/ptyp2" "pty-master" "/dev/ttyp2") | |
229 | #o666) | |
230 | ||
231 | ("dev/ttyp0" ("/hurd/term" "/dev/ttyp0" "pty-slave" "/dev/ptyp0") | |
232 | #o666) | |
233 | ("dev/ttyp1" ("/hurd/term" "/dev/ttyp1" "pty-slave" "/dev/ptyp1") | |
234 | #o666) | |
235 | ("dev/ttyp2" ("/hurd/term" "/dev/ttyp2" "pty-slave" "/dev/ptyp2") | |
236 | #o666))) | |
237 | ||
238 | (for-each scope-set-translator servers) | |
db08a0d2 JN |
239 | (mkdir* "dev/vcs/1") |
240 | (mkdir* "dev/vcs/2") | |
241 | (mkdir* "dev/vcs/2") | |
242 | (rename-file (scope "dev/console") (scope "dev/console-")) | |
951847ee JN |
243 | (for-each scope-set-translator devices) |
244 | ||
245 | (false-if-EEXIST (symlink "/dev/random" (scope "dev/urandom"))) | |
951847ee JN |
246 | (false-if-EEXIST (symlink "/dev/fd/0" (scope "dev/stdin"))) |
247 | (false-if-EEXIST (symlink "/dev/fd/1" (scope "dev/stdout"))) | |
65d95e5d | 248 | (false-if-EEXIST (symlink "/dev/fd/2" (scope "dev/stderr"))) |
44e65a75 | 249 | (false-if-EEXIST (symlink "crash-dump-core" (scope "servers/crash"))) |
65d95e5d JN |
250 | |
251 | ;; Make sure /etc/mtab is a symlink to /proc/mounts. | |
252 | (false-if-exception (delete-file (scope "etc/mtab"))) | |
253 | (mkdir* (scope "etc")) | |
254 | (symlink "/proc/mounts" (scope "etc/mtab"))) | |
951847ee | 255 | |
b37c5441 JN |
256 | \f |
257 | (define* (boot-hurd-system #:key (on-error 'debug)) | |
258 | "This procedure is meant to be called from an early RC script. | |
259 | ||
260 | Install the relevant passive translators on the first boot. Then, run system | |
261 | activation by using the kernel command-line options '--system' and '--load'; | |
262 | starting the Shepherd. | |
263 | ||
264 | XXX TODO: see linux-boot.scm:boot-system. | |
265 | XXX TODO: add proper file-system checking, mounting | |
266 | XXX TODO: move bits to (new?) (hurd?) (activation?) services | |
951847ee | 267 | XXX TODO: use Linux xattr/setxattr to remove (settrans in) /libexec/RUNSYSTEM |
b37c5441 JN |
268 | |
269 | " | |
b37c5441 JN |
270 | |
271 | (display "Welcome, this is GNU's early boot Guile.\n") | |
272 | (display "Use '--repl' for an initrd REPL.\n\n") | |
273 | ||
274 | (call-with-error-handling | |
275 | (lambda () | |
276 | ||
b37c5441 JN |
277 | (let* ((args (command-line)) |
278 | (system (find-long-option "--system" args)) | |
279 | (to-load (find-long-option "--load" args))) | |
280 | ||
951847ee JN |
281 | (format #t "Setting-up essential translators...\n") |
282 | (setenv "PATH" (string-append system "/profile/bin")) | |
283 | (set-hurd-device-translators) | |
68d8c094 | 284 | |
b37c5441 JN |
285 | (false-if-exception (delete-file "/hurd")) |
286 | (let ((hurd/hurd (readlink* (string-append system "/profile/hurd")))) | |
287 | (symlink hurd/hurd "/hurd")) | |
288 | ||
289 | (format #t "Starting pager...\n") | |
290 | (unless (zero? (system* "/hurd/mach-defpager")) | |
291 | (format #t "FAILED...Good luck!\n")) | |
292 | ||
293 | (cond ((member "--repl" args) | |
294 | (format #t "Starting repl...\n") | |
295 | (start-repl)) | |
296 | (to-load | |
297 | (format #t "loading '~a'...\n" to-load) | |
298 | (primitive-load to-load) | |
299 | (format (current-error-port) | |
300 | "boot program '~a' terminated, rebooting~%" | |
301 | to-load) | |
302 | (sleep 2) | |
303 | (reboot)) | |
304 | (else | |
305 | (display "no boot file passed via '--load'\n") | |
306 | (display "entering a warm and cozy REPL\n") | |
307 | (start-repl))))) | |
308 | #:on-error on-error)) | |
309 | ||
310 | ;;; hurd-boot.scm ends here |