Merge remote-tracking branch 'origin/master' into core-updates

Change-Id: If336ce5529031f7d45dd78b173d897b4ca2d6ab0

5 files changed, 74 insertions, 34 deletions

diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index eea2233563..d8c0cd22a3 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -8,6 +8,7 @@
 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
 ;;; Copyright © 2020 Christine Lemmer-Webber <cwebber@dustycloud.org>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -408,6 +409,7 @@ improvement."
 
   (format #t "making '~a' the current system...~%" system)
 
+  (mkdir-p "/run")
   ;; Atomically make SYSTEM current.
   (let ((new (string-append %current-system ".new")))
     (symlink system new)
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 36a59f5f5c..78d779f398 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -7,6 +7,7 @@
 ;;; Copyright © 2019 David C. Trudgian <dave@trudgian.net>
 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -1021,8 +1022,8 @@ were found."
 
 (define (canonicalize-device-spec spec)
   "Return the device name corresponding to SPEC, which can be a <uuid>, a
-<file-system-label>, or a string (typically a /dev file name or an nfs-root
-containing ':/')."
+<file-system-label>, the string 'none' or another string (typically a /dev
+file name or an nfs-root containing ':/')."
   (define max-trials
     ;; Number of times we retry partition label resolution, 1 second per
     ;; trial.  Note: somebody reported a delay of 16 seconds (!) before their
@@ -1046,8 +1047,8 @@ containing ':/')."
 
   (match spec
     ((? string?)
-     (if (string-contains spec ":/")
-         spec                  ; do not resolve NFS devices
+     (if (or (string-contains spec ":/") (string=? spec "none"))
+         spec                  ; do not resolve NFS / tmpfs devices
          ;; Nothing to do, but wait until SPEC shows up.
          (resolve identity spec identity)))
     ((? file-system-label?)
diff --git a/gnu/build/install.scm b/gnu/build/install.scm
index d4982650c1..0aa227b4d8 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2013-2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -134,8 +135,6 @@ STORE."
     (directory "/var/guix/gcroots")
     (directory "/var/empty")                        ; for no-login accounts
     (directory "/var/db")                           ; for dhclient, etc.
-    (directory "/var/run")
-    (directory "/run")
     (directory "/mnt")
     (directory "/var/guix/profiles/per-user/root" 0 0)
 
diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm
index 27c10e3dfe..0b0a8a70d8 100644
--- a/gnu/build/marionette.scm
+++ b/gnu/build/marionette.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016-2022, 2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
@@ -223,29 +223,49 @@ FILE has not shown up after TIMEOUT seconds, raise an error."
 (define* (wait-for-tcp-port port marionette
                             #:key
                             (timeout 20)
+                            (peek? #f)
                             (address `(make-socket-address AF_INET
                                                            INADDR_LOOPBACK
                                                            ,port)))
   "Wait for up to TIMEOUT seconds for PORT to accept connections in
 MARIONETTE.  ADDRESS must be an expression that returns a socket address,
-typically a call to 'make-socket-address'.  Raise an error on failure."
+typically a call to 'make-socket-address'.  When PEEK? is true, attempt to
+read a byte from the socket upon connection; retry if that gives the
+end-of-file object.
+
+Raise an error on failure."
   ;; Note: The 'connect' loop has to run within the guest because, when we
   ;; forward ports to the host, connecting to the host never raises
   ;; ECONNREFUSED.
   (match (marionette-eval
-          `(let* ((address ,address)
-                  (sock (socket (sockaddr:fam address) SOCK_STREAM 0)))
-             (let loop ((i 0))
+          `(let* ((address ,address))
+             (define (open-socket)
+               (socket (sockaddr:fam address) SOCK_STREAM 0))
+
+             (let loop ((sock (open-socket))
+                        (i 0))
                (catch 'system-error
                  (lambda ()
                    (connect sock address)
+                   (when ,peek?
+                     (let ((byte ((@ (ice-9 binary-ports) lookahead-u8)
+                                  sock)))
+                       (when (eof-object? byte)
+                         (close-port sock)
+                         (throw 'system-error
+                                "wait-for-tcp-port" "~A"
+                                (list (strerror ECONNRESET))
+                                (list ECONNRESET)))))
                    (close-port sock)
                    'success)
                  (lambda args
                    (if (< i ,timeout)
                        (begin
                          (sleep 1)
-                         (loop (+ 1 i)))
+                         (loop (if (port-closed? sock)
+                                   (open-socket)
+                                   sock)
+                               (+ 1 i)))
                        (list 'failure address))))))
           marionette)
     ('success #t)
diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm
index e13fd4eef3..0226c64032 100644
--- a/gnu/build/secret-service.scm
+++ b/gnu/build/secret-service.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020-2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -93,13 +93,28 @@ Return #t in the former case and #f in the latter case."
            ('readable #t)
            ('timeout  #f)))))))
 
-(define* (secret-service-send-secrets port secret-root
+(define (socket-address->string address)
+  "Return a human-readable representation of ADDRESS, an object as returned by
+'make-socket-address'."
+  (let ((family (sockaddr:fam address)))
+    (cond ((= AF_INET family)
+           (string-append (inet-ntop AF_INET (sockaddr:addr address))
+                          ":" (number->string (sockaddr:port address))))
+          ((= AF_INET6 family)
+           (string-append "[" (inet-ntop AF_INET6 (sockaddr:addr address)) "]"
+                          ":" (number->string (sockaddr:port address))))
+          ((= AF_UNIX family)
+           (sockaddr:path address))
+          (else
+           (object->string address)))))
+
+(define* (secret-service-send-secrets address secret-root
                                       #:key (retry 60)
                                       (handshake-timeout 180))
-  "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."
+  "Copy all files under SECRET-ROOT by connecting to secret-service listening
+at ADDRESS, an address as returned by 'make-socket-address'.  If connection
+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))))
@@ -118,9 +133,9 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
                       (dump-port input sock))))
                 files)))
 
-  (log "sending secrets to ~a~%" port)
+  (log "sending secrets to ~a~%" (socket-address->string address))
+
   (let ((sock (socket AF_INET (logior SOCK_CLOEXEC SOCK_STREAM) 0))
-        (addr (make-socket-address AF_INET INADDR_LOOPBACK port))
         (sleep (if (resolve-module '(fibers) #f)
                    (module-ref (resolve-interface '(fibers)) 'sleep)
                    sleep)))
@@ -129,7 +144,7 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
     ;; forward port inside the guest.
     (let loop ((retry retry))
       (catch 'system-error
-        (cute connect sock addr)
+        (cute connect sock address)
         (lambda (key . args)
           (when (zero? retry)
             (apply throw key args))
@@ -147,7 +162,8 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
           (('secret-service-server ('version version ...))
            (log "sending files from ~s...~%" secret-root)
            (send-files sock)
-           (log "done sending files to port ~a~%" port)
+           (log "done sending files to ~a~%"
+                (socket-address->string address))
            (close-port sock)
            secret-root)
           (x
@@ -155,7 +171,8 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
            (close-port sock)
            #f))
         (begin                                    ;timeout
-         (log "timeout while sending files to ~a~%" port)
+         (log "timeout while sending files to ~a~%"
+              (socket-address->string address))
          (close-port sock)
          #f))))
 
@@ -168,19 +185,20 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete.  Return
       (unless (= ENOENT (system-error-errno args))
         (apply throw args)))))
 
-(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.  Return the list of files installed on success,
-and #f otherwise."
+(define (secret-service-receive-secrets address)
+  "Listen to ADDRESS, an address returned by 'make-socket-address', and wait
+for a secret service client to send secrets.  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
-    ;; virtio-serial ports, which would be safer, because they are
-    ;; (presumably) unsupported on GNU/Hurd.
+  (define (wait-for-client address)
+    ;; Wait for a connection on ADDRESS.  Note: virtio-serial ports are safer
+    ;; than TCP connections but they are (presumably) unsupported on GNU/Hurd.
     (let ((sock (socket AF_INET (logior SOCK_CLOEXEC SOCK_STREAM) 0)))
-      (bind sock AF_INET INADDR_ANY port)
+      (bind sock address)
       (listen sock 1)
-      (log "waiting for secrets on port ~a...~%" port)
+      (log "waiting for secrets on ~a...~%"
+           (socket-address->string address))
+
       (match (select (list sock) '() '() 60)
         (((_) () ())
          (match (accept sock)
@@ -244,7 +262,7 @@ and #f otherwise."
        (log "invalid secrets received~%")
        #f)))
 
-  (let* ((port   (wait-for-client port))
+  (let* ((port   (wait-for-client address))
          (result (and=> port read-secrets)))
     (when port
       (close-port port))