diff options
Diffstat (limited to 'gnu/installer/utils.scm')
| -rw-r--r-- | gnu/installer/utils.scm | 158 |
1 files changed, 121 insertions, 37 deletions
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm index 842bd02ced..0a91ae1e4a 100644 --- a/gnu/installer/utils.scm +++ b/gnu/installer/utils.scm @@ -21,7 +21,9 @@ #:use-module (guix utils) #:use-module (guix build utils) #:use-module (guix i18n) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) + #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 format) @@ -30,10 +32,15 @@ read-all nearest-exact-integer read-percentage - run-shell-command + run-command syslog-port - syslog)) + syslog + + with-server-socket + current-server-socket + current-clients + send-to-clients)) (define* (read-lines #:optional (port (current-input-port))) "Read lines from PORT and return them as a list." @@ -61,44 +68,48 @@ number. If no percentage is found, return #f" (and result (string->number (match:substring result 1))))) -(define* (run-shell-command command #:key locale) - "Run COMMAND, a string, with Bash, and in the given LOCALE. Return true if +(define* (run-command command #:key locale) + "Run COMMAND, a list of strings, in the given LOCALE. Return true if COMMAND exited successfully, #f otherwise." + (define env (environ)) + (define (pause) (format #t (G_ "Press Enter to continue.~%")) - (read-line (current-input-port))) - - (call-with-temporary-output-file - (lambda (file port) - (when locale - (let ((supported? (false-if-exception - (setlocale LC_ALL locale)))) - ;; If LOCALE is not supported, then set LANGUAGE, which might at - ;; least give us translated messages. - (if supported? - (format port "export LC_ALL=\"~a\"~%" locale) - (format port "export LANGUAGE=\"~a\"~%" - (string-take locale - (string-index locale #\_)))))) - - (format port "exec ~a~%" command) - (close port) - - (guard (c ((invoke-error? c) - (newline) - (format (current-error-port) - (G_ "Command failed with exit code ~a.~%") - (invoke-error-exit-status c)) - (syslog "command ~s failed with exit code ~a" - command (invoke-error-exit-status c)) - (pause) - #f)) - (syslog "running command ~s~%" command) - (invoke "bash" "--init-file" file) - (syslog "command ~s succeeded~%" command) - (newline) - (pause) - #t)))) + (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") + + (when locale + (let ((supported? (false-if-exception + (setlocale LC_ALL locale)))) + ;; If LOCALE is not supported, then set LANGUAGE, which might at + ;; least give us translated messages. + (if supported? + (setenv "LC_ALL" locale) + (setenv "LANGUAGE" + (string-take locale + (string-index locale #\_)))))) + + (guard (c ((invoke-error? c) + (newline) + (format (current-error-port) + (G_ "Command failed with exit code ~a.~%") + (invoke-error-exit-status c)) + (syslog "command ~s failed with exit code ~a" + command (invoke-error-exit-status c)) + (pause) + #f)) + (syslog "running command ~s~%" command) + (apply invoke command) + (syslog "command ~s succeeded~%" command) + (newline) + (pause) + #t)) ;;; @@ -134,3 +145,76 @@ COMMAND exited successfully, #f otherwise." (with-syntax ((fmt (string-append "installer[~d]: " (syntax->datum #'fmt)))) #'(format (syslog-port) fmt (getpid) args ...)))))) + + +;;; +;;; Client protocol. +;;; + +(define %client-socket-file + ;; Unix-domain socket where the installer accepts connections. + "/var/guix/installer-socket") + +(define current-server-socket + ;; Socket on which the installer is currently accepting connections, or #f. + (make-parameter #f)) + +(define current-clients + ;; List of currently connected clients. + (make-parameter '())) + +(define* (open-server-socket + #:optional (socket-file %client-socket-file)) + "Open SOCKET-FILE as a Unix-domain socket to accept incoming connections and +return it." + (mkdir-p (dirname socket-file)) + (when (file-exists? socket-file) + (delete-file socket-file)) + (let ((sock (socket AF_UNIX SOCK_STREAM 0))) + (bind sock AF_UNIX socket-file) + (listen sock 0) + sock)) + +(define (call-with-server-socket thunk) + (if (current-server-socket) + (thunk) + (let ((socket (open-server-socket))) + (dynamic-wind + (const #t) + (lambda () + (parameterize ((current-server-socket socket)) + (thunk))) + (lambda () + (close-port socket)))))) + +(define-syntax-rule (with-server-socket exp ...) + "Evaluate EXP with 'current-server-socket' parameterized to a currently +accepting socket." + (call-with-server-socket (lambda () exp ...))) + +(define* (send-to-clients exp) + "Send EXP to all the current clients." + (define remainder + (fold (lambda (client remainder) + (catch 'system-error + (lambda () + (write exp client) + (newline client) + (force-output client) + (cons client remainder)) + (lambda args + ;; We might get EPIPE if the client disconnects; when that + ;; happens, remove CLIENT from the set of available clients. + (let ((errno (system-error-errno args))) + (if (memv errno (list EPIPE ECONNRESET ECONNABORTED)) + (begin + (syslog "removing client ~s due to ~s while replying~%" + (fileno client) (strerror errno)) + (false-if-exception (close-port client)) + remainder) + (cons client remainder)))))) + '() + (current-clients))) + + (current-clients (reverse remainder)) + exp) |