Merge branch 'master' into staging

5 files changed, 123 insertions, 48 deletions

diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm
index 498022f6db..5ec839f902 100644
--- a/gnu/build/bootloader.scm
+++ b/gnu/build/bootloader.scm
@@ -22,6 +22,8 @@
   #:use-module (guix utils)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 format)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs io simple)
   #:export (write-file-on-device
             install-efi-loader))
 
@@ -35,11 +37,14 @@
   (call-with-input-file file
     (lambda (input)
       (let ((bv (get-bytevector-n input size)))
-        (call-with-output-file device
-          (lambda (output)
-            (seek output offset SEEK_SET)
-            (put-bytevector output bv))
-          #:binary #t)))))
+        (call-with-port
+         (open-file-output-port device
+                                (file-options no-truncate no-create)
+                                (buffer-mode block)
+                                (native-transcoder))
+         (lambda (output)
+           (seek output offset SEEK_SET)
+           (put-bytevector output bv)))))))
 
 
 ;;;
diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index d8efa73f16..8a2d0eb5fd 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -37,6 +37,7 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:export (make-partition-image
+            convert-disk-image
             genimage
             initialize-efi-partition
             initialize-root-partition
@@ -120,13 +121,22 @@ ROOT directory to populate the image."
       (format (current-error-port)
               "Unsupported partition type~%.")))))
 
-(define* (genimage config target)
+(define (convert-disk-image image format output)
+  "Convert IMAGE to OUTPUT according to the given FORMAT."
+  (case format
+    ((compressed-qcow2)
+     (begin
+       (invoke "qemu-img" "convert" "-c" "-f" "raw"
+               "-O" "qcow2" image output)))
+    (else
+     (copy-file image output))))
+
+(define* (genimage config)
   "Use genimage to generate in TARGET directory, the image described in the
 given CONFIG file."
   ;; genimage needs a 'root' directory.
   (mkdir "root")
-  (invoke "genimage" "--config" config
-          "--outputpath" target))
+  (invoke "genimage" "--config" config))
 
 (define* (register-closure prefix closure
                            #:key
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 2d4de788df..4a8bed5a9a 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -170,7 +170,8 @@ for the process."
     (pivot-root root put-old)
     (chdir "/")
     (umount "real-root" MNT_DETACH)
-    (rmdir "real-root")))
+    (rmdir "real-root")
+    (chmod "/" #o755)))
 
 (define* (initialize-user-namespace pid host-uids
                                     #:key (guest-uid 0) (guest-gid 0))
diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm
index 781651e90d..46dcf1b9c3 100644
--- a/gnu/build/secret-service.scm
+++ b/gnu/build/secret-service.scm
@@ -35,44 +35,86 @@
 ;;;
 ;;; Code:
 
-(define* (secret-service-send-secrets port secret-root #:key (retry 60))
-  "Copy all files under SECRET-ROOT using TCP to secret-service listening at
-local PORT.  If connect fails, sleep 1s and retry RETRY times."
+(define-syntax log
+  (lambda (s)
+    "Log the given message."
+    (syntax-case s ()
+      ((_ fmt args ...)
+       (with-syntax ((fmt (string-append "secret service: "
+                                         (syntax->datum #'fmt))))
+         ;; Log to the current output port.  That way, when
+         ;; 'secret-service-send-secrets' is called from shepherd, output goes
+         ;; to syslog.
+         #'(format (current-output-port) fmt args ...))))))
 
+(define* (secret-service-send-secrets port secret-root
+                                      #:key (retry 60)
+                                      (handshake-timeout 120))
+  "Copy all files under SECRET-ROOT using TCP to secret-service listening at
+local PORT.  If connect fails, sleep 1s and retry RETRY times; once connected,
+wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
+#f on failure."
   (define (file->file+size+mode file-name)
     (let ((stat (stat file-name))
           (target (substring file-name (string-length secret-root))))
       (list target (stat:size stat) (stat:mode stat))))
 
-  (format (current-error-port) "sending secrets to ~a~%" port)
+  (define (send-files sock)
+    (let* ((files (if secret-root (find-files secret-root) '()))
+           (files-sizes-modes (map file->file+size+mode files))
+           (secrets `(secrets
+                      (version 0)
+                      (files ,files-sizes-modes))))
+      (write secrets sock)
+      (for-each (lambda (file)
+                  (call-with-input-file file
+                    (lambda (input)
+                      (dump-port input sock))))
+                files)))
+
+  (log "sending secrets to ~a~%" port)
   (let ((sock (socket AF_INET SOCK_STREAM 0))
         (addr (make-socket-address AF_INET INADDR_LOOPBACK port)))
-    ;; connect to wait for port
+    ;; Connect to QEMU on the forwarded port.  The 'connect' call succeeds as
+    ;; soon as QEMU is ready, even if there's no server listening on the
+    ;; forward port inside the guest.
     (let loop ((retry retry))
       (catch 'system-error
         (cute connect sock addr)
         (lambda (key . args)
           (when (zero? retry)
             (apply throw key args))
-          (format (current-error-port) "retrying connection~%")
+          (log "retrying connection [~a attempts left]~%"
+               (- retry 1))
           (sleep 1)
           (loop (1- retry)))))
 
-    (format (current-error-port) "connected!  sending files in ~s %~"
-            secret-root)
-    (let* ((files (if secret-root (find-files secret-root) '()))
-           (files-sizes-modes (map file->file+size+mode files))
-           (secrets `(secrets
-                      (version 0)
-                      (files ,files-sizes-modes))))
-      (write secrets sock)
-      (for-each (compose (cute dump-port <> sock)
-                         (cute open-input-file <>))
-                files))))
+    (log "connected; waiting for handshake...~%")
+
+    ;; Wait for "hello" message from the server.  This is the only way to know
+    ;; that we're really connected to the server inside the guest.
+    (match (select (list sock) '() '() handshake-timeout)
+      (((_) () ())
+       (match (read sock)
+         (('secret-service-server ('version version ...))
+          (log "sending files from ~s...~%" secret-root)
+          (send-files sock)
+          (log "done sending files to port ~a~%" port)
+          (close-port sock)
+          secret-root)
+         (x
+          (log "invalid handshake ~s~%" x)
+          (close-port sock)
+          #f)))
+      ((() () ())                                 ;timeout
+       (log "timeout while sending files to ~a~%" port)
+       (close-port sock)
+       #f))))
 
 (define (secret-service-receive-secrets port)
   "Listen to local PORT and wait for a secret service client to send secrets.
-Write them to the file system."
+Write them to the file system.  Return the list of files installed on success,
+and #f otherwise."
 
   (define (wait-for-client port)
     ;; Wait for a TCP connection on PORT.  Note: We cannot use the
@@ -81,16 +123,26 @@ Write them to the file system."
     (let ((sock (socket AF_INET SOCK_STREAM 0)))
       (bind sock AF_INET INADDR_ANY port)
       (listen sock 1)
-      (format (current-error-port)
-              "waiting for secrets on port ~a...~%"
-              port)
-      (match (accept sock)
-        ((client . address)
-         (format (current-error-port) "client connection from ~a~%"
+      (log "waiting for secrets on port ~a...~%" port)
+      (match (select (list sock) '() '() 60)
+        (((_) () ())
+         (match (accept sock)
+           ((client . address)
+            (log "client connection from ~a~%"
                  (inet-ntop (sockaddr:fam address)
                             (sockaddr:addr address)))
+
+            ;; Send a "hello" message.  This allows the client running on the
+            ;; host to know that it's now actually connected to server running
+            ;; in the guest.
+            (write '(secret-service-server (version 0)) client)
+            (force-output client)
+            (close-port sock)
+            client)))
+        ((() () ())
+         (log "did not receive any secrets; time out~%")
          (close-port sock)
-         client))))
+         #f))))
 
   ;; TODO: Remove when (@ (guix build utils) dump-port) has a 'size'
   ;; parameter.
@@ -115,23 +167,24 @@ Write them to the file system."
       (('secrets ('version 0)
                  ('files ((files sizes modes) ...)))
        (for-each (lambda (file size mode)
-                   (format (current-error-port)
-                           "installing file '~a' (~a bytes)...~%"
-                           file size)
+                   (log "installing file '~a' (~a bytes)...~%"
+                        file size)
                    (mkdir-p (dirname file))
                    (call-with-output-file file
                      (lambda (output)
                        (dump port output size)
                        (chmod file mode))))
-                 files sizes modes))
+                 files sizes modes)
+       (log "received ~a secret files~%" (length files))
+       files)
       (_
-       (format (current-error-port)
-               "invalid secrets received~%")
+       (log "invalid secrets received~%")
        #f)))
 
-  (let* ((port (wait-for-client port))
-         (result (read-secrets port)))
-    (close-port port)
+  (let* ((port   (wait-for-client port))
+         (result (and=> port read-secrets)))
+    (when port
+      (close-port port))
     result))
 
 ;;; secret-service.scm ends here
diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm
index 65141bd60f..91646288d5 100644
--- a/gnu/build/shepherd.scm
+++ b/gnu/build/shepherd.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -196,11 +197,16 @@ namespace, in addition to essential bind-mounts such /proc."
                                       #:allow-other-keys
                                       #:rest args)
   "This is a variant of 'fork+exec-command' procedure, that joins the
-namespaces of process PID beforehand."
-  (container-excursion* pid
-    (lambda ()
-      (apply fork+exec-command command
-             (strip-keyword-arguments '(#:pid) args)))))
+namespaces of process PID beforehand.  If there is no support for containers,
+on Hurd systems for instance, fallback to direct forking."
+  (let ((container-support?
+         (file-exists? "/proc/self/ns"))
+        (fork-proc (lambda ()
+                     (apply fork+exec-command command
+                            (strip-keyword-arguments '(#:pid) args)))))
+    (if container-support?
+        (container-excursion* pid fork-proc)
+        (fork-proc))))
 
 ;; Local Variables:
 ;; eval: (put 'container-excursion* 'scheme-indent-function 1)