janneke pushed a commit to branch wip-hurd-vm
in repository guix.

commit ef647de139d873289c88312194ea994664a91761
Author: Jan (janneke) Nieuwenhuizen <jann...@gnu.org>
AuthorDate: Mon Jun 1 14:11:41 2020 +0200

    hurd-boot: Use setxattr instead of MAKEDEV.
    
    * gnu/build/hurd-boot.scm (setup-translator, translated?,
    set-hurd-device-translators): New procedure.
    (boot-hurd-system): Use them instead of MAKEDEV.
    * gnu/packages/hurd.scm (hurd-rc-script): Remove setting of PATH.
    (hurd)[arguments]: Remove now obsolete substitution.
---
 gnu/build/hurd-boot.scm | 141 +++++++++++++++++++++++++++++++++---------------
 gnu/packages/hurd.scm   |   6 ---
 2 files changed, 97 insertions(+), 50 deletions(-)

diff --git a/gnu/build/hurd-boot.scm b/gnu/build/hurd-boot.scm
index 0532ca7..20d012f 100644
--- a/gnu/build/hurd-boot.scm
+++ b/gnu/build/hurd-boot.scm
@@ -48,11 +48,7 @@ Return the value associated with OPTION, or #f on failure."
 (define* (make-hurd-device-nodes #:optional (root "/"))
   "Make some of the nodes needed on GNU/Hurd."
   (define (scope dir)
-    (string-append root
-                   (if (string-suffix? "/" root)
-                       ""
-                       "/")
-                   dir))
+    (string-append root (if (string-suffix? "/" root) "" "/") dir))
 
   (mkdir (scope "dev"))
   (for-each (lambda (file)
@@ -60,11 +56,10 @@ Return the value associated with OPTION, or #f on failure."
                 (lambda (port)
                   (display file port)   ;avoid hard-linking
                   (chmod port #o666))))
-            '("dev/null"
-              "dev/zero"
-              "dev/full"
+            '("dev/full"
+              "dev/null"
               "dev/random"
-              "dev/urandom"))
+              "dev/zero"))
   ;; Don't create /dev/console, /dev/vcs, etc.: they are created by
   ;; console-run on first boot.
 
@@ -90,6 +85,96 @@ Return the value associated with OPTION, or #f on failure."
   ;; settings?
   )
 
+(define (translated? file-name)
+  "Return true if a translator is installed on FILE-NAME."
+  (false-if-exception
+   (not (string-null? (getxattr file-name "gnu.translator")))))
+
+(define (setup-translator file-name command)
+  "Setup translator COMMAND on FILE-NAME."
+  (unless (translated? file-name)
+    (let ((dir (dirname file-name)))
+      (unless (directory-exists? dir)
+        (mkdir-p dir))
+      (unless (file-exists? file-name)
+        (call-with-output-file file-name
+          (lambda (port)
+            (display file-name port)  ;avoid hard-linking
+            (chmod port #o444)))))
+    (catch 'system-error
+      (lambda _
+        (setxattr file-name "gnu.translator" (string-join command "\0" 
'suffix)))
+      (lambda (key . args)
+        (let ((errno (system-error-errno (cons key args))))
+          (format (current-error-port) "~a: ~a\n"
+                  (strerror errno) file-name)
+          (format (current-error-port) "Ignoring...Good Luck!\n"))))))
+
+(define* (set-hurd-device-translators #:optional (root "/"))
+  "Make some of the device nodes needed on GNU/Hurd."
+
+  (define (scope dir)
+    (string-append root (if (string-suffix? "/" root) "" "/") dir))
+
+  (define scope-setup-translator
+    (match-lambda
+      ((file-name command)
+       (let ((mount-point (scope file-name)))
+         (setup-translator mount-point command)))))
+
+  (define servers
+    '(("servers/crash-dump-core" ("/hurd/crash" "--dump-core"))
+      ("servers/crash-kill"      ("/hurd/crash" "--kill"))
+      ("servers/crash-suspend"   ("/hurd/crash" "--suspend"))
+      ("servers/password"        ("/hurd/password"))
+      ;;
+      ;;("servers/socket/1"        ("/hurd/pflocal"))
+      ("servers/socket/2"        ("/hurd/pfinet"
+                                  "--interface" "eth0"
+                                  "--address"
+                                  "10.0.2.15" ;the default QEMU guest IP
+                                  "--netmask" "255.255.255.0"
+                                  "--gateway" "10.0.2.2"
+                                  "--ipv6" "/servers/socket/16"))))
+
+  (define devices
+    '(("dev/full"    ("/hurd/null"     "--full"))
+      ("dev/null"    ("/hurd/null"))
+      ("dev/random"  ("/hurd/random"   "--seed-file" "/var/lib/random-seed"))
+      ("dev/zero"    ("/hurd/storeio"  "--store-type=zero"))
+
+      ("dev/console" ("/hurd/term"     "/dev/consosle" "device" "console"))
+      ("dev/klog"    ("/hurd/streamio" "kmsg"))
+      ("dev/mem"     ("/hurd/storeio"  "--no-cache" "mem"))
+      ("dev/shm"     ("/hurd/tmpfs"    "--mode=1777" "50%"))
+      ("dev/time"    ("/hurd/storeio"  "--no-cache" "time"))
+
+      ("dev/tty"     ("/hurd/magic"    "tty"))
+      ("dev/vcs"     ("/hurd/console"))
+
+      ("dev/tty1"    ("/hurd/term"     "/dev/tty1" "hurdio" 
"/dev/vcs/1/console"))
+      ("dev/tty2"    ("/hurd/term"     "/dev/tty2" "hurdio" 
"/dev/vcs/2/console"))
+      ("dev/tty3"    ("/hurd/term"     "/dev/tty3" "hurdio" 
"/dev/vcs/3/console"))
+
+      ("dev/ptyp0"   ("/hurd/term"     "/dev/ptyp0" "pty-master" "/dev/ttyp0"))
+      ("dev/ptyp1"   ("/hurd/term"     "/dev/ptyp1" "pty-master" "/dev/ttyp1"))
+      ("dev/ptyp2"   ("/hurd/term"     "/dev/ptyp2" "pty-master" "/dev/ttyp2"))
+
+      ("dev/ttyp0"   ("/hurd/term"     "/dev/ttyp0" "pty-slave" "/dev/ptyp0"))
+      ("dev/ttyp1"   ("/hurd/term"     "/dev/ttyp1" "pty-slave" "/dev/ptyp1"))
+      ("dev/ttyp2"   ("/hurd/term"     "/dev/ttyp2" "pty-slave" 
"/dev/ptyp2"))))
+
+  (for-each scope-setup-translator servers)
+  (mkdir-p (scope "dev/vcs/1"))
+  (mkdir-p (scope "dev/vcs/2"))
+  (mkdir-p (scope "dev/vcs/3"))
+  (for-each scope-setup-translator devices)
+
+  (false-if-exception (symlink "/dev/random" "/dev/urandom"))
+  (false-if-exception (symlink "/dev/fd/0"   "/dev/stdin"))
+  (false-if-exception (symlink "/dev/fd/1"   "/dev/stdout"))
+  (false-if-exception (symlink "/dev/fd/2"   "/dev/stderr")))
+
 
 (define* (boot-hurd-system #:key (on-error 'debug))
   "This procedure is meant to be called from an early RC script.
@@ -101,21 +186,9 @@ starting the Shepherd.
 XXX TODO: see linux-boot.scm:boot-system.
 XXX TODO: add proper file-system checking, mounting
 XXX TODO: move bits to (new?) (hurd?) (activation?) services
-XXX TODO: use xattr/setxattr to remove sett
-XXX TODO: use settrans/setxattr instead of MAKEDEV
+XXX TODO: use Linux xattr/setxattr to remove (settrans in) /libexec/RUNSYSTEM
 
 "
-  (define translators
-    '(("/servers/crash-dump-core" ("/hurd/crash" "--dump-core"))
-      ("/servers/crash-kill" ("/hurd/crash" "--kill"))
-      ("/servers/crash-suspend" ("/hurd/crash" "--suspend"))
-      ("/servers/password" ("/hurd/password"))
-      ("/servers/socket/1" ("/hurd/pflocal"))
-      ("/servers/socket/2" ("/hurd/pfinet" "--interface" "eth0"
-                            "--address" "10.0.2.15" ;the default QEMU guest IP
-                            "--netmask" "255.255.255.0"
-                            "--gateway" "10.0.2.2"
-                            "--ipv6" "/servers/socket/16"))))
 
   (display "Welcome, this is GNU's early boot Guile.\n")
   (display "Use '--repl' for an initrd REPL.\n\n")
@@ -123,28 +196,8 @@ XXX TODO: use settrans/setxattr instead of MAKEDEV
   (call-with-error-handling
    (lambda ()
 
-     (define (translated? node)
-       ;; Return true if a translator is installed on NODE.
-       (with-output-to-port (%make-void-port "w")
-         (lambda ()
-           (with-error-to-port (%make-void-port "w")
-             (lambda ()
-               (zero? (system* "showtrans" "-s" node)))))))
-
-     (for-each (match-lambda
-                 ((node command)
-                  (unless (translated? node)
-                    (mkdir-p (dirname node))
-                    (apply invoke "settrans" "-c" node command))))
-               translators)
-
-     (format #t "Creating essential device nodes...\n")
-     (with-directory-excursion "/dev"
-       (invoke "MAKEDEV" "--devdir=/dev" "std")
-       (invoke "MAKEDEV" "--devdir=/dev" "vcs")
-       (invoke "MAKEDEV" "--devdir=/dev" "tty1""tty2" "tty3" "tty4" "tty5" 
"tty6")
-       (invoke "MAKEDEV" "--devdir=/dev" "ptyp0" "ptyp1" "ptyp2")
-       (invoke "MAKEDEV" "--devdir=/dev" "console"))
+     (format #t "Setting-up essential translators...\n")
+     (set-hurd-device-translators)
 
      (format #t "Starting pager...\n")
      (unless (zero? (system* "/hurd/mach-defpager"))
diff --git a/gnu/packages/hurd.scm b/gnu/packages/hurd.scm
index 8ef561b..5de4acb 100644
--- a/gnu/packages/hurd.scm
+++ b/gnu/packages/hurd.scm
@@ -329,9 +329,6 @@ activation; starting the Shepherd."
                        (srfi srfi-1)
                        (srfi srfi-26))
 
-          ;; "@HURD@" and "@COREUTILS@" are placeholders.
-          (setenv "PATH" "@HURD@/bin:@HURD@/sbin:@COREUTILS@/bin")
-
           (boot-hurd-system))))
 
   ;; FIXME: We want the program to use the cross-compiled Guile when
@@ -495,9 +492,6 @@ exec /libexec/rc \"$@\"
                     (coreutils (assoc-ref inputs "coreutils")))
                (delete-file file)
                (copy-file rc file)
-               (substitute* file
-                 (("@HURD@") out)
-                 (("@COREUTILS@") coreutils))
                #t))))
        #:configure-flags (list (string-append "LDFLAGS=-Wl,-rpath="
                                               %output "/lib")

Reply via email to