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")) | |
83 | (for-each (lambda (file) | |
84 | (call-with-output-file (scope file) | |
85 | (lambda (port) | |
86 | (display file port) ;avoid hard-linking | |
87 | (chmod port #o666)))) | |
88 | '("dev/null" | |
89 | "dev/zero" | |
90 | "dev/full" | |
91 | "dev/random" | |
92 | "dev/urandom")) | |
93 | ;; Don't create /dev/console, /dev/vcs, etc.: they are created by | |
94 | ;; console-run on first boot. | |
95 | ||
96 | (mkdir (scope "servers")) | |
97 | (for-each (lambda (file) | |
98 | (call-with-output-file (scope (string-append "servers/" file)) | |
99 | (lambda (port) | |
100 | (display file port) ;avoid hard-linking | |
101 | (chmod port #o444)))) | |
102 | '("startup" | |
103 | "exec" | |
104 | "proc" | |
105 | "password" | |
106 | "default-pager" | |
107 | "crash-dump-core" | |
108 | "kill" | |
109 | "suspend")) | |
110 | ||
111 | (mkdir (scope "servers/socket")) | |
112 | ;; Don't create /servers/socket/1 & co: runsystem does that on first boot. | |
113 | ||
114 | ;; TODO: Set the 'gnu.translator' extended attribute for passive translator | |
115 | ;; settings? | |
116 | ) | |
117 | ||
118 | \f | |
119 | (define* (boot-hurd-system #:key (on-error 'debug)) | |
120 | "This procedure is meant to be called from an early RC script. | |
121 | ||
122 | Install the relevant passive translators on the first boot. Then, run system | |
123 | activation by using the kernel command-line options '--system' and '--load'; | |
124 | starting the Shepherd. | |
125 | ||
126 | XXX TODO: see linux-boot.scm:boot-system. | |
127 | XXX TODO: add proper file-system checking, mounting | |
128 | XXX TODO: move bits to (new?) (hurd?) (activation?) services | |
129 | XXX TODO: use settrans/setxattr instead of MAKEDEV | |
130 | ||
131 | " | |
132 | (define translators | |
133 | '(("/servers/crash-dump-core" ("/hurd/crash" "--dump-core")) | |
134 | ("/servers/crash-kill" ("/hurd/crash" "--kill")) | |
135 | ("/servers/crash-suspend" ("/hurd/crash" "--suspend")) | |
136 | ("/servers/password" ("/hurd/password")) | |
137 | ("/servers/socket/1" ("/hurd/pflocal")) | |
138 | ("/servers/socket/2" ("/hurd/pfinet" "--interface" "eth0" | |
139 | "--address" "10.0.2.15" ;the default QEMU guest IP | |
140 | "--netmask" "255.255.255.0" | |
141 | "--gateway" "10.0.2.2" | |
142 | "--ipv6" "/servers/socket/16")))) | |
143 | ||
144 | (display "Welcome, this is GNU's early boot Guile.\n") | |
145 | (display "Use '--repl' for an initrd REPL.\n\n") | |
146 | ||
147 | (call-with-error-handling | |
148 | (lambda () | |
149 | ||
150 | (define (translated? node) | |
151 | ;; Return true if a translator is installed on NODE. | |
152 | (with-output-to-port (%make-void-port "w") | |
153 | (lambda () | |
154 | (with-error-to-port (%make-void-port "w") | |
155 | (lambda () | |
68d8c094 | 156 | (zero? (system* "showtrans" "--silent" node))))))) |
b37c5441 JN |
157 | |
158 | (let* ((args (command-line)) | |
159 | (system (find-long-option "--system" args)) | |
160 | (to-load (find-long-option "--load" args))) | |
161 | ||
68d8c094 JN |
162 | (format #t "Creating essential servers...\n") |
163 | (setenv "PATH" (string-append system "/profile/bin" | |
164 | ":" system "/profile/sbin")) | |
165 | (for-each (match-lambda | |
166 | ((node command) | |
167 | (unless (translated? node) | |
168 | (mkdir-p (dirname node)) | |
169 | (apply invoke "settrans" "--create" node command)))) | |
170 | translators) | |
171 | ||
172 | (format #t "Creating essential device nodes...\n") | |
173 | (with-directory-excursion "/dev" | |
174 | (invoke "MAKEDEV" "--devdir=/dev" "std") | |
175 | (invoke "MAKEDEV" "--devdir=/dev" "vcs") | |
176 | (invoke "MAKEDEV" "--devdir=/dev" "tty1""tty2" "tty3" "tty4" "tty5" "tty6") | |
177 | (invoke "MAKEDEV" "--devdir=/dev" "ptyp0" "ptyp1" "ptyp2") | |
178 | (invoke "MAKEDEV" "--devdir=/dev" "console")) | |
179 | ||
b37c5441 JN |
180 | (false-if-exception (delete-file "/hurd")) |
181 | (let ((hurd/hurd (readlink* (string-append system "/profile/hurd")))) | |
182 | (symlink hurd/hurd "/hurd")) | |
183 | ||
184 | (format #t "Starting pager...\n") | |
185 | (unless (zero? (system* "/hurd/mach-defpager")) | |
186 | (format #t "FAILED...Good luck!\n")) | |
187 | ||
188 | (cond ((member "--repl" args) | |
189 | (format #t "Starting repl...\n") | |
190 | (start-repl)) | |
191 | (to-load | |
192 | (format #t "loading '~a'...\n" to-load) | |
193 | (primitive-load to-load) | |
194 | (format (current-error-port) | |
195 | "boot program '~a' terminated, rebooting~%" | |
196 | to-load) | |
197 | (sleep 2) | |
198 | (reboot)) | |
199 | (else | |
200 | (display "no boot file passed via '--load'\n") | |
201 | (display "entering a warm and cozy REPL\n") | |
202 | (start-repl))))) | |
203 | #:on-error on-error)) | |
204 | ||
205 | ;;; hurd-boot.scm ends here |