[bug#65221] [PATCH 2/6] service: don't let earlier ports clobber later ones in EXTRA-PORTS.

[ulfvonbelow <striness@tilde.club>]

In some situations, EXTRA-PORTS may not work as described, because it copies
file descriptor contents in an arbitrary order.  For example, suppose
that (map fileno EXTRA-PORTS) is (7 6 5 4 3).  If the underlying file
originally stored in fd N is represented by F(N), it will assign

3 <-- F(7)
4 <-- F(6)
5 <-- F(5)
6 <-- F(6)
7 <-- F(7)

In other words, the copying of earlier FDs in EXTRA-PORTS may overwrite later
FDs in EXTRA-PORTS.

Because the process of properly and safely copying those FDs involves some
complexity, we've split it into a separate procedure named PRESERVE-PORTS.

* modules/shepherd/service.scm (reconfigure-ports): new procedure.
  (exec-command): use it.
---
 modules/shepherd/service.scm | 154 +++++++++++++++++++++++++----------
 1 file changed, 113 insertions(+), 41 deletions(-)

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 68553d4..68993ac 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -1434,6 +1434,88 @@ FILE."
   (list->vector (map (lambda (group) (group:gid (getgr group)))
                      supplementary-groups)))
 
+(define* (reconfigure-fds ports-or-fds #:optional (base 0))
+  "Duplicate the FDs (fd0 fd1 ... fdN) corresponding to the N ports or FDs in
+EXTRA-PORTS into the FD range (0 1 ... N), clearing their FD_CLOEXEC flag at
+the same time.  This will work regardless of the numeric values of fd1
+... fdN.  File descriptors outside of the range 0..N will not be affected.
+This may fail if there are zero unused file descriptors."
+  ;; If we view each FD as a node, and fd n at index k of FDS as an edge from
+  ;; fd n to fd k, then we have a rather special type of graph.  Because of
+  ;; how the edges must be specified, it has the property that no node can
+  ;; have more than one parent, like a tree, but unlike a tree it is possible
+  ;; to have cycles (combined with the prior restriction, this means a given
+  ;; node can be part of at most one cycle).  I don't know of a good name for
+  ;; that kind of graph - maybe "rootless tree"?  Anyway, our approach is to,
+  ;; for each unique FD in FDS, do a traversal that both finds the cyclic
+  ;; path, if it exists, and sets every FD that isn't part of the cycle, then
+  ;; finally resolve the cycle using a temporary fd.
+
+  (define fds (map (lambda (x)
+                     (if (port? x) (fileno x) x))
+                   ports-or-fds))
+  (define max-fd (apply max 0 fds))
+  (define fd->targets
+    (let ((vec (make-vector (+ 1 max-fd) '())))
+      (for-each (lambda (source-fd dest-fd)
+                  (vector-set! vec source-fd
+                               (cons dest-fd
+                                     (vector-ref vec source-fd))))
+                fds
+                (iota (length fds) base))
+      vec))
+  (define visited (make-vector (+ 1 max-fd) #f))
+
+  (define (rotate-fds! fds)
+    ;; (fdval1 fdval2 fdval3) --> (fdval3 fdval1 fdval2)
+    (match (reverse fds)
+      ((fd0)
+       ;; Clear close-on-exec flag as if it were dup2'ed.
+       (fcntl fd0 F_SETFD 0))
+      ((fd0 . (and rest (fd1 . _)))
+       (let ((tmp-fd (dup->fdes fd0)))
+         (let loop ((fds rest)
+                    (prev fd0))
+           (match fds
+             ((fd . rest)
+              (dup2 fd prev)
+              (loop rest fd))
+             (()
+              (dup2 tmp-fd prev)
+              (close-fdes tmp-fd))))))))
+
+  (define (top-visit fd)
+    (let ((cycle (visit fd fd)))
+      (when cycle
+        (rotate-fds! cycle))))
+
+  (define (visit fd cycle-start-fd)
+    (if (vector-ref visited fd)
+        #f
+        (begin
+          (vector-set! visited fd #t)
+          (let loop ((targets (vector-ref fd->targets fd))
+                     (cycle-tail #f))
+            (match targets
+              ((target . rest)
+               (cond
+                ((= target cycle-start-fd)
+                 (loop rest (list fd)))
+                ((> target max-fd) ;; Has no targets, no need to visit.
+                 (dup2 fd target)
+                 (loop rest cycle-tail))
+                (else
+                 (let ((maybe-cycle-tail (visit target cycle-start-fd)))
+                   (if maybe-cycle-tail
+                       (loop rest (cons fd maybe-cycle-tail))
+                       (begin
+                         (dup2 fd target)
+                         (loop rest cycle-tail)))))))
+              (()
+               cycle-tail))))))
+
+  (for-each top-visit fds))
+
 (define* (exec-command command
                        #:key
                        (user #f)
@@ -1479,48 +1561,38 @@ false."
      (chdir directory)
      (environ environment-variables)
 
-     ;; Close all the file descriptors except stdout and stderr.
-     (let ((max-fd (max-file-descriptors)))
+     ;; Redirect stdin.
+     (catch-system-error (close-fdes 0))
+     ;; Make sure file descriptor zero is used, so we don't end up reusing
+     ;; it for something unrelated, which can confuse some packages.
+     (dup2 (if input-port
+               (fileno input-port)
+               (open-fdes "/dev/null" O_RDONLY))
+           0)
 
-       ;; Redirect stdin.
-       (catch-system-error (close-fdes 0))
-       ;; Make sure file descriptor zero is used, so we don't end up reusing
-       ;; it for something unrelated, which can confuse some packages.
-       (dup2 (if input-port
-                 (fileno input-port)
-                 (open-fdes "/dev/null" O_RDONLY))
-             0)
+     (when (or log-port log-file)
+       (catch #t
+         (lambda ()
+           ;; Redirect stdout and stderr to use LOG-FILE.
+           (catch-system-error (close-fdes 1))
+           (catch-system-error (close-fdes 2))
+           (dup2 (if log-file
+                     (open-fdes log-file (logior O_CREAT O_WRONLY O_APPEND)
+                                #o640)
+                     (fileno log-port))
+                 1)
+           (dup2 1 2)
+
+           ;; Make EXTRA-PORTS available starting from file descriptor 3.
+           ;; This clears their FD_CLOEXEC flag.
+           (reconfigure-fds extra-ports 3))
 
-       (when (or log-port log-file)
-         (catch #t
-           (lambda ()
-             ;; Redirect stout and stderr to use LOG-FILE.
-             (catch-system-error (close-fdes 1))
-             (catch-system-error (close-fdes 2))
-             (dup2 (if log-file
-                       (open-fdes log-file (logior O_CREAT O_WRONLY O_APPEND)
-                                  #o640)
-                       (fileno log-port))
-                   1)
-             (dup2 1 2)
-
-             ;; Make EXTRA-PORTS available starting from file descriptor 3.
-             ;; This clears their FD_CLOEXEC flag.
-             (let loop ((fd    3)
-                        (ports extra-ports))
-               (match ports
-                 (() #t)
-                 ((port rest ...)
-                  (catch-system-error (close-fdes fd))
-                  (dup2 (fileno port) fd)
-                  (loop (+ 1 fd) rest)))))
-
-           (lambda (key . args)
-             (when log-file
-               (format (current-error-port)
-                       "failed to open log-file ~s:~%" log-file))
-             (print-exception (current-error-port) #f key args)
-             (primitive-exit 1))))
+         (lambda (key . args)
+           (when log-file
+             (format (current-error-port)
+                     "failed to open log-file ~s:~%" log-file))
+           (print-exception (current-error-port) #f key args)
+           (primitive-exit 1))))
 
      ;; setgid must be done *before* setuid, otherwise the user will
      ;; likely no longer have permissions to setgid.
@@ -1558,7 +1630,7 @@ false."
          (format (current-error-port)
                  "exec of ~s failed: ~a~%"
                  program (strerror (system-error-errno args)))
-         (primitive-exit 1)))))))
+         (primitive-exit 1))))))
 
 (define %precious-signals
   ;; Signals that the shepherd process handles.
-- 
2.40.1