[bug#65221] [PATCH 1/2] service: make EXTRA-PORTS work as advertised.

[ulfvonbelow <striness@tilde.club>]

EXEC-COMMAND (and, by extension, FORK+EXEC-COMMAND) has several issues:
1. Despite it being documented that "all other file descriptors are closed
   prior to yielding control to COMMAND", this is not currently the case -
   only other file descriptors that are already marked as FD_CLOEXEC are
   closed.  For example, if user code happens to have a file descriptor open,
   for example with call-with-input-file, while EXEC-COMMAND is run, the new
   process image will inherit that file descriptor.  This may cause some
   resource waste, but more importantly may cause security issues in certain
   situations.
2. EXTRA-PORTS is only honored when either LOG-PORT or LOG-FILE is passed.  I
   have no idea why this is the case, it isn't documented anywhere, and it
   isn't intuitive.
3. Even when LOG-PORT or LOG-FILE is passed, 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 many
steps, we've split it, along with marking all file descriptors not being
preserved as FD_CLOEXEC, into a separate procedure named PRESERVE-PORTS.

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

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 68553d4..ffbd03c 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -1434,6 +1434,52 @@ FILE."
   (list->vector (map (lambda (group) (group:gid (getgr group)))
                      supplementary-groups)))
 
+(define (preserve-ports extra-ports)
+  "Duplicate the FDs (fd1 fd2 ... fdN) corresponding to the N ports in
+EXTRA-PORTS into the FD range (3 4 ... 3+N).  This will work regardless of the
+numeric values of fd1 ... fdN.  Any open file descriptors not in EXTRA-PORTS
+and numbered 3 or higher WILL be closed or marked FD_CLOEXEC."
+  ;; We employ the following strategy: copy FDs as high as possible, in
+  ;; descending order of FD, so as to avoid clobbering, then copy the high FDs
+  ;; to low FDs, in the order specified in EXTRA-PORTS.  If more than half of
+  ;; the FD range is included in EXTRA-PORTS, this still won't work, and we
+  ;; may reach a point where copying low will require us to copy the
+  ;; still-uncopied FDs high again.  This should be sufficiently rare as to
+  ;; not be a concern.
+  (let* ((max-fds-count (max-file-descriptors))
+         (highest-fd (- max-fds-count 1))
+         (extra-fds-count (length extra-ports))
+         (preserved-fds-count (+ 3 extra-fds-count))
+         (extra-fds (map fileno extra-ports))
+         (index+fd (map cons
+                        (iota extra-fds-count)
+                        extra-fds))
+         (index+fd-by-fileno (sort index+fd
+                                   (lambda (pair1 pair2)
+                                     (> (cdr pair1)
+                                        (cdr pair2)))))
+         (index2+fd-by-fileno (map cons
+                                   (iota extra-fds-count)
+                                   index+fd-by-fileno))
+         (index2+fd (sort index2+fd-by-fileno
+                          (lambda (spec1 spec2)
+                            (< (second spec1) (second spec2))))))
+    (for-each dup2
+              (map cdr index+fd-by-fileno)
+              (iota extra-fds-count highest-fd -1))
+    (for-each (match-lambda
+                ((by-fileno-index original-index . original-fd)
+                 (dup2 (- highest-fd by-fileno-index)
+                       (+ 3 original-index))))
+              index2+fd)
+    (for-each (lambda (fd)
+                (catch-system-error
+                 (let ((flags (fcntl fd F_GETFD)))
+                   (when (zero? (logand flags FD_CLOEXEC))
+                     (fcntl fd F_SETFD (logior FD_CLOEXEC flags))))))
+              (iota (- max-fds-count preserved-fds-count)
+                    preserved-fds-count))))
+
 (define* (exec-command command
                        #:key
                        (user #f)
@@ -1479,48 +1525,39 @@ 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))
 
-       (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))))
+
+     ;; Close all the file descriptors except stdout, stderr, and EXTRA-PORTS.
+     ;; Make EXTRA-PORTS available starting from file descriptor 3.
+     ;; This clears their FD_CLOEXEC flag.
+     (preserve-ports extra-ports)
 
      ;; setgid must be done *before* setuid, otherwise the user will
      ;; likely no longer have permissions to setgid.
@@ -1558,7 +1595,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