;;; GNU Gu;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu installer utils) #:use-module (gnu services herd) #:use-module (guix utils) #:use-module ((guix build syscalls) #:select (openpty login-tty)) #:use-module (guix build utils) #:use-module (guix i18n) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-19) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #: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) #:use-module (ice-9 textual-ports) #:export (<secret> secret? make-secret secret-content read-lines read-all nearest-exact-integer read-percentage run-external-command-with-handler run-external-command-with-handler/tty run-external-command-with-line-hooks dry-run-command run-command %run-command-in-installer syslog-port %syslog-line-hook installer-log-port %installer-log-line-hook %default-installer-line-hooks installer-log-line call-with-time let/time with-server-socket current-server-socket current-clients send-to-clients with-silent-shepherd)) (define-record-type <secret> (make-secret content) secret? (content secret-content)) (set-record-type-printer! <secret> (lambda (secret port) (format port "<secret>"))) (define* (read-lines #:optional (port (current-input-port))) "Read lines from PORT and return them as a list." (let loop ((line (read-line port)) (lines '())) (if (eof-object? line) (reverse lines) (loop (read-line port) (cons line lines))))) (define (read-all file) "Return the content of the given FILE as a string." (call-with-input-file file get-string-all)) (define (nearest-exact-integer x) "Given a real number X, return the nearest exact integer, with ties going to the nearest exact even integer." (inexact->exact (round x))) (define (read-percentage percentage) "Read PERCENTAGE string and return the corresponding percentage as a number. If no percentage is found, return #f" (let ((result (string-match "^([0-9]+)%$" percentage))) (and result (string->number (match:substring result 1))))) (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))) ;; Hack to work around Guile bug 52835 (define dup-output (duplicate-port output "w")) ;; Void pipe, but holds the pid for close-pipe. (define dummy-pipe (with-input-from-file "/dev/null" (lambda () (with-output-to-port output (lambda () (with-error-to-port dup-output (lambda () (apply open-pipe* (cons "" command))))))))) (close-port output) (close-port dup-output) (handler input) (close-port input) (close-pipe dummy-pipe))) (define (run-external-command-with-handler/tty handler command) "Run command specified by the list COMMAND in a child operating in a pseudoterminal 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." (define-values (controller inferior) (openpty)) (match (primitive-fork) (0 (catch #t (lambda () (close-fdes controller) (login-tty inferior) (apply execlp (car command) command)) (lambda _ (primitive-exit 127)))) (pid (close-fdes inferior) (let* ((port (fdopen controller "r0")) (result (false-if-exception (handler port)))) (close-port port) (cdr (waitpid pid)))))) (define* (run-external-command-with-line-hooks line-hooks command #:key (tty? #false)) "Run command specified by the list COMMAND in a child, processing each output line with the procedures in LINE-HOOKS. If TTY is set to #true, the COMMAND will be run in a pseudoterminal. Returns the integer status value of the child process as returned by waitpid." (define (handler input) (and ;; Lines for progress bars etc. end in \r; treat is as a line ending so ;; those lines are printed right away. (and=> (read-delimited "\r\n" input 'concat) (lambda (line) (if (eof-object? line) #f (begin (for-each (lambda (f) (f line)) (append line-hooks %default-installer-line-hooks)) #t)))) (handler input))) (if tty? (run-external-command-with-handler/tty handler command) (run-external-command-with-handler handler command))) (define* (run-command command #:key (tty? #f)) "Run COMMAND, a list of strings. Return true if COMMAND exited successfully, #f otherwise. If TTY is set to #true, the COMMAND will be run in a pseudoterminal." (define (pause) (format #t (G_ "Press Enter to continue.~%")) (send-to-clients '(pause)) (match (select (cons (current-input-port) (current-clients)) '() '()) (((port _ ...) _ _) (read-line port)))) (installer-log-line "running command ~s" command) (define result (run-external-command-with-line-hooks (list display) command #:tty? tty?)) (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?) (define (dry-run-command . args) (format #t "dry-run-command: skipping: ~a\n" args)) (define %run-command-in-installer (make-parameter (lambda (. args) (raise (condition (&serious) (&message (message "%run-command-in-installer not set")))))))  ;;; ;;; Logging. ;;; (define (call-with-time thunk kont) "Call THUNK and pass KONT the elapsed time followed by THUNK's return values." (let* ((start (current-time time-monotonic)) (result (call-with-values thunk list)) (end (current-time time-monotonic))) (apply kont (time-difference end start) result))) (define-syntax-rule (let/time ((time result exp)) body ...) (call-with-time (lambda () exp) (lambda (time result) body ...))) (define (open-syslog-port) "Return an open port (a socket) to /dev/log or #f if that wasn't possible." (let ((sock (socket AF_UNIX SOCK_DGRAM 0))) (catch 'system-error (lambda () (connect sock AF_UNIX "/dev/log") (setvbuf sock 'line) sock) (lambda args (close-port sock) #f)))) (define syslog-port (let ((port #f)) (lambda () "Return an output port to syslog." (unless port (set! port (open-syslog-port))) (or port (%make-void-port "w"))))) (define (%syslog-line-hook line) (let ((line (if (string-suffix? "\r" line) (string-append (string-drop-right line 1) "\n") line))) (format (syslog-port) "installer[~d]: ~a" (getpid) line))) (define-syntax syslog (lambda (s) "Like 'format', but write to syslog." (syntax-case s () ((_ fmt args ...) (string? (syntax->datum #'fmt)) (with-syntax ((fmt (string-append "installer[~d]: " (syntax->datum #'fmt)))) #'(format (syslog-port) fmt (getpid) args ...)))))) (define (open-new-log-port) (define now (localtime (time-second (current-time)))) (define file-name (format #f "/tmp/installer.~a.log" (strftime "%F.%T" now))) (open file-name (logior O_RDWR O_CREAT))) (define installer-log-port (let ((port #f)) (lambda () "Return an input and output port to the installer log." (unless port (set! port (open-new-log-port))) port))) (define (%installer-log-line-hook line) (display line (installer-log-port))) (define %default-installer-line-hooks (list %syslog-line-hook %installer-log-line-hook)) (define-syntax installer-log-line (lambda (s) "Like 'format', but uses the default line hooks, and only formats one line." (syntax-case s () ((_ fmt args ...) (string? (syntax->datum #'fmt)) (with-syntax ((fmt (string-append (syntax->datum #'fmt) "\n"))) #'(let ((formatted (format #f fmt args ...))) (for-each (lambda (f) (f formatted)) %default-installer-line-hooks)))))))  ;;; ;;; 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-fi-void-port "w"))) (write-file input output) #t)) (test-equal "write-file puts file in C locale collation order" (base32 "0sfn5r63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3") (let ((input (string-append %test-dir ".input"))) (dynamic-wind (lambda () (define (touch file) (call-with-output-file (string-append input "/" file) (const #t))) (mkdir input) (touch "B") (touch "Z") (touch "a") (symlink "B" (string-append input "/z"))) (lambda () (let-values (((port get-hash) (open-sha256-port))) (write-file input port) (close-port port) (get-hash))) (lambda () (rm-rf input))))) (test-equal "restore-file with incomplete input" (string-append %test-dir "/foo") (let ((port (open-bytevector-input-port #vu8(1 2 3)))) (guard (c ((nar-error? c) (and (eq? port (nar-error-port c)) (nar-error-file c)))) (restore-file port (string-append %test-dir "/foo")) #f))) (test-assert "write-file + restore-file" (let* ((input (string-append (dirname (search-path %load-path "guix.scm")) "/guix")) (output %test-dir) (nar (string-append output ".nar"))) (dynamic-wind (lambda () #t) (lambda () (call-with-output-file nar (cut write-file input <>)) (call-with-input-file nar (cut restore-file <> output)) (file-tree-equal? input output)) (lambda () (false-if-exception (delete-file nar)) (false-if-exception (rm-rf output)))))) (test-assert "write-file + restore-file with symlinks" (let ((input