diff options
Diffstat (limited to 'gnu/installer')
| -rw-r--r-- | gnu/installer/dump.scm | 10 | ||||
| -rw-r--r-- | gnu/installer/final.scm | 32 | ||||
| -rw-r--r-- | gnu/installer/hardware.scm | 90 | ||||
| -rw-r--r-- | gnu/installer/newt.scm | 13 | ||||
| -rw-r--r-- | gnu/installer/newt/final.scm | 8 | ||||
| -rw-r--r-- | gnu/installer/newt/network.scm | 11 | ||||
| -rw-r--r-- | gnu/installer/newt/page.scm | 12 | ||||
| -rw-r--r-- | gnu/installer/newt/partition.scm | 18 | ||||
| -rw-r--r-- | gnu/installer/newt/substitutes.scm | 2 | ||||
| -rw-r--r-- | gnu/installer/newt/welcome.scm | 60 | ||||
| -rw-r--r-- | gnu/installer/parted.scm | 55 | ||||
| -rw-r--r-- | gnu/installer/record.scm | 2 | ||||
| -rw-r--r-- | gnu/installer/services.scm | 21 | ||||
| -rw-r--r-- | gnu/installer/steps.scm | 8 | ||||
| -rw-r--r-- | gnu/installer/utils.scm | 74 |
15 files changed, 351 insertions, 65 deletions
diff --git a/gnu/installer/dump.scm b/gnu/installer/dump.scm index daa02f205a..f91cbae021 100644 --- a/gnu/installer/dump.scm +++ b/gnu/installer/dump.scm @@ -28,13 +28,17 @@ #:use-module (web http) #:use-module (web response) #:use-module (webutils multipart) - #:export (prepare-dump + #:export (%core-dump + prepare-dump make-dump send-dump-report)) ;; The installer crash dump type. (define %dump-type "installer-dump") +;; The core dump file. +(define %core-dump "/tmp/installer-core-dump") + (define (result->list result) "Return the alist for the given RESULT." (hash-map->list (lambda (k v) @@ -66,6 +70,10 @@ RESULT is the installer result hash table. Returns the created directory path." ;; syslog (copy-file "/var/log/messages" "syslog") + ;; core dump + (when (file-exists? %core-dump) + (copy-file %core-dump "core-dump")) + ;; dmesg (let ((pipe (open-pipe* OPEN_READ "dmesg"))) (call-with-output-file "dmesg" diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm index 3f6dacc490..069426a3b8 100644 --- a/gnu/installer/final.scm +++ b/gnu/installer/final.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2020 Mathieu Othacehe <[email protected]> -;;; Copyright © 2019, 2020 Ludovic Courtès <[email protected]> +;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -114,6 +114,8 @@ it can interact with the rest of the system." ;; Catch SIGINT and kill the container process. (sigaction SIGINT (lambda (signum) + ;: FIXME: Use of SIGKILL prevents the dynamic-wind exit handler of + ;; THUNK to run. (false-if-exception (kill pid SIGKILL)))) @@ -196,14 +198,16 @@ or #f. Return #t on success and #f on failure." ;; the loaded cow-store locale files will prevent umounting. (install-locale locale) - ;; Save the database, so that it can be restored once the - ;; cow-store is umounted. + ;; Stop the daemon and save the database, so that it can be + ;; restored once the cow-store is umounted. + (stop-service 'guix-daemon) (copy-file database-file saved-database) + + (installer-log-line "mounting copy-on-write store") (mount-cow-store (%installer-target-dir) backing-directory)) (lambda () ;; We need to drag the guix-daemon to the container MNT ;; namespace, so that it can operate on the cow-store. - (stop-service 'guix-daemon) (start-service 'guix-daemon (list (number->string (getpid)))) (setvbuf (current-output-port) 'none) @@ -211,13 +215,27 @@ or #f. Return #t on success and #f on failure." (setenv "PATH" "/run/current-system/profile/bin/") - (set! ret (run-command install-command))) + (set! ret (run-command install-command #:tty? #t))) (lambda () - ;; Restart guix-daemon so that it does no keep the MNT namespace + ;; Stop guix-daemon so that it does no keep the MNT namespace ;; alive. - (restart-service 'guix-daemon) + (stop-service 'guix-daemon) + + ;; Restore the database and restart it. As part of restoring the + ;; database, remove the WAL and shm files in case they were left + ;; behind after guix-daemon was stopped. Failing to do so, + ;; sqlite might behave as if transactions that appear in the WAL + ;; file were committed. (See <https://www.sqlite.org/wal.html>.) + (installer-log-line "restoring store database from '~a'" + saved-database) (copy-file saved-database database-file) + (for-each (lambda (suffix) + (false-if-exception + (delete-file (string-append database-file suffix)))) + '("-wal" "-shm")) + (start-service 'guix-daemon) ;; Finally umount the cow-store and exit the container. + (installer-log-line "unmounting copy-on-write store") (unmount-cow-store (%installer-target-dir) backing-directory) (assert-exit ret)))))))) diff --git a/gnu/installer/hardware.scm b/gnu/installer/hardware.scm new file mode 100644 index 0000000000..cd1a1767d8 --- /dev/null +++ b/gnu/installer/hardware.scm @@ -0,0 +1,90 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Ludovic Courtès <[email protected]> +;;; +;;; 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 +;;; +;;; 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 hardware) + #:use-module (gnu build linux-modules) + #:use-module (guix i18n) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) + #:export (unsupported-pci-device? + pci-device-description)) + +(define %unsupported-linux-modules + ;; List of Linux modules that are useless without non-free firmware. + ;; + ;; Currently only drivers for PCI devices are listed. USB devices such as + ;; "btintel" would require support to list USB devices and read the USB + ;; device ID database. Punt for now as this is usually less critical. + ;; + ;; This list is currently manually maintained based on information on + ;; non-free firmware available from + ;; <https://packages.debian.org/search?keywords=firmware&searchon=names&suite=stable§ion=all>. + '(;; WiFi. + "brcmfmac" + "ipw2100" + "ipw2200" + "iwlwifi" + "mwl8k" + "rtl8188ee" + "rtl818x_pci" + "rtl8192ce" + "rtl8192de" + "rtl8192ee" + + ;; Ethernet. + "bnx2" + "bnx2x" + "liquidio" + + ;; Graphics. + "amdgpu" + "radeon" + + ;; Multimedia. + "ivtv")) + +(define unsupported-pci-device? + ;; Arrange to load the module alias database only once. + (let ((aliases (delay (known-module-aliases)))) + (lambda (device) + "Return true if DEVICE is known to not be supported by free software." + (any (lambda (module) + (member module %unsupported-linux-modules)) + (matching-modules (pci-device-module-alias device) + (force aliases)))))) + +(define (pci-device-description pci-database) + "Return a procedure that, given a PCI device, returns a string describing +it." + (define (with-fallback lookup) + (lambda (vendor-id id) + (let ((vendor name (lookup vendor-id id))) + (values (or vendor (number->string vendor-id 16)) + (or name (number->string id 16)))))) + + (define pci-lookup + (with-fallback (load-pci-device-database pci-database))) + + (lambda (device) + (let ((vendor name (pci-lookup (pci-device-vendor device) + (pci-device-id device)))) + (if (network-pci-device? device) + ;; TRANSLATORS: The two placeholders are the manufacturer + ;; and name of a PCI device. + (format #f (G_ "~a ~a (networking device)") + vendor name) + (string-append vendor " " name))))) diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 1db78e6f0d..e1c4453168 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -62,6 +62,9 @@ (clear-screen)) (define (exit-error error) + ;; Newt may be suspended in the context of the "install-system" + ;; procedure. Resume it unconditionnally. + (newt-resume) (newt-set-color COLORSET-ROOT "white" "red") (define action (run-textbox-page @@ -113,11 +116,7 @@ report it by email to ~a.") uploaded-name %guix-bug-report-address) (define command-output "") (define (line-accumulator line) (set! command-output - (string-append/shared command-output line "\n"))) - (define displayed-command - (string-join - (map (lambda (s) (string-append "\"" s "\"")) args) - " ")) + (string-append/shared command-output line))) (define result (run-external-command-with-line-hooks (list line-accumulator) args)) (define exit-val (status:exit-val result)) @@ -173,8 +172,8 @@ report it by email to ~a.") uploaded-name %guix-bug-report-address) (define (timezone-page zonetab) (run-timezone-page zonetab)) -(define (welcome-page logo) - (run-welcome-page logo)) +(define* (welcome-page logo #:key pci-database) + (run-welcome-page logo #:pci-database pci-database)) (define (menu-page steps) (run-menu-page steps)) diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm index 7c3f73ee82..9f950a0551 100644 --- a/gnu/installer/newt/final.scm +++ b/gnu/installer/newt/final.scm @@ -80,16 +80,20 @@ press the button to reboot."))) (define (run-install-failed-page) (match (current-clients) (() - (match (choice-window + (match (ternary-window (G_ "Installation failed") (G_ "Resume") (G_ "Restart the installer") + (G_ "Report the failure") (G_ "The final system installation step failed. You can resume from \ a specific step, or restart the installer.")) (1 (abort-to-prompt 'installer-step 'abort)) (2 ;; Keep going, the installer will be restarted later on. - #t))) + #t) + (3 (raise + (condition + (&user-abort-error)))))) (_ (send-to-clients '(installation-failure)) #t))) diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm index 0477a489be..ba26fc7c76 100644 --- a/gnu/installer/newt/network.scm +++ b/gnu/installer/newt/network.scm @@ -115,6 +115,11 @@ network devices were found. Do you want to continue anyway?")) (define (wait-service-online) "Display a newt scale until connman detects an Internet access. Do FULL-VALUE tentatives, spaced by 1 second." + (define (url-alive? url) + (false-if-exception + (= (response-code (http-request url)) + 200))) + (define (ci-available?) (dynamic-wind (lambda () @@ -122,10 +127,8 @@ FULL-VALUE tentatives, spaced by 1 second." (lambda _ #f)) (alarm 3)) (lambda () - (false-if-exception - (= (response-code - (http-request "https://ci.guix.gnu.org")) - 200))) + (or (url-alive? "https://ci.guix.gnu.org") + (url-alive? "https://bordeaux.guix.gnu.org"))) (lambda () (alarm 0)))) diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm index 0f508a31c0..e1623a51fd 100644 --- a/gnu/installer/newt/page.scm +++ b/gnu/installer/newt/page.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Mathieu Othacehe <[email protected]> -;;; Copyright © 2019, 2020 Ludovic Courtès <[email protected]> +;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <[email protected]> ;;; Copyright © 2019 Tobias Geerinckx-Rice <[email protected]> ;;; ;;; This file is part of GNU Guix. @@ -278,12 +278,12 @@ input box, such as FLAG-PASSWORD." (destroy-form-and-pop form) input)))))))) -(define (run-error-page text title) - "Run a page to inform the user of an error. The page contains the given TEXT -to explain the error and an \"OK\" button to acknowledge the error. The title -of the page is set to TITLE." +(define* (run-error-page text title #:key (width 40)) + "Run a page to inform the user of an error. The page is WIDTH column wide +and contains the given TEXT to explain the error and an \"OK\" button to +acknowledge the error. The title of the page is set to TITLE." (let* ((text-box - (make-reflowed-textbox -1 -1 text 40 + (make-reflowed-textbox -1 -1 text width #:flags FLAG-BORDER)) (grid (make-grid 1 2)) (ok-button (make-button -1 -1 "OK")) diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index 2adb4922b4..37656696c1 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019 Mathieu Othacehe <[email protected]> +;;; Copyright © 2018, 2019, 2022 Mathieu Othacehe <[email protected]> ;;; Copyright © 2019, 2020 Ludovic Courtès <[email protected]> ;;; Copyright © 2020 Tobias Geerinckx-Rice <[email protected]> ;;; @@ -92,17 +92,31 @@ disk. The installation device as well as the small devices are filtered.") (device (car result))) device)) +(define (run-label-confirmation-page callback) + (lambda (item) + (match (current-clients) + (() + (and (run-confirmation-page + (format #f (G_ "This will create a new ~a partition table, \ +all data on disk will be lost, are you sure you want to proceed?") item) + (G_ "Format disk?") + #:exit-button-procedure callback) + item)) + (_ item)))) + (define (run-label-page button-text button-callback) "Run a page asking the user to select a partition table label." ;; Force the GPT label if UEFI is supported. (if (efi-installation?) - "gpt" + ((run-label-confirmation-page button-callback) "gpt") (run-listbox-selection-page #:info-text (G_ "Select a new partition table type. \ Be careful, all data on the disk will be lost.") #:title (G_ "Partition table") #:listbox-items '("msdos" "gpt") #:listbox-item->text identity + #:listbox-callback-procedure + (run-label-confirmation-page button-callback) #:button-text button-text #:button-callback-procedure button-callback))) diff --git a/gnu/installer/newt/substitutes.scm b/gnu/installer/newt/substitutes.scm index 938cb1a53b..7599d450b6 100644 --- a/gnu/installer/newt/substitutes.scm +++ b/gnu/installer/newt/substitutes.scm @@ -28,7 +28,7 @@ (match (current-clients) (() (case (choice-window - (G_ "Substitute server discovery.") + (G_ "Substitute server discovery") (G_ "Enable") (G_ "Disable") (G_ " By turning this option on, you allow Guix to fetch \ substitutes (pre-built binaries) during installation from servers \ diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm index 7a7ddfb7bd..f821374cb7 100644 --- a/gnu/installer/newt/welcome.scm +++ b/gnu/installer/newt/welcome.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Mathieu Othacehe <[email protected]> -;;; Copyright © 2020 Ludovic Courtès <[email protected]> +;;; Copyright © 2020, 2022 Ludovic Courtès <[email protected]> +;;; Copyright © 2022 Florian Pelz <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,6 +18,11 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu installer newt welcome) + #:use-module ((gnu build linux-modules) + #:select (modules-loaded + pci-devices)) + #:use-module (gnu installer dump) + #:use-module (gnu installer hardware) #:use-module (gnu installer steps) #:use-module (gnu installer utils) #:use-module (gnu installer newt page) @@ -26,6 +32,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 receive) #:use-module (newt) @@ -117,10 +125,52 @@ we want this page to occupy all the screen space available." (lambda () (destroy-form-and-pop form)))))) -(define (run-welcome-page logo) +(define (check-hardware-support pci-database) + "Warn about unsupported devices." + (when (member "uvesafb" (modules-loaded)) + (run-error-page (G_ "\ +This may be a false alarm, but possibly your graphics hardware does not +work well with only free software. Expect trouble. If after installation, +the system does not boot, perhaps you will need to add nomodeset to the +kernel arguments and need to configure the uvesafb kernel module.") + (G_ "Pre-install warning"))) + + (let ((devices (pci-devices))) + (match (filter unsupported-pci-device? devices) + (() ;no unsupported device + #t) + (unsupported + (run-error-page (format #f (G_ "\ +Devices not supported by free software were found on your computer: + +~{ - ~a~%~} +Unfortunately, it means those devices will not be usable. + +To address it, we recommend choosing hardware that respects your freedom as a \ +user--hardware for which free drivers and firmware exist. See \"Hardware \ +Considerations\" in the manual for more information.") + (map (pci-device-description pci-database) + unsupported)) + (G_ "Hardware support warning") + #:width 76))))) + +(define* (run-welcome-page logo #:key pci-database) "Run a welcome page with the given textual LOGO displayed at the center of the page. Ask the user to choose between manual installation, graphical installation and reboot." + (when (file-exists? %core-dump) + (match (choice-window + (G_ "Previous installation failed") + (G_ "Continue") + (G_ "Report the failure") + (G_ "It seems that the previous installation exited unexpectedly \ +and generated a core dump. Do you want to continue or to report the failure \ +first?")) + (1 #t) + (2 (raise + (condition + (&user-abort-error)))))) + (run-menu-page (G_ "GNU Guix install") (G_ "Welcome to GNU Guix system installer! @@ -134,14 +184,16 @@ Documentation is accessible at any time by pressing Ctrl-Alt-F2.") #:listbox-items `((,(G_ "Graphical install using a terminal based interface") . - ,(const #t)) + ,(lambda () + (check-hardware-support pci-database))) (,(G_ "Install using the shell based process") . ,(lambda () + (check-hardware-support pci-database) ;; Switch to TTY3, where a root shell is available for shell based ;; install. The other root TTY's would have been ok too. (system* "chvt" "3") - (run-welcome-page logo))) + (run-welcome-page logo #:pci-database pci-database))) (,(G_ "Reboot") . ,(lambda () diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index fcc936a391..51fa7cf9d9 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -319,6 +319,25 @@ PARTED-OBJECT field equals PARTITION, return #f if not found." partition)) user-partitions)) +(define (read-partition-uuid/retry file-name) + "Call READ-PARTITION-UUID with 5 retries spaced by 1 second. This is useful +if the partition table is updated by the kernel at the time this function is +called, causing the underlying /dev to be absent." + (define max-retries 5) + + (let loop ((retry max-retries)) + (catch #t + (lambda () + (read-partition-uuid file-name)) + (lambda _ + (if (> retry 0) + (begin + (sleep 1) + (loop (- retry 1))) + (error + (format #f (G_ "Could not open ~a after ~a retries~%.") + file-name max-retries))))))) + ;; ;; Devices @@ -360,12 +379,44 @@ fail. See rereadpt function in wipefs.c of util-linux for an explanation." (define %min-device-size (* 2 GIBIBYTE-SIZE)) ;2GiB +(define (mapped-device? device) + "Return #true if DEVICE is a mapped device, false otherwise." + (string-prefix? "/dev/dm-" device)) + +;; TODO: Use DM_TABLE_DEPS ioctl instead of dmsetup. +(define (mapped-device-parent-partition device) + "Return the parent partition path of the mapped DEVICE." + (let* ((command `("dmsetup" "deps" ,device "-o" "devname")) + (parent #f) + (handler + (lambda (input) + ;; We are parsing an output that should look like: + ;; 1 dependencies : (sda2) + (let ((result + (string-match "\\(([^\\)]+)\\)" + (get-string-all input)))) + (and result + (set! parent + (format #f "/dev/~a" + (match:substring result 1)))))))) + (run-external-command-with-handler handler command) + parent)) + (define (eligible-devices) "Return all the available devices except the install device and the devices which are smaller than %MIN-DEVICE-SIZE." (define the-installer-root-partition-path - (installer-root-partition-path)) + (let ((root (installer-root-partition-path))) + (cond + ((mapped-device? root) + ;; If the partition is a mapped device (/dev/dm-X), locate the parent + ;; partition. It is the case when Ventoy is used to host the + ;; installation image. + (let ((parent (mapped-device-parent-partition root))) + (installer-log-line "mapped device ~a -> ~a" parent root) + parent)) + (else root)))) (define (small-device? device) (let ((length (device-length device)) @@ -1108,7 +1159,7 @@ Return #t if all the statements are valid." (need-formatting? (user-partition-need-formatting? user-partition))) (or need-formatting? - (read-partition-uuid file-name) + (read-partition-uuid/retry file-name) (raise (condition (&cannot-read-uuid diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm index 20519a26c3..5e0264682f 100644 --- a/gnu/installer/record.scm +++ b/gnu/installer/record.scm @@ -89,7 +89,7 @@ (partition-page installer-partition-page) ;; procedure void -> void (services-page installer-services-page) - ;; procedure (logo) -> void + ;; procedure (logo #:pci-database) -> void (welcome-page installer-welcome-page) ;; procedure (menu-proc) -> void (parameters-menu installer-parameters-menu) diff --git a/gnu/installer/services.scm b/gnu/installer/services.scm index 6c5f49622f..d08bab47fd 100644 --- a/gnu/installer/services.scm +++ b/gnu/installer/services.scm @@ -159,25 +159,32 @@ (base (if desktop? '%desktop-services '%base-services)) - (heading (list (vertical-space 1) - (comment (G_ "\ + (service-heading (list (vertical-space 1) + (comment (G_ "\ ;; Below is the list of system services. To search for available -;; services, run 'guix system search KEYWORD' in a terminal.\n"))))) +;; services, run 'guix system search KEYWORD' in a terminal.\n")))) + (package-heading (list (vertical-space 1) + (comment (G_ "\ +;; Packages installed system-wide. Users can also install packages +;; under their own account: use 'guix search KEYWORD' to search +;; for packages and 'guix install PACKAGE' to install a package.\n"))))) (if (null? snippets) `(,@(if (null? packages) '() - `((packages (append (list ,@packages) + `(,@package-heading + (packages (append (list ,@packages) %base-packages)))) - ,@heading + ,@service-heading (services ,base)) `(,@(if (null? packages) '() - `((packages (append (list ,@packages) + `(,@package-heading + (packages (append (list ,@packages) %base-packages)))) - ,@heading + ,@service-heading (services (append (list ,@snippets ,@(if desktop? diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm index 8b25ae97c8..0c505e40e4 100644 --- a/gnu/installer/steps.scm +++ b/gnu/installer/steps.scm @@ -28,7 +28,10 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (rnrs io ports) - #:export (<installer-step> + #:export (&user-abort-error + user-abort-error? + + <installer-step> installer-step make-installer-step installer-step? @@ -50,6 +53,9 @@ %current-result)) +(define-condition-type &user-abort-error &error + user-abort-error?) + ;; Hash table storing the step results. Use it only for logging and debug ;; purposes. (define %current-result (make-hash-table)) diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm index 5fd2e2d425..6838410166 100644 --- a/gnu/installer/utils.scm +++ b/gnu/installer/utils.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2020 Mathieu Othacehe <[email protected]> -;;; Copyright © 2019, 2020 Ludovic Courtès <[email protected]> +;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ (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) @@ -45,6 +46,7 @@ nearest-exact-integer read-percentage run-external-command-with-handler + run-external-command-with-handler/tty run-external-command-with-line-hooks run-command run-command-in-installer @@ -124,26 +126,58 @@ the child process as returned by waitpid." (close-port input) (close-pipe dummy-pipe))) -(define (run-external-command-with-line-hooks line-hooks command) +(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. Returns the integer status -value of the child process as returned by waitpid." +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 - (and=> (get-line input) + ;; 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)) + %default-installer-line-hooks)) #t)))) (handler input))) - (run-external-command-with-handler handler command)) + (if tty? + (run-external-command-with-handler/tty handler command) + (run-external-command-with-handler handler command))) -(define* (run-command command) +(define* (run-command command #:key (tty? #f)) "Run COMMAND, a list of strings. Return true if COMMAND exited -successfully, #f otherwise." +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)) @@ -154,8 +188,8 @@ successfully, #f otherwise." (installer-log-line "running command ~s" command) (define result (run-external-command-with-line-hooks - (list %display-line-hook) - command)) + (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)) @@ -232,7 +266,10 @@ values." (or port (%make-void-port "w"))))) (define (%syslog-line-hook line) - (format (syslog-port) "installer[~d]: ~a~%" (getpid) 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) @@ -261,11 +298,7 @@ values." port))) (define (%installer-log-line-hook line) - (format (installer-log-port) "~a~%" line)) - -(define (%display-line-hook line) - (display line) - (newline)) + (display line (installer-log-port))) (define %default-installer-line-hooks (list %syslog-line-hook @@ -277,9 +310,10 @@ values." (syntax-case s () ((_ fmt args ...) (string? (syntax->datum #'fmt)) - #'(let ((formatted (format #f fmt args ...))) - (for-each (lambda (f) (f formatted)) - %default-installer-line-hooks)))))) + (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))))))) ;;; |