squash! system: bare-hurd.tmpl: Add openssh-sans-x client and service.

As reported my mothacehe on IRC: --no-grafts is no longer necessary.

gnu/build/hurd-boot.scm

@@ -80,16 +80,8 @@ Return the value associated with OPTION, or #f on failure."
     (string-append root (if (string-suffix? "/" root) "" "/") dir))
 
   (mkdir (scope "dev"))
-  (for-each (lambda (file)
-              (call-with-output-file (scope file)
-                (lambda (port)
-                  (display file port)   ;avoid hard-linking
-                  (chmod port #o666))))
-            '("dev/null"
-              "dev/zero"
-              "dev/full"
-              "dev/random"
-              "dev/urandom"))
+  ;; Don't create /dev/null etc just yet; the store
+  ;; messes-up the permission bits.
   ;; Don't create /dev/console, /dev/vcs, etc.: they are created by
   ;; console-run on first boot.
 
@@ -115,6 +107,125 @@ Return the value associated with OPTION, or #f on failure."
   ;; settings?
   )
 
+(define (xattr-translator? file-name)
+  "Return true if FILE-NAME has an extended @code{gnu.translator} attribute
+set."
+  (false-if-exception
+   (not (string-null? (getxattr file-name "gnu.translator")))))
+
+(define (showtrans-translator? file-name)
+  "Return true if @file{showtrans} finds a translator installed on FILE-NAME."
+  (with-output-to-port (%make-void-port "w")
+    (lambda _
+      (with-error-to-port (%make-void-port "w")
+        (lambda _
+          (zero? (system* "showtrans" "--silent" file-name)))))))
+
+(define (translated? file-name)
+  "Return true if a translator is installed on FILE-NAME."
+  (if (string-contains %host-type "linux-gnu")
+      (xattr-translator? file-name)
+      (showtrans-translator? file-name)))
+
+(define* (setup-translator file-name command #:optional (mode #o600))
+  "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 mode)))))
+    (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)
+       (scope-setup-translator (list file-name command #o600)))
+      ((file-name command mode)
+       (let ((mount-point (scope file-name)))
+         (setup-translator mount-point command mode)))))
+
+  (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")            #o666)
+      ("dev/null"    ("/hurd/null")                         #o666)
+      ("dev/random"  ("/hurd/random"   "--seed-file" "/var/lib/random-seed")
+                                                            #o644)
+      ("dev/zero"    ("/hurd/storeio"  "--store-type=zero") #o666)
+
+      ("dev/console" ("/hurd/term"     "/dev/console" "device" "console"))
+
+      ("dev/klog"    ("/hurd/streamio" "kmsg"))
+      ("dev/mem"     ("/hurd/storeio"  "--no-cache" "mem")  #o660)
+      ("dev/shm"     ("/hurd/tmpfs"    "--mode=1777" "50%") #o644)
+      ("dev/time"    ("/hurd/storeio"  "--no-cache" "time") #o644)
+
+      ("dev/vcs"     ("/hurd/console"))
+      ("dev/tty"     ("/hurd/magic"    "tty")               #o666)
+
+      ("dev/tty1"    ("/hurd/term"     "/dev/tty1" "hurdio" "/dev/vcs/1/console")
+                                                            #o666)
+      ("dev/tty2"    ("/hurd/term"     "/dev/tty2" "hurdio" "/dev/vcs/2/console")
+                                                            #o666)
+      ("dev/tty3"    ("/hurd/term"     "/dev/tty3" "hurdio" "/dev/vcs/3/console")
+                                                            #o666)
+
+      ("dev/ptyp0"   ("/hurd/term"     "/dev/ptyp0" "pty-master" "/dev/ttyp0")
+                                                            #o666)
+      ("dev/ptyp1"   ("/hurd/term"     "/dev/ptyp1" "pty-master" "/dev/ttyp1")
+                                                            #o666)
+      ("dev/ptyp2"   ("/hurd/term"     "/dev/ptyp2" "pty-master" "/dev/ttyp2")
+                                                            #o666)
+
+      ("dev/ttyp0"   ("/hurd/term"     "/dev/ttyp0" "pty-slave" "/dev/ptyp0")
+                                                            #o666)
+      ("dev/ttyp1"   ("/hurd/term"     "/dev/ttyp1" "pty-slave" "/dev/ptyp1")
+                                                            #o666)
+      ("dev/ttyp2"   ("/hurd/term"     "/dev/ttyp2" "pty-slave" "/dev/ptyp2")
+                                                            #o666)))
+
+  (for-each scope-setup-translator servers)
+  (false-if-exception (mkdir-p (scope "dev/vcs/1")))
+  (false-if-exception (mkdir-p (scope "dev/vcs/2")))
+  (false-if-exception (mkdir-p (scope "dev/vcs/3")))
+  (false-if-exception (rename-file "/dev/console" "/dev/console-"))
+  (for-each scope-setup-translator devices)
+
+  (false-if-exception (symlink "/dev/random" "/dev/urandom"))
+  (false-if-exception (mkdir-p "/dev/fd"))
+  (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.
@@ -126,20 +237,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 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")
@@ -147,35 +247,13 @@ 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" "--silent" node)))))))
-
      (let* ((args    (command-line))
             (system  (find-long-option "--system" args))
             (to-load (find-long-option "--load" args)))
 
-       (format #t "Creating essential servers...\n")
-       (setenv "PATH" (string-append system "/profile/bin"
-                                     ":" system "/profile/sbin"))
-       (for-each (match-lambda
-                   ((node command)
-                    (unless (translated? node)
-                      (mkdir-p (dirname node))
-                      (apply invoke "settrans" "--create" 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")
+       (setenv "PATH" (string-append system "/profile/bin"))
+       (set-hurd-device-translators)
 
        (false-if-exception (delete-file "/hurd"))
        (let ((hurd/hurd (readlink* (string-append system "/profile/hurd"))))

gnu/system.scm

@@ -1190,6 +1190,7 @@ a list of <menu-entry>, to populate the \"old entries\" menu."
                 "--device-master-port='${device-port}'"
                 "--exec-server-task='${exec-task}'"
                 "--store-type=typed"
+                "--x-xattr-translator-records"
                 "'${root}'" "'$(task-create)'" "'$(task-resume)'"))
          (target (%current-target-system))
          (libc (if target

gnu/system/examples/bare-hurd.tmpl

@@ -5,12 +5,27 @@
 
 ;; To build a disk image for a virtual machine, do
 ;;
-;;     ./pre-inst-env guix system disk-image --target=i586-pc-gnu --no-grafts \
+;;     ./pre-inst-env guix system disk-image --target=i586-pc-gnu \
 ;;         gnu/system/examples/bare-hurd.tmpl
 ;;
-;; it boots, but needs activation, more setup and services to be useful.
+;; You may run it like so
+;;
+;;     guix environment --ad-hoc qemu -- qemu-system-i386 -enable-kvm -m 512M \
+;;      -device rtl8139,netdev=net0 -netdev user,id=net0,hostfwd=tcp:127.0.0.1:10022-:2222 \
+;;      -snapshot -hda <the-image>
+;;
+;; and use it like
+;;
+;;     ssh -p 10022 root@localhost
+;;     guix build -e '(@@ (gnu packages commencement) gnu-make-boot0)'
+;;
+;; or even (if you use --image-size=3G)
+;;
+;;     guix build hello
 
 (use-modules (gnu) (gnu system hurd) (guix utils))
+(use-service-modules ssh)
+(use-package-modules ssh)
 
 (define %hurd-os
   (operating-system
@@ -25,7 +40,15 @@
                         %base-file-systems))
     (host-name "guixygnu")
     (timezone "Europe/Amsterdam")
-    (packages %base-packages/hurd)
-    (services %base-services/hurd)))
+    (packages (cons openssh-sans-x %base-packages/hurd))
+    (services (cons (service openssh-service-type
+                             (openssh-configuration
+                              (openssh openssh-sans-x)
+                              (use-pam? #f)
+                              (port-number 2222)
+                              (permit-root-login #t)
+                              (allow-empty-passwords? #t)
+                              (password-authentication? #t)))
+               %base-services/hurd))))
 
 %hurd-os

gnu/system/hurd.scm

@@ -39,16 +39,15 @@
   #:use-module (gnu system)
   #:use-module (gnu system shadow)
   #:use-module (gnu system vm)
-  #:export (cross-hurd-image
-            %base-packages/hurd
+  #:export (%base-packages/hurd
             %base-services/hurd
             %hurd-default-operating-system
             %hurd-default-operating-system-kernel))
 
 ;;; Commentary:
 ;;;
-;;; This module provides tools to (cross-)build GNU/Hurd virtual machine
-;;; images.
+;;; This module provides system-specifics for the GNU/Hurd operating system
+;;; and virtual machine.
 ;;;
 ;;; Code:
 
@@ -104,173 +103,3 @@
     (pam-services '())
     (setuid-programs '())
     (sudoers-file #f)))
-
-(define* (cross-hurd-image #:key (hurd hurd) (gnumach gnumach))
-  "Return a cross-built GNU/Hurd image."
-
-  (define (cross-built thing)
-    (with-parameters ((%current-target-system "i586-pc-gnu"))
-      thing))
-
-  (define (cross-built-entry entry)
-    (manifest-entry
-      (inherit entry)
-      (item (cross-built (manifest-entry-item entry)))
-      (dependencies (map cross-built-entry
-                         (manifest-entry-dependencies entry)))))
-
-  (define system-profile
-    (profile
-     (content
-      (map-manifest-entries cross-built-entry
-                            (packages->manifest %base-packages/hurd)))))
-
-  (define grub.cfg
-    (let ((hurd (cross-built hurd))
-          (mach (with-parameters ((%current-system "i686-linux"))
-                  gnumach))
-          (libc (cross-libc "i586-pc-gnu")))
-      (computed-file "grub.cfg"
-                     #~(call-with-output-file #$output
-                         (lambda (port)
-                           (format port "
-set timeout=2
-search.file ~a/boot/gnumach
-
-menuentry \"GNU\" {
-  multiboot ~a/boot/gnumach root=device:hd0s1
-  module ~a/hurd/ext2fs.static ext2fs \\
-    --multiboot-command-line='${kernel-command-line}' \\
-    --host-priv-port='${host-port}' \\
-    --device-master-port='${device-port}' \\
-    --exec-server-task='${exec-task}' -T typed '${root}' \\
-    '$(task-create)' '$(task-resume)'
-  module ~a/lib/ld.so.1 exec ~a/hurd/exec '$(exec-task=task-create)'
-}\n"
-                                   #+mach #+mach #+hurd
-                                   #+libc #+hurd))))))
-
-  (define fstab
-    (plain-file "fstab"
-                "# This file was generated from your Guix configuration.  Any changes
-# will be lost upon reboot or reconfiguration.
-
-/dev/hd0s1	/	ext2	defaults
-"))
-
-  (define passwd
-    (plain-file "passwd"
-                "root:x:0:0:root:/root:/bin/sh
-guixbuilder:x:1:1:guixbuilder:/var/empty:/bin/no-sh
-"))
-
-  (define group
-    (plain-file "group"
-                "guixbuild:x:1:guixbuilder
-"))
-
-  (define shadow
-    (plain-file "shadow"
-                "root::0:0:0:0:::
-"))
-
-  (define etc-profile
-    (plain-file "profile"
-                "\
-export PS1='\\u@\\h\\$ '
-
-GUIX_PROFILE=\"/run/current-system/profile\"
-. \"$GUIX_PROFILE/etc/profile\"
-
-GUIX_PROFILE=\"$HOME/.guix-profile\"
-if [ -f \"$GUIX_PROFILE/etc/profile\" ]; then
-  . \"$GUIX_PROFILE/etc/profile\"
-fi\n"))
-
-  (define hurd-directives
-    `((directory "/servers")
-      ,@(map (lambda (server)
-               `(file ,(string-append "/servers/" server)))
-             '("startup" "exec" "proc" "password"
-               "default-pager" "crash-dump-core"
-               "kill" "suspend"))
-      ("/servers/crash" -> "crash-dump-core")
-      (directory "/servers/socket")
-      (file "/servers/socket/1")
-      (file "/servers/socket/2")
-      (file "/servers/socket/16")
-      ("/servers/socket/local" -> "1")
-      ("/servers/socket/inet" -> "2")
-      ("/servers/socket/inet6" -> "16")
-      (directory "/boot")
-      ("/boot/grub.cfg" -> ,grub.cfg)   ;XXX: not strictly needed
-      ("/hurd" -> ,(file-append (with-parameters ((%current-target-system
-                                                   "i586-pc-gnu"))
-                                  hurd)
-                                "/hurd"))
-
-      ;; TODO: Create those during activation, eventually.
-      (directory "/root")
-      (file "/root/.guile"
-            ,(object->string
-              '(begin
-                 (use-modules (ice-9 readline) (ice-9 colorized))
-                 (activate-readline) (activate-colorized))))
-      (directory "/run")
-      (directory "/run/current-system")
-      ("/run/current-system/profile" -> ,system-profile)
-      ("/etc/profile" -> ,etc-profile)
-      ("/etc/fstab" -> ,fstab)
-      ("/etc/group" -> ,group)
-      ("/etc/passwd" -> ,passwd)
-      ("/etc/shadow" -> ,shadow)
-      (file "/etc/hostname" "guixygnu")
-      (file "/etc/resolv.conf"
-            "nameserver 10.0.2.3\n")
-      ("/etc/services" -> ,(file-append (with-parameters ((%current-target-system
-                                                           "i586-pc-gnu"))
-                                          net-base)
-                                        "/etc/services"))
-      ("/etc/protocols" -> ,(file-append (with-parameters ((%current-target-system
-                                                            "i586-pc-gnu"))
-                                           net-base)
-                                         "/etc/protocols"))
-      ("/etc/motd" -> ,(file-append (with-parameters ((%current-target-system
-                                                       "i586-pc-gnu"))
-                                      hurd)
-                                    "/etc/motd"))
-      ("/etc/login" -> ,(file-append (with-parameters ((%current-target-system
-                                                        "i586-pc-gnu"))
-                                       hurd)
-                                     "/etc/login"))
-
-
-      ;; XXX can we instead, harmlessly set _PATH_TTYS (from glibc) in runttys.c?
-      ("/etc/ttys" -> ,(file-append (with-parameters ((%current-target-system
-                                                       "i586-pc-gnu"))
-                                      hurd)
-                                    "/etc/ttys"))
-      ("/bin/sh" -> ,(file-append (with-parameters ((%current-target-system
-                                                     "i586-pc-gnu"))
-                                    bash)
-                                  "/bin/sh"))))
-
-  (qemu-image #:file-system-type "ext2"
-              #:file-system-options '("-o" "hurd")
-              #:device-nodes 'hurd
-              #:inputs `(("system" ,system-profile)
-                         ("grub.cfg" ,grub.cfg)
-                         ("fstab" ,fstab)
-                         ("passwd" ,passwd)
-                         ("group" ,group)
-                         ("etc-profile" ,etc-profile)
-                         ("shadow" ,shadow))
-              #:copy-inputs? #t
-              #:os system-profile
-              #:bootcfg-drv grub.cfg
-              #:bootloader grub-bootloader
-              #:register-closures? #f
-              #:extra-directives hurd-directives))
-
-;; Return this thunk so one can type "guix build -f gnu/system/hurd.scm".
-cross-hurd-image