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   (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 ()
 156                (zero? (system* "showtrans" "-s" node)))))))
 157
 158      (for-each (match-lambda
 159                  ((node command)
 160                   (unless (translated? node)
 161                     (mkdir-p (dirname node))
 162                     (apply invoke "settrans" "-c" node command))))
 163                translators)
 164
 165      (format #t "Creating essential device nodes...\n")
 166      (with-directory-excursion "/dev"
 167        (invoke "MAKEDEV" "--devdir=/dev" "std")
 168        (invoke "MAKEDEV" "--devdir=/dev" "vcs")
 169        (invoke "MAKEDEV" "--devdir=/dev" "tty1""tty2" "tty3" "tty4" "tty5" "tty6")
 170        (invoke "MAKEDEV" "--devdir=/dev" "ptyp0" "ptyp1" "ptyp2")
 171        (invoke "MAKEDEV" "--devdir=/dev" "console"))
 172
 173      (let* ((args    (command-line))
 174             (system  (find-long-option "--system" args))
 175             (to-load (find-long-option "--load" args)))
 176
 177        (false-if-exception (delete-file "/hurd"))
 178        (let ((hurd/hurd (readlink* (string-append system "/profile/hurd"))))
 179          (symlink hurd/hurd "/hurd"))
 180
 181        (format #t "Starting pager...\n")
 182        (unless (zero? (system* "/hurd/mach-defpager"))
 183          (format #t "FAILED...Good luck!\n"))
 184
 185        (cond ((member "--repl" args)
 186               (format #t "Starting repl...\n")
 187               (start-repl))
 188              (to-load
 189               (format #t "loading '~a'...\n" to-load)
 190               (primitive-load to-load)
 191               (format (current-error-port)
 192                       "boot program '~a' terminated, rebooting~%"
 193                       to-load)
 194               (sleep 2)
 195               (reboot))
 196              (else
 197               (display "no boot file passed via '--load'\n")
 198               (display "entering a warm and cozy REPL\n")
 199               (start-repl)))))
 200    #:on-error on-error))
 201
 202 ;;; hurd-boot.scm ends here