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>
5 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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
34 ;;; Utility procedures useful to boot a Hurd system.
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 <>)
46 (substring arg (+ 1 (string-index arg #\=)))))))
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)
53 (let loop ((file file)
55 (define (absolute target)
56 (if (absolute-file-name? target)
58 (string-append (dirname file) "/" target)))
60 (if (>= depth %max-symlink-depth)
66 (values #t (readlink file)))
68 (let ((errno (system-error-errno args)))
69 (if (or (= errno EINVAL))
71 (apply throw args))))))
72 (lambda (success? target)
74 (loop (absolute target) (+ depth 1))
77 (define* (make-hurd-device-nodes #:optional (root "/"))
78 "Make some of the nodes needed on GNU/Hurd."
80 (string-append root (if (string-suffix? "/" root) "" "/") dir))
83 (for-each (lambda (file)
84 (call-with-output-file (scope file)
86 (display file port) ;avoid hard-linking
93 ;; Don't create /dev/console, /dev/vcs, etc.: they are created by
94 ;; console-run on first boot.
96 (mkdir (scope "servers"))
97 (for-each (lambda (file)
98 (call-with-output-file (scope (string-append "servers/" file))
100 (display file port) ;avoid hard-linking
101 (chmod port #o444))))
111 (mkdir (scope "servers/socket"))
112 ;; Don't create /servers/socket/1 & co: runsystem does that on first boot.
114 ;; TODO: Set the 'gnu.translator' extended attribute for passive translator
119 (define* (boot-hurd-system #:key (on-error 'debug))
120 "This procedure is meant to be called from an early RC script.
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.
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
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"))))
144 (display "Welcome, this is GNU's early boot Guile.\n")
145 (display "Use '--repl' for an initrd REPL.\n\n")
147 (call-with-error-handling
150 (define (translated? node)
151 ;; Return true if a translator is installed on NODE.
152 (with-output-to-port (%make-void-port "w")
154 (with-error-to-port (%make-void-port "w")
156 (zero? (system* "showtrans" "--silent" node)))))))
158 (let* ((args (command-line))
159 (system (find-long-option "--system" args))
160 (to-load (find-long-option "--load" args)))
162 (format #t "Creating essential servers...\n")
163 (setenv "PATH" (string-append system "/profile/bin"
164 ":" system "/profile/sbin"))
165 (for-each (match-lambda
167 (unless (translated? node)
168 (mkdir-p (dirname node))
169 (apply invoke "settrans" "--create" node command))))
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"))
180 (false-if-exception (delete-file "/hurd"))
181 (let ((hurd/hurd (readlink* (string-append system "/profile/hurd"))))
182 (symlink hurd/hurd "/hurd"))
184 (format #t "Starting pager...\n")
185 (unless (zero? (system* "/hurd/mach-defpager"))
186 (format #t "FAILED...Good luck!\n"))
188 (cond ((member "--repl" args)
189 (format #t "Starting repl...\n")
192 (format #t "loading '~a'...\n" to-load)
193 (primitive-load to-load)
194 (format (current-error-port)
195 "boot program '~a' terminated, rebooting~%"
200 (display "no boot file passed via '--load'\n")
201 (display "entering a warm and cozy REPL\n")
203 #:on-error on-error))
205 ;;; hurd-boot.scm ends here