| 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 | ;; Don't create /dev/null etc just yet; the store |
| 84 | ;; messes-up the permission bits. |
| 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 | |
| 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 _ |
| 147 | (apply invoke "settrans" "--create" file-name command)) |
| 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" |
| 194 | "--ipv6" "/servers/socket/16")))) |
| 195 | |
| 196 | (define devices |
| 197 | '(("dev/full" ("/hurd/null" "--full") #o666) |
| 198 | ("dev/null" ("/hurd/null") #o666) |
| 199 | ("dev/random" ("/hurd/random" "--seed-file" "/var/lib/random-seed") |
| 200 | #o644) |
| 201 | ("dev/zero" ("/hurd/storeio" "--store-type=zero") #o666) |
| 202 | |
| 203 | ("dev/console" ("/hurd/term" "/dev/console" "device" "console")) |
| 204 | |
| 205 | ("dev/klog" ("/hurd/streamio" "kmsg")) |
| 206 | ("dev/mem" ("/hurd/storeio" "--no-cache" "mem") #o660) |
| 207 | ("dev/shm" ("/hurd/tmpfs" "--mode=1777" "50%") #o644) |
| 208 | ("dev/time" ("/hurd/storeio" "--no-cache" "time") #o644) |
| 209 | |
| 210 | ("dev/vcs" ("/hurd/console")) |
| 211 | ("dev/tty" ("/hurd/magic" "tty") #o666) |
| 212 | |
| 213 | ("dev/tty1" ("/hurd/term" "/dev/tty1" "hurdio" "/dev/vcs/1/console") |
| 214 | #o666) |
| 215 | ("dev/tty2" ("/hurd/term" "/dev/tty2" "hurdio" "/dev/vcs/2/console") |
| 216 | #o666) |
| 217 | ("dev/tty3" ("/hurd/term" "/dev/tty3" "hurdio" "/dev/vcs/3/console") |
| 218 | #o666) |
| 219 | |
| 220 | ("dev/ptyp0" ("/hurd/term" "/dev/ptyp0" "pty-master" "/dev/ttyp0") |
| 221 | #o666) |
| 222 | ("dev/ptyp1" ("/hurd/term" "/dev/ptyp1" "pty-master" "/dev/ttyp1") |
| 223 | #o666) |
| 224 | ("dev/ptyp2" ("/hurd/term" "/dev/ptyp2" "pty-master" "/dev/ttyp2") |
| 225 | #o666) |
| 226 | |
| 227 | ("dev/ttyp0" ("/hurd/term" "/dev/ttyp0" "pty-slave" "/dev/ptyp0") |
| 228 | #o666) |
| 229 | ("dev/ttyp1" ("/hurd/term" "/dev/ttyp1" "pty-slave" "/dev/ptyp1") |
| 230 | #o666) |
| 231 | ("dev/ttyp2" ("/hurd/term" "/dev/ttyp2" "pty-slave" "/dev/ptyp2") |
| 232 | #o666))) |
| 233 | |
| 234 | (for-each scope-set-translator servers) |
| 235 | (mkdir* (scope "dev/vcs/1")) |
| 236 | (mkdir* (scope "dev/vcs/2")) |
| 237 | (mkdir* (scope "dev/vcs/2")) |
| 238 | (rename-file (scope "/dev/console") (scope "/dev/console-")) |
| 239 | (for-each scope-set-translator devices) |
| 240 | |
| 241 | (false-if-EEXIST (symlink "/dev/random" (scope "dev/urandom"))) |
| 242 | (mkdir* (scope "dev/fd")) |
| 243 | (false-if-EEXIST (symlink "/dev/fd/0" (scope "dev/stdin"))) |
| 244 | (false-if-EEXIST (symlink "/dev/fd/1" (scope "dev/stdout"))) |
| 245 | (false-if-EEXIST (symlink "/dev/fd/2" (scope "dev/stderr")))) |
| 246 | |
| 247 | \f |
| 248 | (define* (boot-hurd-system #:key (on-error 'debug)) |
| 249 | "This procedure is meant to be called from an early RC script. |
| 250 | |
| 251 | Install the relevant passive translators on the first boot. Then, run system |
| 252 | activation by using the kernel command-line options '--system' and '--load'; |
| 253 | starting the Shepherd. |
| 254 | |
| 255 | XXX TODO: see linux-boot.scm:boot-system. |
| 256 | XXX TODO: add proper file-system checking, mounting |
| 257 | XXX TODO: move bits to (new?) (hurd?) (activation?) services |
| 258 | XXX TODO: use Linux xattr/setxattr to remove (settrans in) /libexec/RUNSYSTEM |
| 259 | |
| 260 | " |
| 261 | |
| 262 | (display "Welcome, this is GNU's early boot Guile.\n") |
| 263 | (display "Use '--repl' for an initrd REPL.\n\n") |
| 264 | |
| 265 | (call-with-error-handling |
| 266 | (lambda () |
| 267 | |
| 268 | (let* ((args (command-line)) |
| 269 | (system (find-long-option "--system" args)) |
| 270 | (to-load (find-long-option "--load" args))) |
| 271 | |
| 272 | (format #t "Setting-up essential translators...\n") |
| 273 | (setenv "PATH" (string-append system "/profile/bin")) |
| 274 | (set-hurd-device-translators) |
| 275 | |
| 276 | (false-if-exception (delete-file "/hurd")) |
| 277 | (let ((hurd/hurd (readlink* (string-append system "/profile/hurd")))) |
| 278 | (symlink hurd/hurd "/hurd")) |
| 279 | |
| 280 | (format #t "Starting pager...\n") |
| 281 | (unless (zero? (system* "/hurd/mach-defpager")) |
| 282 | (format #t "FAILED...Good luck!\n")) |
| 283 | |
| 284 | (cond ((member "--repl" args) |
| 285 | (format #t "Starting repl...\n") |
| 286 | (start-repl)) |
| 287 | (to-load |
| 288 | (format #t "loading '~a'...\n" to-load) |
| 289 | (primitive-load to-load) |
| 290 | (format (current-error-port) |
| 291 | "boot program '~a' terminated, rebooting~%" |
| 292 | to-load) |
| 293 | (sleep 2) |
| 294 | (reboot)) |
| 295 | (else |
| 296 | (display "no boot file passed via '--load'\n") |
| 297 | (display "entering a warm and cozy REPL\n") |
| 298 | (start-repl))))) |
| 299 | #:on-error on-error)) |
| 300 | |
| 301 | ;;; hurd-boot.scm ends here |