gnu/build/hurd-boot.scm

   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         (setxattr file-name "gnu.translator" (string-join command "\0" 'suffix)))
 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* "dev/vcs/1")
 236   (mkdir* "dev/vcs/2")
 237   (mkdir* "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* "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