diff options
Diffstat (limited to 'gnu/installer')
| -rw-r--r-- | gnu/installer/newt/keymap.scm | 13 | ||||
| -rw-r--r-- | gnu/installer/newt/page.scm | 38 | ||||
| -rw-r--r-- | gnu/installer/newt/partition.scm | 8 | ||||
| -rw-r--r-- | gnu/installer/parted.scm | 55 | ||||
| -rw-r--r-- | gnu/installer/services.scm | 6 |
5 files changed, 106 insertions, 14 deletions
diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm index 3e765bfdd4..948b54783c 100644 --- a/gnu/installer/newt/keymap.scm +++ b/gnu/installer/newt/keymap.scm @@ -1,5 +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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,7 +28,9 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:export (run-keymap-page)) + #:use-module (ice-9 match) + #:export (run-keymap-page + keyboard-layout->configuration)) (define (run-layout-page layouts layout->text) (let ((title (G_ "Layout"))) @@ -120,3 +123,11 @@ names of the selected keyboard layout and variant." (list layout (or variant "")))) (format-result (run-installer-steps #:steps keymap-steps))) + +(define (keyboard-layout->configuration keymap) + "Return the operating system configuration snippet to install KEYMAP." + (match keymap + ((name "") + `((keyboard-layout (keyboard-layout ,name)))) + ((name variant) + `((keyboard-layout (keyboard-layout ,name ,variant)))))) diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm index 23fbfcce76..8b3fd488e9 100644 --- a/gnu/installer/newt/page.scm +++ b/gnu/installer/newt/page.scm @@ -1,5 +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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +30,7 @@ draw-connecting-page run-input-page run-error-page + run-confirmation-page run-listbox-selection-page run-scale-page run-checkbox-tree-page @@ -141,6 +143,42 @@ of the page is set to TITLE." (newt-set-color COLORSET-ROOT "white" "blue") (destroy-form-and-pop form))) +(define* (run-confirmation-page text title + #:key (exit-button-procedure (const #f))) + "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." + (let* ((text-box + (make-reflowed-textbox -1 -1 text 40 + #:flags FLAG-BORDER)) + (ok-button (make-button -1 -1 (G_ "Continue"))) + (exit-button (make-button -1 -1 (G_ "Exit"))) + (grid (vertically-stacked-grid + GRID-ELEMENT-COMPONENT text-box + GRID-ELEMENT-SUBGRID + (horizontal-stacked-grid + GRID-ELEMENT-COMPONENT ok-button + GRID-ELEMENT-COMPONENT exit-button))) + (form (make-form))) + + (add-form-to-grid grid form #t) + (make-wrapped-grid-window grid title) + + (receive (exit-reason argument) + (run-form form) + (dynamic-wind + (const #t) + (lambda () + (case exit-reason + ((exit-component) + (cond + ((components=? argument ok-button) + #t) + ((components=? argument exit-button) + (exit-button-procedure)))))) + (lambda () + (destroy-form-and-pop form)))))) + (define* (run-listbox-selection-page #:key info-text title diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index d4c91edc66..373aedd24c 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -1,5 +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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -53,7 +54,12 @@ (car result))) (define (draw-formatting-page) - "Draw a page to indicate partitions are being formated." + "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?") + (G_ "Format disk?") + #:exit-button-procedure button-exit-action) (draw-info-page (format #f (G_ "Partition formatting is in progress, please wait.")) (G_ "Preparing partitions"))) diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm index 642b8c6d8a..7cc2217cbe 100644 --- a/gnu/installer/parted.scm +++ b/gnu/installer/parted.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +25,10 @@ #:use-module ((gnu build file-systems) #:select (read-partition-uuid read-luks-partition-uuid)) + #:use-module ((gnu build linux-modules) + #:select (missing-modules)) + #:use-module ((gnu system linux-initrd) + #:select (%base-initrd-modules)) #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (guix records) @@ -1243,22 +1248,51 @@ from (gnu system mapped-devices) and return it." (target ,label) (type luks-device-mapping)))) +(define (root-user-partition? partition) + "Return true if PARTITION is the root partition." + (let ((mount-point (user-partition-mount-point partition))) + (and mount-point + (string=? mount-point "/")))) + (define (bootloader-configuration user-partitions) "Return the bootloader configuration field for USER-PARTITIONS." - (let* ((root-partition - (find (lambda (user-partition) - (let ((mount-point - (user-partition-mount-point user-partition))) - (and mount-point - (string=? mount-point "/")))) - user-partitions)) + (let* ((root-partition (find root-user-partition? + user-partitions)) (root-partition-disk (user-partition-disk-file-name root-partition))) `((bootloader-configuration ,@(if (efi-installation?) `((bootloader grub-efi-bootloader) (target ,(default-esp-mount-point))) `((bootloader grub-bootloader) - (target ,root-partition-disk))))))) + (target ,root-partition-disk))) + + ;; XXX: Assume we defined the 'keyboard-layout' field of + ;; <operating-system> right above. + (keyboard-layout keyboard-layout))))) + +(define (user-partition-missing-modules user-partitions) + "Return the list of kernel modules missing from the default set of kernel +modules to access USER-PARTITIONS." + (let ((devices (filter user-partition-crypt-label user-partitions)) + (root (find root-user-partition? user-partitions))) + (delete-duplicates + (append-map (lambda (device) + (catch 'system-error + (lambda () + (missing-modules device %base-initrd-modules)) + (const '()))) + (delete-duplicates + (map user-partition-file-name + (cons root devices))))))) + +(define (initrd-configuration user-partitions) + "Return an 'initrd-modules' field with everything needed for +USER-PARTITIONS, or return nothing." + (match (user-partition-missing-modules user-partitions) + (() + '()) + ((modules ...) + `((initrd-modules ',modules))))) (define (user-partitions->configuration user-partitions) "Return the configuration field for USER-PARTITIONS." @@ -1266,10 +1300,11 @@ from (gnu system mapped-devices) and return it." (swap-devices (map user-partition-file-name swap-user-partitions)) (encrypted-partitions (filter user-partition-crypt-label user-partitions))) - `(,@(if (null? swap-devices) + `((bootloader ,@(bootloader-configuration user-partitions)) + ,@(initrd-configuration user-partitions) + ,@(if (null? swap-devices) '() `((swap-devices (list ,@swap-devices)))) - (bootloader ,@(bootloader-configuration user-partitions)) ,@(if (null? encrypted-partitions) '() `((mapped-devices diff --git a/gnu/installer/services.scm b/gnu/installer/services.scm index ed44b87682..2b6625f6af 100644 --- a/gnu/installer/services.scm +++ b/gnu/installer/services.scm @@ -38,13 +38,15 @@ (list (desktop-environment (name "GNOME") - (snippet '(gnome-desktop-service))) + (snippet '(service gnome-desktop-service-type))) (desktop-environment (name "Xfce") + ;; TODO: Use 'xfce-desktop-service-type' when the 'guix' package provides + ;; it with a default value. (snippet '(xfce-desktop-service))) (desktop-environment (name "MATE") - (snippet '(mate-desktop-service))) + (snippet '(service mate-desktop-service-type))) (desktop-environment (name "Enlightenment") (snippet '(service enlightenment-desktop-service-type))))) |