diff options
Diffstat (limited to 'gnu/installer')
| -rw-r--r-- | gnu/installer/newt.scm | 1 | ||||
| -rw-r--r-- | gnu/installer/newt/ethernet.scm | 2 | ||||
| -rw-r--r-- | gnu/installer/newt/final.scm | 19 | ||||
| -rw-r--r-- | gnu/installer/newt/network.scm | 2 | ||||
| -rw-r--r-- | gnu/installer/newt/page.scm | 11 | ||||
| -rw-r--r-- | gnu/installer/newt/parameters.scm | 4 | ||||
| -rw-r--r-- | gnu/installer/newt/partition.scm | 20 | ||||
| -rw-r--r-- | gnu/installer/newt/services.scm | 3 | ||||
| -rw-r--r-- | gnu/installer/newt/welcome.scm | 8 | ||||
| -rw-r--r-- | gnu/installer/newt/wifi.scm | 3 | ||||
| -rw-r--r-- | gnu/installer/parted.scm | 115 | ||||
| -rw-r--r-- | gnu/installer/steps.scm | 2 | ||||
| -rw-r--r-- | gnu/installer/tests.scm | 31 | ||||
| -rw-r--r-- | gnu/installer/utils.scm | 14 |
14 files changed, 165 insertions, 70 deletions
diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index fdab721b2f..a1cbeca49a 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -46,6 +46,7 @@ (newt-init) (clear-screen) (set-screen-size!) + (syslog "Display is ~ax~a.~%" (screen-columns) (screen-rows)) (push-help-line (format #f (G_ "Press <F1> for installation parameters.")))) diff --git a/gnu/installer/newt/ethernet.scm b/gnu/installer/newt/ethernet.scm index ba5e222a37..ecd22efbb2 100644 --- a/gnu/installer/newt/ethernet.scm +++ b/gnu/installer/newt/ethernet.scm @@ -77,7 +77,7 @@ connection is pending." #:title (G_ "Ethernet connection") #:listbox-items services #:listbox-item->text ethernet-service->text - #:listbox-height (min (+ (length services) 2) 10) + #:listbox-height (min (+ (length services) 2) 5) #:button-text (G_ "Exit") #:button-callback-procedure (lambda _ diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm index 89684c4d8a..7f6dd9f075 100644 --- a/gnu/installer/newt/final.scm +++ b/gnu/installer/newt/final.scm @@ -29,6 +29,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (ice-9 match) + #:use-module ((ice-9 rdelim) #:select (read-line)) #:use-module (newt) #:export (run-final-page)) @@ -39,9 +40,8 @@ file)) (define* (run-config-display-page #:key locale) - (let ((width (%configuration-file-width)) - (height (nearest-exact-integer - (/ (screen-rows) 2)))) + (let ((width (max 70 (- (screen-columns) 20))) + (height (default-listbox-height))) (run-file-textbox-page #:info-text (format #f (G_ "\ We're now ready to proceed with the installation! \ @@ -107,6 +107,19 @@ a specific step, or restart the installer.")) install-ok?)) (define (run-final-page result prev-steps) + (define (wait-for-clients) + (unless (null? (current-clients)) + (syslog "waiting with clients before starting final step~%") + (send-to-clients '(starting-final-step)) + (match (select (current-clients) '() '()) + (((port _ ...) _ _) + (read-line port))))) + + ;; Before generating the configuration file, give clients a chance to do + ;; things such as changing the swap partition label. + (wait-for-clients) + + (syslog "proceeding with final step~%") (let* ((configuration (format-configuration prev-steps result)) (user-partitions (result-step result 'partition)) (locale (result-step result 'locale)) diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm index 461d5d99c0..4af7143d63 100644 --- a/gnu/installer/newt/network.scm +++ b/gnu/installer/newt/network.scm @@ -80,7 +80,7 @@ network devices were found. Do you want to continue anyway?")) #:title (G_ "Internet access") #:listbox-items items #:listbox-item->text technology->text - #:listbox-height (min (+ (length items) 2) 10) + #:listbox-height (min (+ (length items) 2) 5) #:button-text (G_ "Exit") #:button-callback-procedure (lambda _ diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm index 1d6b9979b4..4209674c28 100644 --- a/gnu/installer/newt/page.scm +++ b/gnu/installer/newt/page.scm @@ -32,7 +32,9 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (newt) - #:export (draw-info-page + #:export (default-listbox-height + + draw-info-page draw-connecting-page run-input-page run-error-page @@ -168,6 +170,10 @@ Like 'run-form', return two values: the exit reason, and an \"argument\"." (_ (values reason argument)))))) +(define (default-listbox-height) + "Return the default listbox height." + (max 5 (- (screen-rows) 20))) + (define (draw-info-page text title) "Draw an informative page with the given TEXT as content. Set the title of this page to TITLE." @@ -339,7 +345,8 @@ of the page is set to TITLE." (info-textbox-width 50) listbox-items listbox-item->text - (listbox-height 20) + (listbox-height + (default-listbox-height)) (listbox-default-item #f) (listbox-allow-multiple? #f) (sort-listbox-items? #t) diff --git a/gnu/installer/newt/parameters.scm b/gnu/installer/newt/parameters.scm index 95112b5780..8fb1aa3abb 100644 --- a/gnu/installer/newt/parameters.scm +++ b/gnu/installer/newt/parameters.scm @@ -20,6 +20,7 @@ #:use-module (gnu installer proxy) #:use-module (gnu installer steps) #:use-module (gnu installer newt page) + #:use-module (guix build syscalls) #:use-module (guix i18n) #:use-module (ice-9 match) #:use-module (newt) @@ -40,7 +41,8 @@ empty string, proxy usage will be disabled.") (let* ((items (list (cons (G_ "Change keyboard layout") keyboard-layout-selection) - (cons (G_ "Configure HTTP proxy") run-proxy-page))) + (cons (G_ "Configure HTTP proxy") run-proxy-page) + (cons (G_ "Reboot") reboot))) (result (run-listbox-selection-page #:info-text (G_ "Please choose one of the following parameters or \ diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index ed38287fe8..81cf68d782 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -25,6 +25,7 @@ #:use-module (gnu installer newt page) #:use-module (gnu installer newt utils) #:use-module (guix i18n) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -56,11 +57,17 @@ #:button-callback-procedure button-exit-action))) (car result))) -(define (draw-formatting-page) +(define (draw-formatting-page partitions) "Draw a page asking for confirmation, and then indicating that partitions are being formatted." - (run-confirmation-page (G_ "We are about to format your hard disk. All \ -its data will be lost. Do you wish to continue?") + ;; TRANSLATORS: The ~{ and ~} format specifiers are used to iterate the list + ;; of device names of the user partitions that will be formatted. + (run-confirmation-page (format #f (G_ "We are about to write the configured \ +partition table to the disk and format the partitions listed below. Their \ +data will be lost. Do you wish to continue?~%~%~{ - ~a~%~}") + (map user-partition-file-name + (filter user-partition-need-formatting? + partitions))) (G_ "Format disk?") #:exit-button-procedure button-exit-action) (draw-info-page @@ -674,7 +681,7 @@ by pressing the Exit button.~%~%"))) (G_ "Guided partitioning") (G_ "Manual partitioning")) #:info-textbox-width 76 ;we need a lot of room for INFO-TEXT - #:listbox-height 12 + #:listbox-height (max 5 (- (screen-rows) 30)) #:listbox-items (disk-items) #:listbox-item->text cdr #:sort-listbox-items? #f @@ -773,9 +780,12 @@ by pressing the Exit button.~%~%"))) (user-partitions (run-page non-install-devices)) (user-partitions-with-pass (prompt-luks-passwords user-partitions)) - (form (draw-formatting-page))) + (form (draw-formatting-page user-partitions))) ;; Make sure the disks are not in use before proceeding to formatting. (free-parted non-install-devices) (format-user-partitions user-partitions-with-pass) + (syslog "formatted ~a user partitions~%" + (length user-partitions-with-pass)) + (destroy-form-and-pop form) user-partitions)) diff --git a/gnu/installer/newt/services.scm b/gnu/installer/newt/services.scm index 6d431cb4bb..ae249ba972 100644 --- a/gnu/installer/newt/services.scm +++ b/gnu/installer/newt/services.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> -;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -77,6 +77,7 @@ system.") We recommend NetworkManager or Connman for a WiFi-capable laptop; the DHCP \ client may be enough for a server.") #:info-textbox-width 70 + #:listbox-height 7 #:listbox-items (filter (lambda (service) (eq? 'network-management (system-service-type service))) diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm index 1b4b2df816..5f461279e2 100644 --- a/gnu/installer/newt/welcome.scm +++ b/gnu/installer/newt/welcome.scm @@ -38,6 +38,9 @@ (define info-textbox-width (make-parameter 70)) (define options-listbox-height (make-parameter 5)) +(define (display-logo?) + (> (screen-rows) 35)) + (define* (run-menu-page title info-text logo #:key listbox-items @@ -55,7 +58,10 @@ we want this page to occupy all the screen space available." items)) (let* ((logo-textbox - (make-textbox -1 -1 (logo-width) (logo-height) 0)) + (make-textbox -1 -1 + (if (display-logo?) (logo-width) 0) + (if (display-logo?) (logo-height) 0) + 0)) (info-textbox (make-reflowed-textbox -1 -1 info-text diff --git a/gnu/installer/newt/wifi.scm b/gnu/installer/newt/wifi.scm index 3fd5756b99..f5d8f1fdbf 100644 --- a/gnu/installer/newt/wifi.scm +++ b/gnu/installer/newt/wifi.scm @@ -165,7 +165,8 @@ of <service-item> records present in LISTBOX." (define service-name-max-length (make-parameter 20)) ;; Height of the listbox displaying wifi services. -(define wifi-listbox-height (make-parameter 20)) +(define wifi-listbox-height (make-parameter + (default-listbox-height))) ;; Information textbox width. (define info-textbox-width (make-parameter 40)) diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index b0c73b837e..9ef263d1f9 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -36,10 +36,12 @@ #:use-module (guix utils) #:use-module (guix i18n) #:use-module (parted) + #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -317,7 +319,7 @@ PARTED-OBJECT field equals PARTITION, return #f if not found." fail. See rereadpt function in wipefs.c of util-linux for an explanation." ;; Kernel always return EINVAL for BLKRRPART on loopdevices. (and (not (string-match "/dev/loop*" file-name)) - (let loop ((try 4)) + (let loop ((try 16)) (usleep 250000) (let ((in-use? (device-in-use? file-name))) (if (and in-use? (> try 0)) @@ -338,15 +340,12 @@ fail. See rereadpt function in wipefs.c of util-linux for an explanation." (define (non-install-devices) "Return all the available devices, except the busy one, allegedly the install device. DEVICE-IS-BUSY? is a parted call, checking if the device is -mounted. The install image uses an overlayfs so the install device does not -appear as mounted and won't be considered as busy. So use also DEVICE-IN-USE? -from (guix build syscalls) module, who will try to re-read the device's -partition table to determine whether or not it is already used (like sfdisk -from util-linux)." +mounted." + ;; FIXME: The install image uses an overlayfs so the install device does not + ;; appear as mounted and won't be considered as busy. (remove (lambda (device) (let ((file-name (device-path device))) - (or (device-is-busy? device) - (with-delay-device-in-use? file-name)))) + (device-is-busy? device))) (devices))) @@ -526,56 +525,54 @@ determined by MAX-LENGTH-COLUMN procedure." (size (user-partition-size user-partition)) (mount-point (user-partition-mount-point user-partition))) `(,@(if has-name? - `((name . ,(string-append "Name: " (or name "None")))) + `((name . ,(format #f (G_ "Name: ~a") + (or name (G_ "None"))))) '()) ,@(if (and has-extended? (freespace-partition? partition) (not (eq? type 'logical))) - `((type . ,(string-append "Type: " type-name))) + `((type . ,(format #f (G_ "Type: ~a") type-name))) '()) ,@(if (eq? type 'extended) '() - `((fs-type . ,(string-append "Filesystem type: " fs-type-name)))) + `((fs-type . ,(format #f (G_ "File system type: ~a") + fs-type-name)))) ,@(if (or (eq? type 'extended) (eq? fs-type 'swap) (not has-extended?)) '() - `((bootable . ,(string-append "Bootable flag: " - (if bootable? "On" "Off"))))) + `((bootable . ,(format #f (G_ "Bootable flag: ~:[off~;on~]") + bootable?)))) ,@(if (and (not has-extended?) (not (eq? fs-type 'swap))) - `((esp? . ,(string-append "ESP flag: " - (if esp? "On" "Off")))) + `((esp? . ,(format #f (G_ "ESP flag: ~:[off~;on~]") esp?))) '()) ,@(if (freespace-partition? partition) (let ((size-formatted - (or size (unit-format device + (or size (unit-format device ;XXX: i18n (partition-length partition))))) - `((size . ,(string-append "Size : " size-formatted)))) + `((size . ,(format #f (G_ "Size: ~a") size-formatted)))) '()) ,@(if (or (eq? type 'extended) (eq? fs-type 'swap)) '() `((crypt-label - . ,(string-append - "Encryption: " - (if crypt-label - (format #f "Yes (label ~a)" crypt-label) - "No"))))) + . ,(format #f (G_ "Encryption: ~:[No~a~;Yes (label '~a')~]") + crypt-label (or crypt-label ""))))) ,@(if (or (freespace-partition? partition) (eq? fs-type 'swap)) '() `((need-formatting? - . ,(string-append "Format the partition? : " - (if need-formatting? "Yes" "No"))))) + . ,(format #f (G_ "Format the partition? ~:[No~;Yes~]") + need-formatting?)))) ,@(if (or (eq? type 'extended) (eq? fs-type 'swap)) '() `((mount-point - . ,(string-append "Mount point : " - (or mount-point - (and esp? (default-esp-mount-point)) - "None")))))))) + . ,(format #f (G_ "Mount point: ~a") + (or mount-point + (and esp? (default-esp-mount-point)) + (G_ "None"))))))))) ;; @@ -759,11 +756,33 @@ cause them to cross." dev-constraint)) (no-constraint (constraint-any device)) ;; Try to create a partition with an optimal alignment - ;; constraint. If it fails, fallback to creating a partition with - ;; no specific constraint. + ;; constraint. If it fails, fallback to creating a partition + ;; with no specific constraint. + (partition-constraint-ok? + (disk-add-partition disk partition final-constraint)) + (partition-no-contraint-ok? + (or partition-constraint-ok? + (disk-add-partition disk partition no-constraint))) (partition-ok? - (or (disk-add-partition disk partition final-constraint) - (disk-add-partition disk partition no-constraint)))) + (or partition-constraint-ok? partition-no-contraint-ok?))) + (syslog "Creating partition: +~/type: ~a +~/filesystem-type: ~a +~/start: ~a +~/end: ~a +~/start-range: [~a, ~a] +~/end-range: [~a, ~a] +~/constraint: ~a +~/no-constraint: ~a +" + partition-type + (filesystem-type-name filesystem-type) + start-sector* + end-sector + (geometry-start start-range) (geometry-end start-range) + (geometry-start end-range) (geometry-end end-range) + partition-constraint-ok? + partition-no-contraint-ok?) ;; Set the partition name if supported. (when (and partition-ok? has-name? name) (partition-set-name partition name)) @@ -911,13 +930,13 @@ exists." (let* ((start-partition (and (not has-extended?) - (not esp-partition) (if (efi-installation?) - (user-partition - (fs-type 'fat32) - (esp? #t) - (size new-esp-size) - (mount-point (default-esp-mount-point))) + (and (not esp-partition) + (user-partition + (fs-type 'fat32) + (esp? #t) + (size new-esp-size) + (mount-point (default-esp-mount-point)))) (user-partition (fs-type 'ext4) (bootable? #t) @@ -1327,7 +1346,12 @@ USER-PARTITIONS, or return nothing." ,@(initrd-configuration user-partitions) ,@(if (null? swap-devices) '() - `((swap-devices (list ,@swap-devices)))) + (let* ((uuids (map (lambda (file) + (uuid->string (read-partition-uuid file))) + swap-devices))) + `((swap-devices (list ,@(map (lambda (uuid) + `(uuid ,uuid)) + uuids)))))) ,@(if (null? encrypted-partitions) '() `((mapped-devices @@ -1364,9 +1388,12 @@ the devices not to be used before returning." (let ((device-file-names (map device-path devices))) (for-each force-device-sync devices) (for-each (lambda (file-name) - (let ((in-use? (with-delay-device-in-use? file-name))) - (and in-use? - (error - (format #f (G_ "Device ~a is still in use.") - file-name))))) + (let/time ((time in-use? + (with-delay-device-in-use? file-name))) + (if in-use? + (error + (format #f (G_ "Device ~a is still in use.") + file-name)) + (syslog "Syncing ~a took ~a seconds.~%" + file-name (time-second time))))) device-file-names))) diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm index 16d74c207f..fdcfb0cb4d 100644 --- a/gnu/installer/steps.scm +++ b/gnu/installer/steps.scm @@ -50,7 +50,6 @@ %installer-configuration-file %installer-target-dir - %configuration-file-width format-configuration configuration->file)) @@ -218,7 +217,6 @@ stored in RESULTS. Return #f otherwise." (define %installer-configuration-file (make-parameter "/mnt/etc/config.scm")) (define %installer-target-dir (make-parameter "/mnt")) -(define %configuration-file-width (make-parameter 79)) (define (format-configuration steps results) "Return the list resulting from the application of the procedure defined in diff --git a/gnu/installer/tests.scm b/gnu/installer/tests.scm index 58bf0a2700..f318546a2f 100644 --- a/gnu/installer/tests.scm +++ b/gnu/installer/tests.scm @@ -286,8 +286,9 @@ instrumented for further testing." edit-configuration-file)) "Converse over PORT to choose the partitioning method. When ENCRYPTED? is true, choose full-disk encryption with PASSPHRASE as the LUKS passphrase. -This conversation goes past the final dialog box that shows the configuration -file, actually starting the installation process." +This conversation stops when the user partitions have been formatted, right +before the installer generates the configuration file and shows it in a dialog +box." (converse port ((list-selection (title "Partitioning method") (multiple-choices? #f) @@ -330,15 +331,29 @@ file, actually starting the installation process." #t) ((info (title "Preparing partitions") _ ...) (values)) ;nothing to return - ((file-dialog (title "Configuration file") - (text _) - (file ,configuration-file)) - (edit-configuration-file configuration-file)))) + ((starting-final-step) + ;; Do not return anything. The reply will be sent by + ;; 'conclude-installation' and in the meantime the installer just waits + ;; for us, giving us a chance to do things such as changing partition + ;; UUIDs before it generates the configuration file. + (values)))) (define (conclude-installation port) - "Conclude the installation by checking over PORT that we get the final -messages once the 'guix system init' process has completed." + "Conclude the installation by checking over PORT that we get the generated +configuration file, accepting it and starting the installation, and then +receiving the final messages once the 'guix system init' process has +completed." + ;; Assume the previous message received was 'starting-final-step'; here we + ;; send the reply to that message, which lets the installer continue. + (write #t port) + (newline port) + (force-output port) + (converse port + ((file-dialog (title "Configuration file") + (text _) + (file ,configuration-file)) + (edit-configuration-file configuration-file)) ((pause) ;"Press Enter to continue." #t) ((installation-complete) ;congratulations! diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm index 5f8fe8ca01..a7fa66a199 100644 --- a/gnu/installer/utils.scm +++ b/gnu/installer/utils.scm @@ -22,6 +22,7 @@ #:use-module (guix build utils) #:use-module (guix i18n) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-34) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -36,6 +37,8 @@ syslog-port syslog + call-with-time + let/time with-server-socket current-server-socket @@ -117,6 +120,17 @@ COMMAND exited successfully, #f otherwise." ;;; 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))) |