@@ -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?)
;;;