Merge branch 'master' into gnome-team

1 files changed, 162 insertions, 11 deletions

diff --git a/gnu/services/virtualization.scm b/gnu/services/virtualization.scm
index e1a206e0eb..f0f0ab3bf1 100644
--- a/gnu/services/virtualization.scm
+++ b/gnu/services/virtualization.scm
@@ -27,7 +27,9 @@
   #:use-module (gnu bootloader grub)
   #:use-module (gnu image)
   #:use-module (gnu packages admin)
+  #:use-module (gnu packages bash)
   #:use-module (gnu packages gdb)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu packages package-management)
   #:use-module (gnu packages ssh)
   #:use-module (gnu packages virtualization)
@@ -50,6 +52,8 @@
   #:use-module (guix records)
   #:use-module (guix store)
   #:use-module (guix utils)
+  #:autoload   (guix self) (make-config.scm)
+  #:autoload   (guix platform) (platform-system)
 
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
@@ -1061,6 +1065,40 @@ that will be listening to receive secret keys on port 1004, TCP."
 ;;; The Hurd in VM service: a Childhurd.
 ;;;
 
+(define (operating-system-with-offloading-account os)
+  (define accounts
+    (list (user-group
+           (name "offloading")
+           (system? #t))
+          (user-account
+           (name "offloading")
+           (group "offloading")
+           (system? #t)
+           (comment "Offloading privilege separation user")
+           (home-directory "/var/run/offloading")
+           (shell (file-append bash-minimal "/bin/sh")))))
+
+  (operating-system
+    (inherit os)
+    (services (cons (simple-service 'offloading-account
+                                    account-service-type
+                                    accounts)
+                    (operating-system-user-services os)))))
+
+(define (operating-system-with-locked-root-account os)
+  "Return OS with a 'root' account whose password is uninitialized, thereby
+preventing password-based authentication as 'root'."
+  (define root
+    ;; %ROOT-ACCOUNT has an empty password; change that to an uninitialized
+    ;; password.
+    (user-account
+     (inherit %root-account)
+     (password #f)))
+
+  (operating-system
+    (inherit os)
+    (users (cons root (operating-system-users os)))))
+
 (define %hurd-vm-operating-system
   (operating-system
     (inherit %hurd-default-operating-system)
@@ -1078,8 +1116,7 @@ that will be listening to receive secret keys on port 1004, TCP."
                         (openssh-configuration
                          (openssh openssh-sans-x)
                          (use-pam? #f)
-                         (port-number 2222)
-                         (permit-root-login #t)
+                         (permit-root-login 'prohibit-password)
                          (allow-empty-passwords? #t)
                          (password-authentication? #t)))
 
@@ -1100,7 +1137,7 @@ that will be listening to receive secret keys on port 1004, TCP."
                (default %hurd-vm-operating-system))
   (qemu        hurd-vm-configuration-qemu               ;file-like
                (default qemu-minimal))
-  (image       hurd-vm-configuration-image              ;string
+  (image       hurd-vm-configuration-image              ;<image>
                (thunked)
                (default (hurd-vm-disk-image this-record)))
   (disk-size   hurd-vm-configuration-disk-size          ;number or 'guess
@@ -1114,20 +1151,32 @@ that will be listening to receive secret keys on port 1004, TCP."
   (net-options hurd-vm-configuration-net-options        ;list of string
                (thunked)
                (default (hurd-vm-net-options this-record)))
+  (offloading? hurd-vm-configuration-offloading?        ;Boolean
+               (default #t))
   (secret-root hurd-vm-configuration-secret-root        ;string
                (default "/etc/childhurd")))
 
 (define (hurd-vm-disk-image config)
   "Return a disk-image for the Hurd according to CONFIG.  The secret-service
 is added to the OS specified in CONFIG."
-  (let* ((os        (secret-service-operating-system
-                     (hurd-vm-configuration-os config)))
+  (define transform
+    (compose secret-service-operating-system
+             ;; When offloading is enabled, (1) add the 'offloading' account,
+             ;; and (2) prevent users from logging in as 'root' without a
+             ;; password as this would allow any user on the host to populate
+             ;; the host's store indirectly (for example by logging in as root
+             ;; in the Hurd VM over VNC).
+             (if (hurd-vm-configuration-offloading? config)
+                 (compose operating-system-with-locked-root-account
+                          operating-system-with-offloading-account)
+                 identity)))
+
+  (let* ((os        (transform (hurd-vm-configuration-os config)))
          (disk-size (hurd-vm-configuration-disk-size config))
          (type      (lookup-image-type-by-name 'hurd-qcow2))
          (os->image (image-type-constructor type)))
-    (system-image
-     (image (inherit (os->image os))
-            (size disk-size)))))
+    (image (inherit (os->image os))
+           (size disk-size))))
 
 (define (hurd-vm-port config base)
   "Return the forwarded vm port for this childhurd config."
@@ -1146,7 +1195,7 @@ is added to the OS specified in CONFIG."
                     "-:1004"
                     ",hostfwd=tcp:127.0.0.1:"
                     (number->string (hurd-vm-port config %hurd-vm-ssh-port))
-                    "-:2222"
+                    "-:22"
                     ",hostfwd=tcp:127.0.0.1:"
                     (number->string (hurd-vm-port config %hurd-vm-vnc-port))
                     "-:5900")))
@@ -1169,7 +1218,7 @@ is added to the OS specified in CONFIG."
                       "-m" (number->string #$memory-size)
                       #$@net-options
                       #$@options
-                      "--hda" #+image
+                      "--hda" #+(system-image image)
 
                       ;; Cause the service to be respawned if the guest
                       ;; reboots (it can reboot for instance if it did not
@@ -1272,6 +1321,50 @@ is added to the OS specified in CONFIG."
 
   (program-file "initialize-hurd-vm-substitutes" run))
 
+(define (authorize-guest-substitutes-on-host)
+  "Return a program that authorizes the guest's archive signing key (passed as
+an argument) on the host."
+  (define not-config?
+    (match-lambda
+      ('(guix config) #f)
+      (('guix _ ...) #t)
+      (('gnu _ ...) #t)
+      (_ #f)))
+
+  (define run
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules `(((guix config) => ,(make-config.scm))
+                               ,@(source-module-closure
+                                  '((guix pki)
+                                    (guix build utils))
+                                  #:select? not-config?))
+        #~(begin
+            (use-modules (ice-9 match)
+                         (ice-9 textual-ports)
+                         (gcrypt pk-crypto)
+                         (guix pki)
+                         (guix build utils))
+
+            (match (command-line)
+              ((_ guest-config-directory)
+               (let ((guest-key (string-append guest-config-directory
+                                               "/signing-key.pub")))
+                 (if (file-exists? guest-key)
+                     ;; Add guest key to the host's ACL.
+                     (let* ((key (string->canonical-sexp
+                                  (call-with-input-file guest-key
+                                    get-string-all)))
+                            (acl (public-keys->acl
+                                  (cons key (acl->public-keys (current-acl))))))
+                       (with-atomic-file-replacement %acl-file
+                         (lambda (_ port)
+                           (write-acl acl port))))
+                     (format (current-error-port)
+                             "warning: guest key missing from '~a'~%"
+                             guest-key)))))))))
+
+  (program-file "authorize-guest-substitutes-on-host" run))
+
 (define (hurd-vm-activation config)
   "Return a gexp to activate the Hurd VM according to CONFIG."
   (with-imported-modules '((guix build utils))
@@ -1287,15 +1380,71 @@ is added to the OS specified in CONFIG."
         (define guix-directory
           (string-append secret-directory "/etc/guix"))
 
+        (define offloading-ssh-key
+          #$(hurd-vm-configuration-offloading-ssh-key config))
+
         (unless (file-exists? ssh-directory)
           ;; Generate SSH host keys under SSH-DIRECTORY.
           (mkdir-p ssh-directory)
           (invoke #$(file-append openssh "/bin/ssh-keygen")
                   "-A" "-f" secret-directory))
 
+        (unless (or (not #$(hurd-vm-configuration-offloading? config))
+                    (file-exists? offloading-ssh-key))
+          ;; Generate a user SSH key pair for the host to use when offloading
+          ;; to the guest.
+          (mkdir-p (dirname offloading-ssh-key))
+          (invoke #$(file-append openssh "/bin/ssh-keygen")
+                  "-t" "ed25519" "-N" ""
+                  "-f" offloading-ssh-key)
+
+          ;; Authorize it in the guest for user 'offloading'.
+          (let ((authorizations
+                 (string-append ssh-directory
+                                "/authorized_keys.d/offloading")))
+            (mkdir-p (dirname authorizations))
+            (copy-file (string-append offloading-ssh-key ".pub")
+                       authorizations)
+            (chmod (dirname authorizations) #o555)))
+
         (unless (file-exists? guix-directory)
           (invoke #$(initialize-hurd-vm-substitutes)
-                  guix-directory)))))
+                  guix-directory))
+
+        (when #$(hurd-vm-configuration-offloading? config)
+          ;; Authorize the archive signing key from GUIX-DIRECTORY in the host.
+          (invoke #$(authorize-guest-substitutes-on-host) guix-directory)))))
+
+(define (hurd-vm-configuration-offloading-ssh-key config)
+  "Return the name of the file containing the SSH key of user 'offloading'."
+  (string-append "/etc/guix/offload/ssh/childhurd"
+                 (or (and=> (hurd-vm-configuration-id config)
+                            number->string)
+                     "")))
+
+(define (hurd-vm-guix-extension config)
+  "When offloading is enabled, add this childhurd to the list of offlading
+machines in /etc/guix/machines.scm."
+  (if (hurd-vm-configuration-offloading? config)
+      (let* ((image (hurd-vm-configuration-image config))
+             (platform (image-platform image))
+             (system (platform-system platform))
+             (vm-ssh-key (string-append
+                          (hurd-vm-configuration-secret-root config)
+                          "/etc/ssh/ssh_host_ed25519_key.pub"))
+             (host-ssh-key (hurd-vm-configuration-offloading-ssh-key config)))
+        (guix-extension
+         (build-machines
+          (list #~(build-machine
+                   (name "localhost")
+                   (port #$(hurd-vm-port config %hurd-vm-ssh-port))
+                   (systems '(#$system))
+                   (host-key (call-with-input-file #$vm-ssh-key
+                               (@ (ice-9 textual-ports)
+                                  get-string-all)))
+                   (user "offloading")
+                   (private-key #$host-ssh-key))))))
+      (guix-extension)))
 
 (define hurd-vm-service-type
   (service-type
@@ -1304,6 +1453,8 @@ is added to the OS specified in CONFIG."
                                         hurd-vm-shepherd-service)
                      (service-extension account-service-type
                                         (const %hurd-vm-accounts))
+                     (service-extension guix-service-type
+                                        hurd-vm-guix-extension)
                      (service-extension activation-service-type
                                         hurd-vm-activation)))
    (default-value (hurd-vm-configuration))