[bug#53063] [PATCH wip-harden-installer 05/14] installer: Capture external commands output.

[Josselin Poiret]

* gnu/installer/utils.scm (close-fdes-ignore-badf, reset-fds,
run-external-command-with-handler,
run-external-command-with-line-hooks): New variables.
(run-command): Use run-external-command-with-line-hooks.
---
 gnu/installer/utils.scm | 154 ++++++++++++++++++++++++++++++++++------
 1 file changed, 134 insertions(+), 20 deletions(-)

diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index 1bff1e1229..878434f074 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -25,7 +25,9 @@ (define-module (gnu installer utils)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-34)
+  #:use-module (ice-9 control)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
@@ -78,37 +80,149 @@ (define (read-percentage percentage)
     (and result
          (string->number (match:substring result 1)))))
 
+;; This is needed because there are two close procedures in Guile:
+;; * close, which relocates ports that were using the fd to use a
+;;   newly dup'd fd;
+;; * vanilla close-fdes, which does not ignore EBADF, making it
+;;   impossible to use it to close all ports.
+(define (close-fdes-ignore-badf fd)
+  (let/ec escape
+    (with-exception-handler
+        (lambda (exn)
+          (if (eq? (exception-kind exn) 'system-error)
+              (let ((args (exception-args exn)))
+                (if (eq? (car (car (cdr (cdr (cdr args)))))
+                              9) ;; EBADF
+                    (escape)
+                    (raise-exception exn)))
+              (raise-exception exn)))
+      (lambda ()
+        (close-fdes fd)))))
+
+(define (reset-fds in out err)
+  "Resets the stdin, stdout and stderr to IN, OUT and ERR
+respectively, while closing all other open file descriptors."
+  ;; getrlimit is undocumented, but defined in
+  ;; libguile/posix.c.
+  (define maxfds (getrlimit 'nofile))
+  (let loop ((fd 0))
+    (and (< fd maxfds)
+         (begin (unless (or (eq? in fd)
+                            (eq? out fd)
+                            (eq? err fd))
+                  (close-fdes-ignore-badf fd))
+                (loop (+ fd 1)))))
+  (define (next-available fd)
+    (and (< fd maxfds)
+         (if (or (eq? in fd)
+                 (eq? out fd)
+                 (eq? err fd))
+             (next-available (+ fd 1))
+             fd)))
+  (define dupin (next-available 3))
+  (define dupout (next-available (+ dupin 1)))
+  (define duperr (next-available (+ dupout 1)))
+  (dup2 in dupin)
+  (dup2 out dupout)
+  (dup2 err duperr)
+  (for-each close-fdes-ignore-badf (list in out err))
+  (dup2 dupin 0)
+  (dup2 dupout 1)
+  (dup2 duperr 2)
+  (for-each close-fdes (list dupin dupout duperr))
+  (set-current-input-port (fdes->inport 0))
+  (set-current-output-port (fdes->outport 1))
+  (set-current-error-port (fdes->outport 2)))
+
+(define* (run-external-command-with-handler handler command)
+    "Run command specified by the list COMMAND in a child with output handler
+HANDLER.  HANDLER is a procedure taking an input port, to which the command
+will write its standard output and error.  Returns the integer status value of
+the child process as returned by waitpid."
+  (match-let (((input . output) (pipe)))
+    (match (primitive-fork)
+      (0 ;; We're in the child
+       (close-port input)
+       (reset-fds
+        (open-fdes "/dev/null" O_WRONLY)
+        ;; Avoid port GC'ing closing the fd by increasing its revealed count.
+        (port->fdes output)
+        (fileno output))
+       (with-exception-handler
+           (lambda (exn)
+             ((@@ (ice-9 exceptions) format-exception) (current-error-port)
+              exn)
+             (primitive-_exit 1))
+         (lambda ()
+           (apply execlp (car command) command)
+           (primitive-_exit 1))))
+      (pid
+       (close-port output)
+       (handler input)
+       (close-port input)
+       (cdr (waitpid pid))))))
+
+(define (run-external-command-with-line-hooks line-hooks command)
+  "Run command specified by ARGS in a child, processing each output line with
+the procedures in LINE-HOOKS.  Returns the integer status value of
+the child process as returned by waitpid."
+  (define (handler input)
+    (and (and=> (get-line input)
+                (lambda (line)
+                  (if (eof-object? line)
+                      #f
+                      (begin (for-each (lambda (f) (f line))
+                                (append line-hooks
+                                    %default-installer-line-hooks))
+                             #t))))
+         (handler input)))
+  (run-external-command-with-handler handler command))
+
 (define* (run-command command)
   "Run COMMAND, a list of strings.  Return true if COMMAND exited
 successfully, #f otherwise."
-  (define env (environ))
-
   (define (pause)
     (format #t (G_ "Press Enter to continue.~%"))
     (send-to-clients '(pause))
-    (environ env)                               ;restore environment variables
     (match (select (cons (current-input-port) (current-clients))
              '() '())
       (((port _ ...) _ _)
        (read-line port))))
 
-  (setenv "PATH" "/run/current-system/profile/bin")
-
-  (guard (c ((invoke-error? c)
-             (newline)
-             (format (current-error-port)
-                     (G_ "Command failed with exit code ~a.~%")
-                     (invoke-error-exit-status c))
-             (installer-log-line "command ~s failed with exit code ~a"
-                                 command (invoke-error-exit-status c))
-             (pause)
-             #f))
-    (installer-log-line "running command ~s" command)
-    (apply invoke command)
-    (installer-log-line "command ~s succeeded" command)
-    (newline)
-    (pause)
-    #t))
+  (installer-log-line "running command ~s" command)
+  (define result (run-external-command-with-line-hooks
+                  (list %display-line-hook)
+                  command))
+  (define exit-val (status:exit-val result))
+  (define term-sig (status:term-sig result))
+  (define stop-sig (status:stop-sig result))
+  (define succeeded?
+    (cond
+     ((and exit-val (not (zero? exit-val)))
+      (installer-log-line "command ~s exited with value ~a"
+                          command exit-val)
+      (format #t (G_ "Command ~s exited with value ~a")
+              command exit-val)
+      #f)
+     (term-sig
+      (installer-log-line "command ~s killed by signal ~a"
+                          command term-sig)
+      (format #t (G_ "Command ~s killed by signal ~a")
+              command term-sig)
+      #f)
+     (stop-sig
+      (installer-log-line "command ~s stopped by signal ~a"
+                          command stop-sig)
+      (format #t (G_ "Command ~s stopped by signal ~a")
+              command stop-sig)
+      #f)
+     (else
+      (installer-log-line "command ~s succeeded" command)
+      (format #t (G_ "Command ~s succeeded") command)
+      #t)))
+  (newline)
+  (pause)
+  succeeded?)
 
 
 ;;;
-- 
2.34.0