diff options
Diffstat (limited to 'gnu/installer')
| -rw-r--r-- | gnu/installer/final.scm | 90 | ||||
| -rw-r--r-- | gnu/installer/keymap.scm | 8 | ||||
| -rw-r--r-- | gnu/installer/locale.scm | 21 | ||||
| -rw-r--r-- | gnu/installer/newt/final.scm | 28 | ||||
| -rw-r--r-- | gnu/installer/newt/keymap.scm | 45 | ||||
| -rw-r--r-- | gnu/installer/newt/locale.scm | 54 | ||||
| -rw-r--r-- | gnu/installer/newt/network.scm | 7 | ||||
| -rw-r--r-- | gnu/installer/newt/page.scm | 76 | ||||
| -rw-r--r-- | gnu/installer/newt/partition.scm | 36 | ||||
| -rw-r--r-- | gnu/installer/newt/services.scm | 80 | ||||
| -rw-r--r-- | gnu/installer/newt/timezone.scm | 5 | ||||
| -rw-r--r-- | gnu/installer/newt/user.scm | 99 | ||||
| -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 | 55 | ||||
| -rw-r--r-- | gnu/installer/services.scm | 158 | ||||
| -rw-r--r-- | gnu/installer/steps.scm | 28 | ||||
| -rw-r--r-- | gnu/installer/user.scm | 31 | ||||
| -rw-r--r-- | gnu/installer/utils.scm | 38 |
19 files changed, 695 insertions, 175 deletions
diff --git a/gnu/installer/final.scm b/gnu/installer/final.scm index e1c62f5ce0..855b640030 100644 --- a/gnu/installer/final.scm +++ b/gnu/installer/final.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. ;;; @@ -20,17 +21,98 @@ #:use-module (gnu installer newt page) #:use-module (gnu installer steps) #:use-module (gnu installer utils) + #:use-module (gnu installer user) #:use-module (gnu services herd) #:use-module (guix build utils) + #:use-module (gnu build accounts) + #:use-module ((gnu system shadow) #:prefix sys:) + #:use-module (rnrs io ports) #:export (install-system)) -(define (install-system) - "Start COW-STORE service on target directory and launch guix install command -in a subshell." +(define %seed + (seed->random-state + (logxor (getpid) (car (gettimeofday))))) + +(define (integer->alphanumeric-char n) + "Map N, an integer in the [0..62] range, to an alphanumeric character." + (cond ((< n 10) + (integer->char (+ (char->integer #\0) n))) + ((< n 36) + (integer->char (+ (char->integer #\A) (- n 10)))) + ((< n 62) + (integer->char (+ (char->integer #\a) (- n 36)))) + (else + (error "integer out of bounds" n)))) + +(define (random-string len) + "Compute a random string of size LEN where each character is alphanumeric." + (let loop ((chars '()) + (len len)) + (if (zero? len) + (list->string chars) + (let ((n (random 62 %seed))) + (loop (cons (integer->alphanumeric-char n) chars) + (- len 1)))))) + +(define (create-user-database users root) + "Create /etc/passwd, /etc/shadow, and /etc/group under ROOT for the given +USERS." + (define etc + (string-append root "/etc")) + + (define (salt) + ;; "$6" gives us a SHA512 password hash; the random string must be taken + ;; from the './0-9A-Za-z' alphabet (info "(libc) Passphrase Storage"). + (string-append "$6$" (random-string 10))) + + (define users* + (map (lambda (user) + (define root? + (string=? "root" (user-name user))) + + (sys:user-account (name (user-name user)) + (comment (user-real-name user)) + (group "users") + (uid (if root? 0 #f)) + (home-directory + (user-home-directory user)) + (password (crypt (user-password user) + (salt))) + + ;; We need a string here, not a file-like, hence + ;; this choice. + (shell + "/run/current-system/profile/bin/bash"))) + users)) + + (define-values (group password shadow) + (user+group-databases users* sys:%base-groups + #:current-passwd '() + #:current-groups '() + #:current-shadow '())) + + (mkdir-p etc) + (write-group group (string-append etc "/group")) + (write-passwd password (string-append etc "/passwd")) + (write-shadow shadow (string-append etc "/shadow"))) + +(define* (install-system locale #:key (users '())) + "Create /etc/shadow and /etc/passwd on the installation target for USERS. +Start COW-STORE service on target directory and launch guix install command in +a subshell. LOCALE must be the locale name under which that command will run, +or #f. Return #t on success and #f on failure." (let ((install-command (format #f "guix system init ~a ~a" (%installer-configuration-file) (%installer-target-dir)))) (mkdir-p (%installer-target-dir)) + + ;; We want to initialize user passwords but we don't want to store them in + ;; the config file since the password hashes would end up world-readable + ;; in the store. Thus, create /etc/shadow & co. here such that, on the + ;; first boot, the activation snippet that creates accounts will reuse the + ;; passwords that we've put in there. + (create-user-database users (%installer-target-dir)) + (start-service 'cow-store (list (%installer-target-dir))) - (false-if-exception (run-shell-command install-command)))) + (run-shell-command install-command #:locale locale))) diff --git a/gnu/installer/keymap.scm b/gnu/installer/keymap.scm index d66b376d9c..df9fc5e441 100644 --- a/gnu/installer/keymap.scm +++ b/gnu/installer/keymap.scm @@ -36,6 +36,7 @@ make-x11-keymap-layout x11-keymap-layout? x11-keymap-layout-name + x11-keymap-layout-synopsis x11-keymap-layout-description x11-keymap-layout-variants @@ -60,7 +61,8 @@ x11-keymap-layout make-x11-keymap-layout x11-keymap-layout? (name x11-keymap-layout-name) ;string - (description x11-keymap-layout-description) ;string + (synopsis x11-keymap-layout-synopsis) ;string (e.g., "en") + (description x11-keymap-layout-description) ;string (a whole phrase) (variants x11-keymap-layout-variants)) ;list of <x11-keymap-variant> (define-record-type* <x11-keymap-variant> @@ -117,6 +119,8 @@ Configuration Database, describing possible XKB configurations." (variantList ,[variant -> v] ...)) (x11-keymap-layout (name name) + (synopsis (car + (assoc-ref rest-layout 'shortDescription))) (description (car (assoc-ref rest-layout 'description))) (variants (list v ...)))] @@ -126,6 +130,8 @@ Configuration Database, describing possible XKB configurations." . ,rest-layout)) (x11-keymap-layout (name name) + (synopsis (car + (assoc-ref rest-layout 'shortDescription))) (description (car (assoc-ref rest-layout 'description))) (variants '()))])) diff --git a/gnu/installer/locale.scm b/gnu/installer/locale.scm index 2b45b2200a..284062a6e7 100644 --- a/gnu/installer/locale.scm +++ b/gnu/installer/locale.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. ;;; @@ -69,6 +70,24 @@ (codeset . ,(match:substring matches 5)) (modifier . ,(match:substring matches 7))))) +(define (normalize-codeset codeset) + "Compute the \"normalized\" variant of CODESET." + ;; info "(libc) Using gettextized software", for the algorithm used to + ;; compute the normalized codeset. + (letrec-syntax ((-> (syntax-rules () + ((_ proc value) + (proc value)) + ((_ proc rest ...) + (proc (-> rest ...)))))) + (-> (lambda (str) + (if (string-every char-set:digit str) + (string-append "iso" str) + str)) + string-downcase + (lambda (str) + (string-filter char-set:letter+digit str)) + codeset))) + (define (locale->locale-string locale) "Reverse operation of locale-string->locale." (let ((language (locale-language locale)) @@ -81,7 +100,7 @@ `("_" ,territory) '()) ,@(if codeset - `("." ,codeset) + `("." ,(normalize-codeset codeset)) '()) ,@(if modifier `("@" ,modifier) diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm index 645c1e8689..e375282613 100644 --- a/gnu/installer/newt/final.scm +++ b/gnu/installer/newt/final.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,15 +30,24 @@ #:use-module (newt) #:export (run-final-page)) +(define* (strip-prefix file #:optional (prefix (%installer-target-dir))) + "Strip PREFIX from FILE, if PREFIX actually is a prefix of FILE." + (if (string-prefix? prefix file) + (string-drop file (string-length prefix)) + file)) + (define (run-config-display-page) (let ((width (%configuration-file-width)) (height (nearest-exact-integer (/ (screen-rows) 2)))) (run-file-textbox-page - #:info-text (G_ "We're now ready to proceed with the installation! \ + #:info-text (format #f (G_ "\ +We're now ready to proceed with the installation! \ A system configuration file has been generated, it is displayed below. \ +This file will be available as '~a' on the installed system. \ The new system will be created from this file once you've pressed OK. \ This will take a few minutes.") + (strip-prefix (%installer-configuration-file))) #:title (G_ "Configuration file") #:file (%installer-configuration-file) #:info-textbox-width width @@ -55,7 +65,10 @@ This will take a few minutes.") (G_ "Reboot") (G_ "Congratulations! Installation is now complete. \ You may remove the device containing the installation image and \ -press the button to reboot."))) +press the button to reboot.")) + + ;; Return success so that the installer happily reboots. + 'success) (define (run-install-failed-page) (choice-window @@ -65,22 +78,25 @@ press the button to reboot."))) (G_ "The final system installation step failed. You can retry the \ last step, or restart the installer."))) -(define (run-install-shell) +(define* (run-install-shell locale + #:key (users '())) (clear-screen) (newt-suspend) - (let ((install-ok? (install-system))) + (let ((install-ok? (install-system locale #:users users))) (newt-resume) install-ok?)) (define (run-final-page result prev-steps) - (let* ((configuration (format-configuration prev-steps result)) + (let* ((configuration (format-configuration prev-steps result)) (user-partitions (result-step result 'partition)) + (locale (result-step result 'locale)) + (users (result-step result 'user)) (install-ok? (with-mounted-partitions user-partitions (configuration->file configuration) (run-config-display-page) - (run-install-shell)))) + (run-install-shell locale #:users users)))) (if install-ok? (run-install-success-page) (run-install-failed-page)))) diff --git a/gnu/installer/newt/keymap.scm b/gnu/installer/newt/keymap.scm index 3e765bfdd4..2908ba7f0e 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,10 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:export (run-keymap-page)) + #:use-module (ice-9 i18n) + #:use-module (ice-9 match) + #:export (run-keymap-page + keyboard-layout->configuration)) (define (run-layout-page layouts layout->text) (let ((title (G_ "Layout"))) @@ -61,14 +65,29 @@ (define (sort-layouts layouts) "Sort LAYOUTS list by putting the US layout ahead and return it." + (define (layout<? layout1 layout2) + (let ((text1 (x11-keymap-layout-description layout1)) + (text2 (x11-keymap-layout-description layout2))) + ;; XXX: We're calling 'gettext' more than once per item. + (string-locale<? (gettext text1 "xkeyboard-config") + (gettext text2 "xkeyboard-config")))) + + (define preferred + ;; Two-letter language tag for the preferred keyboard layout. + (or (getenv "LANGUAGE") "us")) + (call-with-values (lambda () (partition (lambda (layout) - (let ((name (x11-keymap-layout-name layout))) - (string=? name "us"))) + ;; The 'synopsis' field is usually a language code (e.g., "en") + ;; while the 'name' field is a country code (e.g., "us"). + (or (string=? (x11-keymap-layout-name layout) preferred) + (string=? (x11-keymap-layout-synopsis layout) preferred))) layouts)) - (cut append <> <>))) + (lambda (main others) + (append (sort main layout<?) + (sort others layout<?))))) (define (sort-variants variants) "Sort VARIANTS list by putting the international variant ahead and return it." @@ -94,7 +113,8 @@ names of the selected keyboard layout and variant." (run-layout-page (sort-layouts layouts) (lambda (layout) - (x11-keymap-layout-description layout)))))) + (gettext (x11-keymap-layout-description layout) + "xkeyboard-config")))))) ;; Propose the user to select a variant among those supported by the ;; previously selected layout. (installer-step @@ -108,15 +128,24 @@ names of the selected keyboard layout and variant." (run-variant-page (sort-variants variants) (lambda (variant) - (x11-keymap-variant-description - variant)))))))))) + (gettext (x11-keymap-variant-description variant) + "xkeyboard-config")))))))))) (define (format-result result) (let ((layout (x11-keymap-layout-name (result-step result 'layout))) (variant (and=> (result-step result 'variant) (lambda (variant) - (x11-keymap-variant-name variant))))) + (gettext (x11-keymap-variant-name variant) + "xkeyboard-config"))))) (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/locale.scm b/gnu/installer/newt/locale.scm index 4fa07df81e..7108e2960b 100644 --- a/gnu/installer/newt/locale.scm +++ b/gnu/installer/newt/locale.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. ;;; @@ -30,17 +31,11 @@ #:export (run-locale-page)) (define (run-language-page languages language->text) - (let ((title (G_ "Locale language"))) + (define result (run-listbox-selection-page - #:title title - #:info-text (G_ "Choose the locale's language to be used for the \ -installation process. A locale is a regional variant of your language \ -encompassing number, date and currency format, among other details. - -Based on the language you choose, you will possibly be asked to \ -select a locale's territory, codeset and modifier in the next \ -steps. The locale will also be used as the default one for the \ -installed system.") + #:title (G_ "Locale language") + #:info-text (G_ "Choose the language to use for the \ +installation process and for the installed system.") #:info-textbox-width 70 #:listbox-items languages #:listbox-item->text language->text @@ -50,14 +45,19 @@ installed system.") (lambda _ (raise (condition - (&installer-step-abort))))))) + (&installer-step-abort)))))) + + ;; Immediately install the chosen language so that the territory page that + ;; comes after (optionally) is displayed in the chosen language. + (setenv "LANGUAGE" result) + + result) (define (run-territory-page territories territory->text) (let ((title (G_ "Locale location"))) (run-listbox-selection-page #:title title - #:info-text (G_ "Choose your locale's location. This is a shortlist of \ -locations based on the language you selected.") + #:info-text (G_ "Choose a territory for this language.") #:listbox-items territories #:listbox-item->text territory->text #:button-text (G_ "Back") @@ -71,8 +71,7 @@ locations based on the language you selected.") (let ((title (G_ "Locale codeset"))) (run-listbox-selection-page #:title title - #:info-text (G_ "Choose your locale's codeset. If UTF-8 is available, \ - it should be preferred.") + #:info-text (G_ "Choose the locale encoding.") #:listbox-items codesets #:listbox-item->text identity #:listbox-default-item "UTF-8" @@ -163,7 +162,13 @@ glibc locale string and return it." (run-language-page (sort-languages (delete-duplicates (map locale-language supported-locales))) - (cut language-code->language-name iso639-languages <>))))) + (lambda (language) + (let ((english (language-code->language-name iso639-languages + language))) + (setenv "LANGUAGE" language) + (let ((native (gettext english "iso_639-3"))) + (unsetenv "LANGUAGE") + native))))))) (installer-step (id 'territory) (compute @@ -177,10 +182,11 @@ glibc locale string and return it." ;; supported by the previously selected language. (run-territory-page (delete-duplicates (map locale-territory locales)) - (lambda (territory-code) - (if territory-code - (territory-code->territory-name iso3166-territories - territory-code) + (lambda (territory) + (if territory + (let ((english (territory-code->territory-name + iso3166-territories territory))) + (gettext english "iso_3166-1")) (G_ "No location")))))))) (installer-step (id 'codeset) @@ -191,9 +197,11 @@ glibc locale string and return it." ;; narrow down the search of a locale. (break-on-locale-found locales) - ;; Otherwise, ask for a codeset. - (run-codeset-page - (delete-duplicates (map locale-codeset locales))))))) + ;; Otherwise, choose a codeset. + (let ((codesets (delete-duplicates (map locale-codeset locales)))) + (if (member "UTF-8" codesets) + "UTF-8" ;don't even ask + (run-codeset-page codesets))))))) (installer-step (id 'modifier) (compute diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm index f13176dc61..cf27a8cca2 100644 --- a/gnu/installer/newt/network.scm +++ b/gnu/installer/newt/network.scm @@ -59,7 +59,7 @@ Internet and return the selected technology. For now, only technologies with (G_ "Internet access") (G_ "Continue") (G_ "Exit") - (G_ "The install process requires an internet access, but no \ + (G_ "The install process requires Internet access but no \ network device were found. Do you want to continue anyway?")) ((1) (raise (condition @@ -68,7 +68,7 @@ network device were found. Do you want to continue anyway?")) (condition (&installer-step-abort))))) (run-listbox-selection-page - #:info-text (G_ "The install process requires an internet access.\ + #:info-text (G_ "The install process requires Internet access.\ Please select a network device.") #:title (G_ "Internet access") #:listbox-items items @@ -93,7 +93,8 @@ network device were found. Do you want to continue anyway?")) (full-value 5)) (run-scale-page #:title (G_ "Powering technology") - #:info-text (format #f "Waiting for technology ~a to be powered." name) + #:info-text (format #f (G_ "Waiting for technology ~a to be powered.") + name) #:scale-full-value full-value #:scale-update-proc (lambda (value) diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm index 23fbfcce76..3173d54737 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. ;;; @@ -20,6 +21,7 @@ #:use-module (gnu installer utils) #:use-module (gnu installer newt utils) #:use-module (guix i18n) + #:use-module (ice-9 i18n) #:use-module (ice-9 match) #:use-module (ice-9 receive) #:use-module (srfi srfi-1) @@ -29,6 +31,7 @@ draw-connecting-page run-input-page run-error-page + run-confirmation-page run-listbox-selection-page run-scale-page run-checkbox-tree-page @@ -72,17 +75,20 @@ this page to TITLE." #:key (allow-empty-input? #f) (default-text #f) - (input-field-width 40)) + (input-field-width 40) + (input-flags 0)) "Run a page to prompt user for an input. The given TEXT will be displayed above the input field. The page title is set to TITLE. Unless allow-empty-input? is set to #t, an error page will be displayed if the user -enters an empty input." +enters an empty input. INPUT-FLAGS is a bitwise-or'd set of flags for the +input box, such as FLAG-PASSWORD." (let* ((text-box (make-reflowed-textbox -1 -1 text input-field-width #:flags FLAG-BORDER)) (grid (make-grid 1 3)) - (input-entry (make-entry -1 -1 20)) + (input-entry (make-entry -1 -1 20 + #:flags input-flags)) (ok-button (make-button -1 -1 (G_ "OK"))) (form (make-form))) @@ -141,6 +147,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 @@ -185,7 +227,7 @@ be selected (using the <SPACE> key). It that case, a list containing the selected items will be returned. If SORT-LISTBOX-ITEMS? is set to #t, the listbox items are sorted using -'string<=' procedure (after being converted to text). +'string-locale<?' procedure (after being converted to text). If ALLOW-DELETE? is #t, the form will return if the <DELETE> key is pressed, otherwise nothing will happen. @@ -211,7 +253,7 @@ ITEM was inserted into LISTBOX." items)) (define (sort-listbox-items listbox-items) - "Return LISTBOX-ITEMS sorted using the 'string<=' procedure on the text + "Return LISTBOX-ITEMS sorted using the 'string-locale<?' procedure on the text corresponding to each item in the list." (let* ((items (map (lambda (item) (cons item (listbox-item->text item))) @@ -220,7 +262,7 @@ corresponding to each item in the list." (sort items (lambda (a b) (let ((text-a (cdr a)) (text-b (cdr b))) - (string<= text-a text-b)))))) + (string-locale<? text-a text-b)))))) (map car sorted-items))) ;; Store the last selected listbox item's key. @@ -395,10 +437,14 @@ error is raised if the MAX-SCALE-UPDATE limit is reached." (lambda () (destroy-form-and-pop form))))) +(define %none-selected + (circular-list #f)) + (define* (run-checkbox-tree-page #:key info-text title items + (selection %none-selected) item->text (info-textbox-width 50) (checkbox-tree-height 10) @@ -411,7 +457,8 @@ a checkbox list. The page contains vertically stacked from the top to the bottom, an informative text set to INFO-TEXT, the checkbox list and two buttons, 'Ok' and 'Exit'. The page title's is set to TITLE. ITEMS are converted to text using ITEM->TEXT before being displayed in the checkbox -list. +list. SELECTION is a list of Booleans of the same length as ITEMS that +specifies which items are initially checked. INFO-TEXTBOX-WIDTH is the width of the textbox where INFO-TEXT will be displayed. CHECKBOX-TREE-HEIGHT is the height of the checkbox list. @@ -423,12 +470,15 @@ pressed. This procedure returns the list of checked items in the checkbox list among ITEMS when 'Ok' is pressed." (define (fill-checkbox-tree checkbox-tree items) - (map - (lambda (item) - (let* ((item-text (item->text item)) - (key (add-entry-to-checkboxtree checkbox-tree item-text 0))) - (cons key item))) - items)) + (map (lambda (item selected?) + (let* ((item-text (item->text item)) + (key (add-entry-to-checkboxtree checkbox-tree item-text + (if selected? + FLAG-SELECTED + 0)))) + (cons key item))) + items + selection)) (let* ((checkbox-tree (make-checkboxtree -1 -1 diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index d4c91edc66..2b22ac85b4 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. ;;; @@ -41,8 +42,8 @@ (define (run-scheme-page) "Run a page asking the user for a partitioning scheme." (let* ((items - '((root . "Everything is one partition") - (root-home . "Separate /home partition"))) + `((root . ,(G_ "Everything is one partition")) + (root-home . ,(G_ "Separate /home partition")))) (result (run-listbox-selection-page #:info-text (G_ "Please select a partitioning scheme.") #:title (G_ "Partition scheme") @@ -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"))) @@ -146,6 +152,10 @@ USER-PARTITIONS list. Return this list with password fields filled-in." (file-name (user-partition-file-name user-part)) (password-page (lambda () + ;; Note: Don't use FLAG-PASSWORD here because this is the + ;; first bit of text that the user types in, so it's + ;; probably safer if they can see that the keyboard layout + ;; they chose is in effect. (run-input-page (format #f (G_ "Please enter the password for the \ encryption of partition ~a (label: ~a).") file-name crypt-label) @@ -155,7 +165,8 @@ encryption of partition ~a (label: ~a).") file-name crypt-label) (run-input-page (format #f (G_ "Please confirm the password for the \ encryption of partition ~a (label: ~a).") file-name crypt-label) - (G_ "Password confirmation required"))))) + (G_ "Password confirmation required") + #:input-flags FLAG-PASSWORD)))) (if crypt-label (let loop () (let ((password (password-page)) @@ -418,10 +429,10 @@ partition. Leave this field empty if you don't want to set a mounting point.") (run-listbox-selection-page #:info-text (if creation? - (G_ (format #f "Creating ~a partition starting at ~a of ~a." - type-str start file-name)) - (G_ (format #f "You are currently editing partition ~a." - number-str))) + (format #f (G_ "Creating ~a partition starting at ~a of ~a.") + type-str start file-name) + (format #f (G_ "You are currently editing partition ~a.") + number-str)) #:title (if creation? (G_ "Partition creation") (G_ "Partition edit")) @@ -662,7 +673,8 @@ by pressing the Exit button.~%~%"))) #:title (if guided? (G_ "Guided partitioning") (G_ "Manual partitioning")) - #:info-textbox-width 70 + #:info-textbox-width 76 ;we need a lot of room for INFO-TEXT + #:listbox-height 12 #:listbox-items (disk-items) #:listbox-item->text cdr #:sort-listbox-items? #f @@ -713,9 +725,9 @@ by pressing the Exit button.~%~%"))) "Run a page asking the user for a partitioning method." (define (run-page devices) (let* ((items - '((entire . "Guided - using the entire disk") - (entire-encrypted . "Guided - using the entire disk with encryption") - (manual . "Manual"))) + `((entire . ,(G_ "Guided - using the entire disk")) + (entire-encrypted . ,(G_ "Guided - using the entire disk with encryption")) + (manual . ,(G_ "Manual")))) (result (run-listbox-selection-page #:info-text (G_ "Please select a partitioning method.") #:title (G_ "Partitioning method") diff --git a/gnu/installer/newt/services.scm b/gnu/installer/newt/services.scm index 6bcb6244ae..4f32d9077b 100644 --- a/gnu/installer/newt/services.scm +++ b/gnu/installer/newt/services.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. ;;; @@ -30,19 +31,70 @@ (define (run-desktop-environments-cbt-page) "Run a page allowing the user to choose between various desktop environments." - (run-checkbox-tree-page - #:info-text (G_ "Please select the desktop(s) environment(s) you wish to \ -install. If you select multiple desktops environments, we will be able to \ -choose the one to use on the log-in screen with F1.") - #:title (G_ "Desktop environment") - #:items %desktop-environments - #:item->text desktop-environment-name - #:checkbox-tree-height 5 - #:exit-button-callback-procedure - (lambda () - (raise - (condition - (&installer-step-abort)))))) + (let ((items (filter desktop-system-service? %system-services))) + (run-checkbox-tree-page + #:info-text (G_ "Please select the desktop(s) environment(s) you wish to \ +install. If you select multiple desktops environments, you will be able to \ +choose the one to use on the log-in screen.") + #:title (G_ "Desktop environment") + #:items items + #:selection (map system-service-recommended? items) + #:item->text system-service-name ;no i18n for DE names + #:checkbox-tree-height 8 + #:exit-button-callback-procedure + (lambda () + (raise + (condition + (&installer-step-abort))))))) + +(define (run-networking-cbt-page) + "Run a page allowing the user to select networking services." + (let ((items (filter (lambda (service) + (eq? 'networking (system-service-type service))) + %system-services))) + (run-checkbox-tree-page + #:info-text (G_ "You can now select networking services to run on your \ +system.") + #:title (G_ "Network service") + #:items items + #:selection (map system-service-recommended? items) + #:item->text (compose G_ system-service-name) + #:checkbox-tree-height 5 + #: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"))) + (run-listbox-selection-page + #:title title + #:info-text (G_ "Choose the method to manage network connections. + +We recommend NetworkManager or Connman for a WiFi-capable laptop; the DHCP \ +client may be enough for a server.") + #:info-textbox-width 70 + #:listbox-items (filter (lambda (service) + (eq? 'network-management + (system-service-type service))) + %system-services) + #:listbox-item->text (compose G_ system-service-name) + #:sort-listbox-items? #f + #:button-text (G_ "Exit") + #:button-callback-procedure + (lambda _ + (raise + (condition + (&installer-step-abort))))))) (define (run-services-page) - (run-desktop-environments-cbt-page)) + (let ((desktop (run-desktop-environments-cbt-page))) + ;; When the user did not select any desktop services, and thus didn't get + ;; '%desktop-services', offer network management services. + (append desktop + (run-networking-cbt-page) + (if (null? desktop) + (list (run-network-management-page)) + '())))) diff --git a/gnu/installer/newt/timezone.scm b/gnu/installer/newt/timezone.scm index 63b44af729..67bf41ff84 100644 --- a/gnu/installer/newt/timezone.scm +++ b/gnu/installer/newt/timezone.scm @@ -50,12 +50,15 @@ returned." (define (run-page timezone-tree) (define (loop path) + ;; XXX: Translation of time zones isn't perfect here because the + ;; "iso_3166-1" domain contains translation for "territories" (like + ;; "Antarctic") but not for continents (like "Africa"). (let ((timezones (locate-children timezone-tree path))) (run-listbox-selection-page #:title (G_ "Timezone") #:info-text (G_ "Please select a timezone.") #:listbox-items timezones - #:listbox-item->text identity + #:listbox-item->text (cut gettext <> "iso_3166-1") #:button-text (if (null? path) (G_ "Exit") (G_ "Back")) diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm index 59b1913cfc..deab056e0c 100644 --- a/gnu/installer/newt/user.scm +++ b/gnu/installer/newt/user.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. ;;; @@ -28,18 +29,31 @@ #:use-module (srfi srfi-26) #:export (run-user-page)) -(define (run-user-add-page) +(define* (run-user-add-page #:key (name "") (real-name "") + (home-directory "")) + "Run a form to enter the user name, home directory, and password. Use NAME, +REAL-NAME, and HOME-DIRECTORY as the initial values in the form." (define (pad-label label) (string-pad-right label 20)) (let* ((label-name (make-label -1 -1 (pad-label (G_ "Name")))) + (label-real-name + (make-label -1 -1 (pad-label (G_ "Real name")))) (label-home-directory (make-label -1 -1 (pad-label (G_ "Home directory")))) + (label-password + (make-label -1 -1 (pad-label (G_ "Password")))) (entry-width 30) - (entry-name (make-entry -1 -1 entry-width)) - (entry-home-directory (make-entry -1 -1 entry-width)) - (entry-grid (make-grid 2 2)) + (entry-name (make-entry -1 -1 entry-width + #:initial-value name)) + (entry-real-name (make-entry -1 -1 entry-width + #:initial-value real-name)) + (entry-home-directory (make-entry -1 -1 entry-width + #:initial-value home-directory)) + (entry-password (make-entry -1 -1 entry-width + #:flags FLAG-PASSWORD)) + (entry-grid (make-grid 2 5)) (button-grid (make-grid 1 1)) (ok-button (make-button -1 -1 (G_ "OK"))) (grid (make-grid 1 2)) @@ -50,8 +64,12 @@ (set-entry-grid-field 0 0 label-name) (set-entry-grid-field 1 0 entry-name) - (set-entry-grid-field 0 1 label-home-directory) - (set-entry-grid-field 1 1 entry-home-directory) + (set-entry-grid-field 0 1 label-real-name) + (set-entry-grid-field 1 1 entry-real-name) + (set-entry-grid-field 0 2 label-home-directory) + (set-entry-grid-field 1 2 entry-home-directory) + (set-entry-grid-field 0 3 label-password) + (set-entry-grid-field 1 3 entry-password) (set-grid-field button-grid 0 0 GRID-ELEMENT-COMPONENT ok-button) @@ -59,11 +77,17 @@ entry-name (lambda (component) (set-entry-text entry-home-directory - (string-append "/home/" (entry-value entry-name))))) + (string-append "/home/" (entry-value entry-name))) + + (when (string-null? (entry-value entry-real-name)) + (set-entry-text entry-real-name + (string-titlecase (entry-value entry-name)))))) (add-components-to-form form - label-name label-home-directory - entry-name entry-home-directory + label-name label-real-name + label-home-directory label-password + entry-name entry-real-name + entry-home-directory entry-password ok-button) (make-wrapped-grid-window (vertically-stacked-grid @@ -82,19 +106,57 @@ (when (eq? exit-reason 'exit-component) (cond ((components=? argument ok-button) - (let ((name (entry-value entry-name)) - (home-directory (entry-value entry-home-directory))) + (let ((name (entry-value entry-name)) + (real-name (entry-value entry-real-name)) + (home-directory (entry-value entry-home-directory)) + (password (entry-value entry-password))) (if (or (string=? name "") (string=? home-directory "")) (begin (error-page) (run-user-add-page)) - (user - (name name) - (home-directory home-directory)))))))) + (let ((password (confirm-password password))) + (if password + (user + (name name) + (real-name real-name) + (home-directory home-directory) + (password password)) + (run-user-add-page #:name name + #:real-name real-name + #:home-directory + home-directory))))))))) (lambda () (destroy-form-and-pop form))))))) +(define* (confirm-password password #:optional (try-again (const #f))) + "Ask the user to confirm PASSWORD, a possibly empty string. Call TRY-AGAIN, +a thunk, if the confirmation doesn't match PASSWORD, and return its result." + (define confirmation + (run-input-page (G_ "Please confirm the password.") + (G_ "Password confirmation required") + #:allow-empty-input? #t + #:input-flags FLAG-PASSWORD)) + + (if (string=? password confirmation) + password + (begin + (run-error-page + (G_ "Password mismatch, please try again.") + (G_ "Password error")) + (try-again)))) + +(define (run-root-password-page) + ;; TRANSLATORS: Leave "root" untranslated: it refers to the name of the + ;; system administrator account. + (define password + (run-input-page (G_ "Please choose a password for the system \ +administrator (\"root\").") + (G_ "System administrator password") + #:input-flags FLAG-PASSWORD)) + + (confirm-password password run-root-password-page)) + (define (run-user-page) (define (run users) (let* ((listbox (make-listbox @@ -169,7 +231,12 @@ (run-error-page (G_ "Please create at least one user.") (G_ "No user")) (run users)) - users)))) + (reverse users))))) (lambda () (destroy-form-and-pop form)))))) - (run '())) + + ;; Add a "root" user simply to convey the root password. + (cons (user (name "root") + (home-directory "/root") + (password (run-root-password-page))) + (run '()))) diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm index b0b5429c0f..aec3e7a612 100644 --- a/gnu/installer/newt/welcome.scm +++ b/gnu/installer/newt/welcome.scm @@ -95,9 +95,11 @@ installation and reboot." (G_ "GNU Guix install") (G_ "Welcome to GNU Guix system installer! -Please note that the present graphical installer is still under heavy \ -development, so you might want to prefer using the shell based process. \ -The documentation is accessible at any time by pressing CTRL-ALT-F2.") +You will be guided through a graphical installation program. + +If you are familiar with GNU/Linux and you want tight control over \ +the installation process, you can instead choose manual installation. \ +Documentation is accessible at any time by pressing Ctrl-Alt-F2.") logo #:listbox-items `((,(G_ "Graphical install using a terminal based interface") diff --git a/gnu/installer/newt/wifi.scm b/gnu/installer/newt/wifi.scm index 4cf5c128e7..da2f0b56d0 100644 --- a/gnu/installer/newt/wifi.scm +++ b/gnu/installer/newt/wifi.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2019 Meiyo Peng <meiyo@riseup.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -80,7 +81,7 @@ nmc_wifi_strength_bars." (message (G_ "Unable to find a wifi technology")))))))) (define (draw-scanning-page) - "Draw a page to indicate a wifi scan in in progress." + "Draw a page to indicate a wifi scan in progress." (draw-info-page (G_ "Scanning wifi for available networks, please wait.") (G_ "Scan in progress"))) 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..fbfcdac4e5 100644 --- a/gnu/installer/services.scm +++ b/gnu/installer/services.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. ;;; @@ -18,42 +19,129 @@ (define-module (gnu installer services) #:use-module (guix records) - #:export (<desktop-environment> - desktop-environment - make-desktop-environment - desktop-environment-name - desktop-environment-snippet + #:use-module (srfi srfi-1) + #:export (system-service? + system-service-name + system-service-type + system-service-recommended? + system-service-snippet + system-service-packages - %desktop-environments - desktop-environments->configuration)) + desktop-system-service? + networking-system-service? -(define-record-type* <desktop-environment> - desktop-environment make-desktop-environment - desktop-environment? - (name desktop-environment-name) ;string - (snippet desktop-environment-snippet)) ;symbol + %system-services + system-services->configuration)) + +(define-record-type* <system-service> + system-service make-system-service + system-service? + (name system-service-name) ;string + (type system-service-type) ;'desktop | 'networking + (recommended? system-service-recommended? ;Boolean + (default #f)) + (snippet system-service-snippet ;list of sexps + (default '())) + (packages system-service-packages ;list of sexps + (default '()))) ;; This is the list of desktop environments supported as services. -(define %desktop-environments - (list - (desktop-environment - (name "GNOME") - (snippet '(gnome-desktop-service))) - (desktop-environment - (name "Xfce") - (snippet '(xfce-desktop-service))) - (desktop-environment - (name "MATE") - (snippet '(mate-desktop-service))) - (desktop-environment - (name "Enlightenment") - (snippet '(service enlightenment-desktop-service-type))))) - -(define (desktop-environments->configuration desktop-environments) - "Return the configuration field for DESKTOP-ENVIRONMENTS." - (let ((snippets - (map desktop-environment-snippet desktop-environments))) - `(,@(if (null? snippets) - '() - `((services (cons* ,@snippets - %desktop-services))))))) +(define %system-services + (let-syntax ((desktop-environment (syntax-rules () + ((_ fields ...) + (system-service + (type 'desktop) + fields ...)))) + (G_ (syntax-rules () ;for xgettext + ((_ str) str)))) + (list + (desktop-environment + (name "GNOME") + (snippet '((service gnome-desktop-service-type)))) + (desktop-environment + (name "Xfce") + (snippet '((service xfce-desktop-service-type)))) + (desktop-environment + (name "MATE") + (snippet '((service mate-desktop-service-type)))) + (desktop-environment + (name "Enlightenment") + (snippet '((service enlightenment-desktop-service-type)))) + (desktop-environment + (name "Openbox") + (packages '((specification->package "openbox")))) + (desktop-environment + (name "awesome") + (packages '((specification->package "awesome")))) + (desktop-environment + (name "i3") + (packages '((specification->package "i3-wm")))) + (desktop-environment + (name "ratpoison") + (packages '((specification->package "ratpoison")))) + + ;; Networking. + (system-service + (name (G_ "OpenSSH secure shell daemon (sshd)")) + (type 'networking) + (snippet '((service openssh-service-type)))) + (system-service + (name (G_ "Tor anonymous network router")) + (type 'networking) + (snippet '((service tor-service-type)))) + (system-service + (name (G_ "Mozilla NSS certificates, for HTTPS access")) + (type 'networking) + (packages '((specification->package "nss-certs"))) + (recommended? #t)) + + ;; Network connectivity management. + (system-service + (name (G_ "NetworkManager network connection manager")) + (type 'network-management) + (snippet '((service network-manager-service-type) + (service wpa-supplicant-service-type)))) + (system-service + (name (G_ "Connman network connection manager")) + (type 'network-management) + (snippet '((service connman-service-type) + (service wpa-supplicant-service-type)))) + (system-service + (name (G_ "DHCP client (dynamic IP address assignment)")) + (type 'network-management) + (snippet '((service dhcp-client-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)) + (packages (append-map system-service-packages services)) + (desktop? (find desktop-system-service? services)) + (base (if desktop? + '%desktop-services + '%base-services))) + (if (null? snippets) + `(,@(if (null? packages) + '() + `((packages (list ,@packages)))) + (services ,base)) + `(,@(if (null? packages) + '() + `((packages (list ,@packages)))) + (services (append (list ,@snippets + + ,@(if desktop? + ;; XXX: Assume 'keyboard-layout' is in + ;; scope. + '((set-xorg-configuration + (xorg-configuration + (keyboard-layout keyboard-layout)))) + '())) + ,base)))))) diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm index 3f0bdad4f7..039dd0ca10 100644 --- a/gnu/installer/steps.scm +++ b/gnu/installer/steps.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2018, 2019 Mathieu Othacehe <m.othacehe@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -113,16 +113,24 @@ return the accumalated result so far." (define* (skip-to-step step result #:key todo-steps done-steps) - (match (list todo-steps done-steps) - (((todo . rest-todo) (prev-done ... last-done)) - (if (eq? (installer-step-id todo) - (installer-step-id step)) + (match todo-steps + ((todo . rest-todo) + (let ((found? (eq? (installer-step-id todo) + (installer-step-id step)))) + (cond + (found? (run result #:todo-steps todo-steps - #:done-steps done-steps) - (skip-to-step step (pop-result result) - #:todo-steps (cons last-done todo-steps) - #:done-steps prev-done))))) + #:done-steps done-steps)) + ((and (not found?) + (null? done-steps)) + (error (format #f "Step ~a not found" (installer-step-id step)))) + (else + (match done-steps + ((prev-done ... last-done) + (skip-to-step step (pop-result result) + #:todo-steps (cons last-done todo-steps) + #:done-steps prev-done))))))))) (define* (run result #:key todo-steps done-steps) (match todo-steps @@ -215,7 +223,7 @@ found in RESULTS." '()))) steps)) (modules '((use-modules (gnu)) - (use-service-modules desktop)))) + (use-service-modules desktop networking ssh xorg)))) `(,@modules () (operating-system ,@configuration)))) diff --git a/gnu/installer/user.scm b/gnu/installer/user.scm index 1f8d40a011..4e701e64ce 100644 --- a/gnu/installer/user.scm +++ b/gnu/installer/user.scm @@ -18,12 +18,15 @@ (define-module (gnu installer user) #:use-module (guix records) + #:use-module (srfi srfi-1) #:export (<user> user make-user user-name + user-real-name user-group user-home-directory + user-password users->configuration)) @@ -31,20 +34,28 @@ user make-user user? (name user-name) + (real-name user-real-name + (default "")) (group user-group (default "users")) + (password user-password) (home-directory user-home-directory)) (define (users->configuration users) "Return the configuration field for USERS." + (define (user->sexp user) + `(user-account + (name ,(user-name user)) + (comment ,(user-real-name user)) + (group ,(user-group user)) + (home-directory ,(user-home-directory user)) + (supplementary-groups '("wheel" "netdev" + "audio" "video")))) + `((users (cons* - ,@(map (lambda (user) - `(user-account - (name ,(user-name user)) - (group ,(user-group user)) - (home-directory ,(user-home-directory user)) - (supplementary-groups - (quote ("wheel" "netdev" - "audio" "video"))))) - users) - %base-user-accounts)))) + ,@(filter-map (lambda (user) + ;; Do not emit a 'user-account' form for "root". + (and (not (string=? (user-name user) "root")) + (user->sexp user))) + users) + %base-user-accounts)))) diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm index e91f90a84d..ddb96bc338 100644 --- a/gnu/installer/utils.scm +++ b/gnu/installer/utils.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. ;;; @@ -19,6 +20,8 @@ (define-module (gnu installer utils) #:use-module (guix utils) #:use-module (guix build utils) + #:use-module (guix i18n) + #:use-module (srfi srfi-34) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 textual-ports) @@ -54,10 +57,37 @@ number. If no percentage is found, return #f" (and result (string->number (match:substring result 1))))) -(define (run-shell-command command) +(define* (run-shell-command command #:key locale) + "Run COMMAND, a string, with Bash, and in the given LOCALE. Return true if +COMMAND exited successfully, #f otherwise." + (define (pause) + (format #t (G_ "Press Enter to continue.~%")) + (read-line (current-input-port))) + (call-with-temporary-output-file (lambda (file port) - (format port "~a~%" command) - ;; (format port "exit~%") + (when locale + (let ((supported? (false-if-exception + (setlocale LC_ALL locale)))) + ;; If LOCALE is not supported, then set LANGUAGE, which might at + ;; least give us translated messages. + (if supported? + (format port "export LC_ALL=\"~a\"~%" locale) + (format port "export LANGUAGE=\"~a\"~%" + (string-take locale + (string-index locale #\_)))))) + + (format port "exec ~a~%" command) (close port) - (invoke "bash" "--init-file" file)))) + + (guard (c ((invoke-error? c) + (newline) + (format (current-error-port) + (G_ "Command failed with exit code ~a.~%") + (invoke-error-exit-status c)) + (pause) + #f)) + (invoke "bash" "--init-file" file) + (newline) + (pause) + #t)))) |