diff options
Diffstat (limited to 'gnu/installer')
| -rw-r--r-- | gnu/installer/newt/partition.scm | 33 | ||||
| -rw-r--r-- | gnu/installer/newt/services.scm | 25 | ||||
| -rw-r--r-- | gnu/installer/parted.scm | 165 | ||||
| -rw-r--r-- | gnu/installer/services.scm | 18 | ||||
| -rw-r--r-- | gnu/installer/steps.scm | 14 | ||||
| -rw-r--r-- | gnu/installer/tests.scm | 48 |
6 files changed, 219 insertions, 84 deletions
diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index 81cf68d782..ea524eb4c3 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -95,14 +95,17 @@ DEVICES list." (define (run-label-page button-text button-callback) "Run a page asking the user to select a partition table label." - (run-listbox-selection-page - #:info-text (G_ "Select a new partition table type. \ + ;; Force the GPT label if UEFI is supported. + (if (efi-installation?) + "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 - #:button-text button-text - #:button-callback-procedure button-callback)) + #:title (G_ "Partition table") + #:listbox-items '("msdos" "gpt") + #:listbox-item->text identity + #:button-text button-text + #:button-callback-procedure button-callback))) (define (run-type-page partition) "Run a page asking the user to select a partition type." @@ -128,7 +131,7 @@ Be careful, all data on the disk will be lost.") (run-listbox-selection-page #:info-text (G_ "Please select the file-system type for this partition.") #:title (G_ "File-system type") - #:listbox-items '(ext4 btrfs fat16 fat32 jfs ntfs swap) + #:listbox-items '(ext4 btrfs fat16 fat32 jfs ntfs xfs swap) #:listbox-item->text user-fs-type-name #:sort-listbox-items? #f #:button-text (G_ "Exit") @@ -640,8 +643,10 @@ edit it." default-result)))) ((partition? item) (if (freespace-partition? item) - (run-error-page (G_ "You cannot delete a free space area.") - (G_ "Delete partition")) + (begin + (run-error-page (G_ "You cannot delete a free space area.") + (G_ "Delete partition")) + default-result) (let* ((disk (partition-disk item)) (number-str (partition-print-number item)) (info-text @@ -706,6 +711,13 @@ by pressing the Exit button.~%~%"))) (run-error-page (G_ "No root mount point found.") (G_ "Missing mount point")) + #f) + ((cannot-read-uuid? c) + (run-error-page + (format #f (G_ "Cannot read the ~a partition UUID.\ + You may need to format it.") + (cannot-read-uuid-partition c)) + (G_ "Wrong partition format")) #f)) (check-user-partitions user-partitions)))) (if user-partitions-ok? @@ -786,6 +798,7 @@ by pressing the Exit button.~%~%"))) (format-user-partitions user-partitions-with-pass) (syslog "formatted ~a user partitions~%" (length user-partitions-with-pass)) + (syslog "user-partitions: ~a~%" user-partitions) (destroy-form-and-pop form) user-partitions)) diff --git a/gnu/installer/newt/services.scm b/gnu/installer/newt/services.scm index 74f28e41ba..1af4e7df2d 100644 --- a/gnu/installer/newt/services.scm +++ b/gnu/installer/newt/services.scm @@ -68,6 +68,28 @@ system.") (condition (&installer-step-abort))))))) +(define (run-other-services-cbt-page) + "Run a page allowing the user to select other services." + (let ((items (filter (lambda (service) + (not (member (system-service-type service) + '(desktop + network-management + networking)))) + %system-services))) + (run-checkbox-tree-page + #:info-text (G_ "You can now select other services to run on your \ +system.") + #:title (G_ "Other services") + #:items items + #:selection (map system-service-recommended? items) + #:item->text (compose G_ system-service-name) + #:checkbox-tree-height 9 + #:exit-button-callback-procedure + (lambda () + (raise + (condition + (&installer-step-abort))))))) + (define (run-network-management-page) "Run a page to select among several network management methods." (let ((title (G_ "Network management"))) @@ -100,4 +122,5 @@ client may be enough for a server.") (run-networking-cbt-page) (if (null? desktop) (list (run-network-management-page)) - '())))) + '()) + (run-other-services-cbt-page)))) diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index 9ef263d1f9..cbe676017b 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -24,8 +24,13 @@ #:use-module (gnu installer newt page) #:use-module (gnu system uuid) #:use-module ((gnu build file-systems) - #:select (read-partition-uuid + #:select (canonicalize-device-spec + find-partition-by-label + read-partition-uuid read-luks-partition-uuid)) + #:use-module ((gnu build linux-boot) + #:select (linux-command-line + find-long-option)) #:use-module ((gnu build linux-modules) #:select (missing-modules)) #:use-module ((gnu system linux-initrd) @@ -70,6 +75,7 @@ small-freespace-partition? esp-partition? boot-partition? + efi-installation? default-esp-mount-point with-delay-device-in-use? @@ -106,6 +112,9 @@ &no-root-mount-point no-root-mount-point? + &cannot-read-uuid + cannot-read-uuid? + cannot-read-uuid-partition check-user-partitions set-user-partitions-file-name @@ -193,12 +202,8 @@ inferior to MAX-SIZE, #f otherwise." (define (esp-partition? partition) "Return #t if partition has the ESP flag, return #f otherwise." (let* ((disk (partition-disk partition)) - (disk-type (disk-disk-type disk)) - (has-extended? (disk-type-check-feature - disk-type - DISK-TYPE-FEATURE-EXTENDED))) + (disk-type (disk-disk-type disk))) (and (data-partition? partition) - (not has-extended?) (partition-is-flag-available? partition PARTITION-FLAG-ESP) (partition-get-flag partition PARTITION-FLAG-ESP)))) @@ -226,6 +231,7 @@ inferior to MAX-SIZE, #f otherwise." ((fat32) "fat32") ((jfs) "jfs") ((ntfs) "ntfs") + ((xfs) "xfs") ((swap) "linux-swap"))) (define (user-fs-type->mount-type fs-type) @@ -233,10 +239,11 @@ inferior to MAX-SIZE, #f otherwise." (case fs-type ((ext4) "ext4") ((btrfs) "btrfs") - ((fat16) "fat") + ((fat16) "vfat") ((fat32) "vfat") ((jfs) "jfs") - ((ntfs) "ntfs"))) + ((ntfs) "ntfs") + ((xfs) "xfs"))) (define (partition-filesystem-user-type partition) "Return the filesystem type of PARTITION, to be stored in the FS-TYPE field @@ -251,6 +258,7 @@ of <user-partition> record." ((string=? name "fat32") 'fat32) ((string=? name "jfs") 'jfs) ((string=? name "ntfs") 'ntfs) + ((string=? name "xfs") 'xfs) ((or (string=? name "swsusp") (string=? name "linux-swap(v0)") (string=? name "linux-swap(v1)")) @@ -337,16 +345,35 @@ fail. See rereadpt function in wipefs.c of util-linux for an explanation." (with-null-output-ports (invoke "dmsetup" "remove_all"))) +(define (installation-device) + "Return the installation device path." + (let* ((cmdline (linux-command-line)) + (root (find-long-option "--root" cmdline))) + (and root + (canonicalize-device-spec (uuid root))))) + (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." - ;; 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))) - (device-is-busy? device))) - (devices))) + "Return all the available devices, except the install device." + (define (read-only? device) + (dynamic-wind + (lambda () + (device-open device)) + (lambda () + (device-read-only? device)) + (lambda () + (device-close device)))) + + ;; If parted reports that a device is read-only it is probably the + ;; installation device. However, as this detection does not always work, + ;; compare the device path to the installation device path read from the + ;; command line. + (let ((install-device (installation-device))) + (remove (lambda (device) + (let ((file-name (device-path device))) + (or (read-only? device) + (and install-device + (string=? file-name install-device))))) + (devices)))) ;; @@ -871,7 +898,7 @@ partition." (format #f "Unable to create partition ~a~%" name))))))))) (define (force-user-partitions-formatting user-partitions) - "Set the NEED-FORMATING? fields to #t on all <user-partition> records of + "Set the NEED-FORMATTING? fields to #t on all <user-partition> records of USER-PARTITIONS list and return the updated list." (map (lambda (p) (user-partition @@ -918,30 +945,26 @@ exists." ;; disk space. Otherwise, set the swap size to 5% of the disk space. (swap-size (min default-swap-size five-percent-disk))) - (if has-extended? - ;; msdos - remove everything. - (disk-remove-all-partitions disk) - ;; gpt - remove everything but esp if it exists. - (for-each - (lambda (partition) - (and (data-partition? partition) - (disk-remove-partition* disk partition))) - non-boot-partitions)) + ;; Remove everything but esp if it exists. + (for-each + (lambda (partition) + (and (data-partition? partition) + (disk-remove-partition* disk partition))) + non-boot-partitions) (let* ((start-partition - (and (not has-extended?) - (if (efi-installation?) - (and (not esp-partition) - (user-partition - (fs-type 'fat32) - (esp? #t) - (size new-esp-size) - (mount-point (default-esp-mount-point)))) + (if (efi-installation?) + (and (not esp-partition) (user-partition - (fs-type 'ext4) - (bootable? #t) - (bios-grub? #t) - (size bios-grub-size))))) + (fs-type 'fat32) + (esp? #t) + (size new-esp-size) + (mount-point (default-esp-mount-point)))) + (user-partition + (fs-type 'ext4) + (bootable? #t) + (bios-grub? #t) + (size bios-grub-size)))) (new-partitions (cond ((or (eq? scheme 'entire-root) @@ -1013,15 +1036,48 @@ exists." (define-condition-type &no-root-mount-point &condition no-root-mount-point?) +;; Cannot not read the partition UUID. +(define-condition-type &cannot-read-uuid &condition + cannot-read-uuid? + (partition cannot-read-uuid-partition)) + (define (check-user-partitions user-partitions) - "Return #t if the USER-PARTITIONS lists contains one <user-partition> record -with a mount-point set to '/', raise &no-root-mount-point condition -otherwise." - (let ((mount-points - (map user-partition-mount-point user-partitions))) - (or (member "/" mount-points) - (raise - (condition (&no-root-mount-point)))))) + "Check the following statements: + +The USER-PARTITIONS list contains one <user-partition> record with a +mount-point set to '/'. Raise &no-root-mount-point condition otherwise. + +All the USER-PARTITIONS with a mount point and that will not be formatted have +a valid UUID. Raise a &cannot-read-uuid condition specifying the faulty +partition otherwise. + +Return #t if all the statements are valid." + (define (check-root) + (let ((mount-points + (map user-partition-mount-point user-partitions))) + (or (member "/" mount-points) + (raise + (condition (&no-root-mount-point)))))) + + (define (check-uuid) + (let ((mount-partitions + (filter user-partition-mount-point user-partitions))) + (every + (lambda (user-partition) + (let ((file-name (user-partition-file-name user-partition)) + (need-formatting? + (user-partition-need-formatting? user-partition))) + (or need-formatting? + (read-partition-uuid file-name) + (raise + (condition + (&cannot-read-uuid + (partition file-name))))))) + mount-partitions))) + + (and (check-root) + (check-uuid) + #t)) (define (set-user-partitions-file-name user-partitions) "Set the partition file-name of <user-partition> records in USER-PARTITIONS @@ -1072,6 +1128,11 @@ bit bucket." (with-null-output-ports (invoke "mkfs.ntfs" "-F" "-f" partition))) +(define (create-xfs-file-system partition) + "Create an XFS file-system for PARTITION file-name." + (with-null-output-ports + (invoke "mkfs.xfs" "-f" partition))) + (define (create-swap-partition partition) "Set up swap area on PARTITION file-name." (with-null-output-ports @@ -1116,7 +1177,7 @@ USER-PARTITION if it is encrypted, or the plain file-name otherwise." (define (format-user-partitions user-partitions) "Format the <user-partition> records in USER-PARTITIONS list with -NEED-FORMATING? field set to #t." +NEED-FORMATTING? field set to #t." (for-each (lambda (user-partition) (let* ((need-formatting? @@ -1153,6 +1214,10 @@ NEED-FORMATING? field set to #t." (and need-formatting? (not (eq? type 'extended)) (create-ntfs-file-system file-name))) + ((xfs) + (and need-formatting? + (not (eq? type 'extended)) + (create-xfs-file-system file-name))) ((swap) (create-swap-partition file-name)) (else @@ -1303,9 +1368,9 @@ from (gnu system mapped-devices) and return it." `((bootloader-configuration ,@(if (efi-installation?) `((bootloader grub-efi-bootloader) - (target ,(default-esp-mount-point))) + (targets (list ,(default-esp-mount-point)))) `((bootloader grub-bootloader) - (target ,root-partition-disk))) + (targets (list ,root-partition-disk)))) ;; XXX: Assume we defined the 'keyboard-layout' field of ;; <operating-system> right above. diff --git a/gnu/installer/services.scm b/gnu/installer/services.scm index ec5ea30594..341d8b69c8 100644 --- a/gnu/installer/services.scm +++ b/gnu/installer/services.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2018 Mathieu Othacehe <[email protected]> ;;; Copyright © 2019 Ludovic Courtès <[email protected]> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <[email protected]> +;;; Copyright © 2021 Tobias Geerinckx-Rice <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,7 +30,6 @@ system-service-packages desktop-system-service? - networking-system-service? %system-services system-services->configuration)) @@ -38,7 +38,7 @@ system-service make-system-service system-service? (name system-service-name) ;string - (type system-service-type) ;'desktop | 'networking + (type system-service-type) ;'desktop|'networking|… (recommended? system-service-recommended? ;Boolean (default #f)) (snippet system-service-snippet ;list of sexps @@ -46,7 +46,6 @@ (packages system-service-packages ;list of sexps (default '()))) -;; This is the list of desktop environments supported as services. (define %system-services (let-syntax ((desktop-environment (syntax-rules () ((_ fields ...) @@ -56,6 +55,7 @@ (G_ (syntax-rules () ;for xgettext ((_ str) str)))) (list + ;; This is the list of desktop environments supported as services. (desktop-environment (name "GNOME") (snippet '((service gnome-desktop-service-type)))) @@ -118,16 +118,18 @@ (system-service (name (G_ "DHCP client (dynamic IP address assignment)")) (type 'network-management) - (snippet '((service dhcp-client-service-type))))))) + (snippet '((service dhcp-client-service-type)))) + + ;; Dealing with documents. + (system-service + (name (G_ "CUPS printing system (no Web interface by default)")) + (type 'document) + (snippet '((service cups-service-type))))))) (define (desktop-system-service? service) "Return true if SERVICE is a desktop environment service." (eq? 'desktop (system-service-type service))) -(define (networking-system-service? service) - "Return true if SERVICE is a desktop environment service." - (eq? 'networking (system-service-type service))) - (define (system-services->configuration services) "Return the configuration field for SERVICES." (let* ((snippets (append-map system-service-snippet services)) diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm index fdcfb0cb4d..c05dfa567a 100644 --- a/gnu/installer/steps.scm +++ b/gnu/installer/steps.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2019 Mathieu Othacehe <[email protected]> -;;; Copyright © 2020 Ludovic Courtès <[email protected]> +;;; Copyright © 2020, 2021 Ludovic Courtès <[email protected]> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ (define-module (gnu installer steps) #:use-module (guix records) #:use-module (guix build utils) + #:use-module (guix i18n) #:use-module (gnu installer utils) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) @@ -234,7 +235,7 @@ found in RESULTS." '()))) steps)) (modules '((use-modules (gnu)) - (use-service-modules desktop networking ssh xorg)))) + (use-service-modules cups desktop networking ssh xorg)))) `(,@modules () (operating-system ,@configuration)))) @@ -245,8 +246,13 @@ found in RESULTS." (mkdir-p (dirname filename)) (call-with-output-file filename (lambda (port) - (format port ";; This is an operating system configuration generated~%") - (format port ";; by the graphical installer.~%") + ;; TRANSLATORS: This is a comment within a Scheme file. Each line must + ;; start with ";; " (two semicolons and a space). Please keep line + ;; length below 60 characters. + (display (G_ "\ +;; This is an operating system configuration generated +;; by the graphical installer.\n") + port) (newline port) (for-each (lambda (part) (if (null? part) diff --git a/gnu/installer/tests.scm b/gnu/installer/tests.scm index f318546a2f..12d1d91608 100644 --- a/gnu/installer/tests.scm +++ b/gnu/installer/tests.scm @@ -37,7 +37,8 @@ enter-host-name+passwords choose-services choose-partitioning - conclude-installation + start-installation + complete-installation edit-configuration-file)) @@ -219,8 +220,9 @@ ROOT-PASSWORD, and USERS." (string-contains service "NSS")))) (choose-network-management-tool? (lambda (service) - (string-contains service "DHCP")))) - "Converse over PORT to choose networking services." + (string-contains service "DHCP"))) + (choose-other-service? (const #f))) + "Converse over PORT to choose services." (define desktop-environments '()) (converse port @@ -239,7 +241,11 @@ ROOT-PASSWORD, and USERS." (multiple-choices? #f) (items ,services)) (null? desktop-environments) - (find choose-network-management-tool? services)))) + (find choose-network-management-tool? services)) + + ((checkbox-list (title "Other services") (text _) + (items ,services)) + (filter choose-other-service? services)))) (define (edit-configuration-file file) "Edit FILE, an operating system configuration file generated by the @@ -281,14 +287,19 @@ instrumented for further testing." (define* (choose-partitioning port #:key (encrypted? #t) + (uefi-support? #f) (passphrase "thepassphrase") (edit-configuration-file 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. + +When UEFI-SUPPORT? is true, assume that we are running the installation tests +on an UEFI capable machine. + 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." +box. " (converse port ((list-selection (title "Partitioning method") (multiple-choices? #f) @@ -306,11 +317,15 @@ box." disks)) ;; The "Partition table" dialog pops up only if there's not already a - ;; partition table. + ;; partition table and if the system does not support UEFI. ((list-selection (title "Partition table") (multiple-choices? #f) (items _)) + ;; When UEFI is supported, the partition is forced to GPT by the + ;; installer. + (not uefi-support?) "gpt") + ((list-selection (title "Partition scheme") (multiple-choices? #f) (items (,one-partition _ ...))) @@ -338,10 +353,10 @@ box." ;; UUIDs before it generates the configuration file. (values)))) -(define (conclude-installation port) - "Conclude the installation by checking over PORT that we get the generated +(define (start-installation port) + "Start 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 +receiving the pause message 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. @@ -355,8 +370,19 @@ completed." (file ,configuration-file)) (edit-configuration-file configuration-file)) ((pause) ;"Press Enter to continue." - #t) - ((installation-complete) ;congratulations! + (values)))) + +(define (complete-installation port) + "Complete the installation by replying to the installer pause message and +waiting for the installation-complete message." + ;; Assume the previous message received was 'pause'; here we send the reply + ;; to that message, which lets the installer continue. + (write #t port) + (newline port) + (force-output port) + + (converse port + ((installation-complete) (values)))) ;;; Local Variables: |