diff options
Diffstat (limited to 'gnu/installer/newt')
| -rw-r--r-- | gnu/installer/newt/ethernet.scm | 8 | ||||
| -rw-r--r-- | gnu/installer/newt/final.scm | 12 | ||||
| -rw-r--r-- | gnu/installer/newt/keymap.scm | 8 | ||||
| -rw-r--r-- | gnu/installer/newt/locale.scm | 25 | ||||
| -rw-r--r-- | gnu/installer/newt/network.scm | 16 | ||||
| -rw-r--r-- | gnu/installer/newt/page.scm | 170 | ||||
| -rw-r--r-- | gnu/installer/newt/partition.scm | 10 | ||||
| -rw-r--r-- | gnu/installer/newt/services.scm | 16 | ||||
| -rw-r--r-- | gnu/installer/newt/timezone.scm | 4 | ||||
| -rw-r--r-- | gnu/installer/newt/user.scm | 11 | ||||
| -rw-r--r-- | gnu/installer/newt/welcome.scm | 2 | ||||
| -rw-r--r-- | gnu/installer/newt/wifi.scm | 4 |
12 files changed, 195 insertions, 91 deletions
diff --git a/gnu/installer/newt/ethernet.scm b/gnu/installer/newt/ethernet.scm index ecd22efbb2..d75a640519 100644 --- a/gnu/installer/newt/ethernet.scm +++ b/gnu/installer/newt/ethernet.scm @@ -65,9 +65,7 @@ connection is pending." (run-error-page (G_ "No ethernet service available, please try again.") (G_ "No service")) - (raise - (condition - (&installer-step-abort)))) + (abort-to-prompt 'installer-step 'abort)) ((service) ;; Only one service is available so return it directly. service) @@ -81,7 +79,5 @@ connection is pending." #:button-text (G_ "Exit") #:button-callback-procedure (lambda _ - (raise - (condition - (&installer-step-abort)))) + (abort-to-prompt 'installer-step 'abort)) #:listbox-callback-procedure connect-ethernet-service)))) diff --git a/gnu/installer/newt/final.scm b/gnu/installer/newt/final.scm index 7f6dd9f075..7c3f73ee82 100644 --- a/gnu/installer/newt/final.scm +++ b/gnu/installer/newt/final.scm @@ -59,9 +59,7 @@ This will take a few minutes.") #:file-textbox-height height #:exit-button-callback-procedure (lambda () - (raise - (condition - (&installer-step-abort))))))) + (abort-to-prompt 'installer-step 'abort))))) (define (run-install-success-page) (match (current-clients) @@ -88,9 +86,7 @@ press the button to reboot."))) (G_ "Restart the installer") (G_ "The final system installation step failed. You can resume from \ a specific step, or restart the installer.")) - (1 (raise - (condition - (&installer-step-abort)))) + (1 (abort-to-prompt 'installer-step 'abort)) (2 ;; Keep going, the installer will be restarted later on. #t))) @@ -109,7 +105,7 @@ a specific step, or restart the installer.")) (define (run-final-page result prev-steps) (define (wait-for-clients) (unless (null? (current-clients)) - (syslog "waiting with clients before starting final step~%") + (installer-log-line "waiting with clients before starting final step") (send-to-clients '(starting-final-step)) (match (select (current-clients) '() '()) (((port _ ...) _ _) @@ -119,7 +115,7 @@ a specific step, or restart the installer.")) ;; things such as changing the swap partition label. (wait-for-clients) - (syslog "proceeding with final step~%") + (installer-log-line "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/keymap.scm b/gnu/installer/newt/keymap.scm index 92f7f46f34..c5d4be6792 100644 --- a/gnu/installer/newt/keymap.scm +++ b/gnu/installer/newt/keymap.scm @@ -59,9 +59,7 @@ different layout at any time from the parameters menu."))) ((param) (const #f)) (else (lambda _ - (raise - (condition - (&installer-step-abort))))))))) + (abort-to-prompt 'installer-step 'abort))))))) (define (run-variant-page variants variant->text) (let ((title (G_ "Variant"))) @@ -74,9 +72,7 @@ different layout at any time from the parameters menu."))) #:button-text (G_ "Back") #:button-callback-procedure (lambda _ - (raise - (condition - (&installer-step-abort))))))) + (abort-to-prompt 'installer-step 'abort))))) (define (sort-layouts layouts) "Sort LAYOUTS list by putting the US layout ahead and return it." diff --git a/gnu/installer/newt/locale.scm b/gnu/installer/newt/locale.scm index bfd89aca2c..01171e253f 100644 --- a/gnu/installer/newt/locale.scm +++ b/gnu/installer/newt/locale.scm @@ -43,9 +43,7 @@ installation process and for the installed system.") #:button-text (G_ "Exit") #:button-callback-procedure (lambda _ - (raise - (condition - (&installer-step-abort)))))) + (abort-to-prompt 'installer-step 'abort)))) ;; Immediately install the chosen language so that the territory page that ;; comes after (optionally) is displayed in the chosen language. @@ -63,9 +61,7 @@ installation process and for the installed system.") #:button-text (G_ "Back") #:button-callback-procedure (lambda _ - (raise - (condition - (&installer-step-abort))))))) + (abort-to-prompt 'installer-step 'abort))))) (define (run-codeset-page codesets) (let ((title (G_ "Locale codeset"))) @@ -78,9 +74,7 @@ installation process and for the installed system.") #:button-text (G_ "Back") #:button-callback-procedure (lambda _ - (raise - (condition - (&installer-step-abort))))))) + (abort-to-prompt 'installer-step 'abort))))) (define (run-modifier-page modifiers modifier->text) (let ((title (G_ "Locale modifier"))) @@ -94,9 +88,7 @@ symbol.") #:button-text (G_ "Back") #:button-callback-procedure (lambda _ - (raise - (condition - (&installer-step-abort))))))) + (abort-to-prompt 'installer-step 'abort))))) (define* (run-locale-page #:key supported-locales @@ -110,11 +102,10 @@ associating a territory code with a territory name. The formatted locale, under glibc format is returned." (define (break-on-locale-found locales) - "Raise the &installer-step-break condition if LOCALES contains exactly one + "Break to the installer step if LOCALES contains exactly one element." (and (= (length locales) 1) - (raise - (condition (&installer-step-break))))) + (abort-to-prompt 'installer-step 'break))) (define (filter-locales locales result) "Filter the list of locale records LOCALES using the RESULT returned by @@ -218,8 +209,8 @@ glibc locale string and return it." ;; If run-installer-steps returns locally, it means that the user had to go ;; through all steps (language, territory, codeset and modifier) to select a - ;; locale. In that case, like if we exited by raising &installer-step-break - ;; condition, turn the result into a glibc locale string and return it. + ;; locale. In that case, like if we exited by breaking to the installer + ;; step, turn the result into a glibc locale string and return it. (result->locale-string supported-locales (run-installer-steps #:steps locale-steps))) diff --git a/gnu/installer/newt/network.scm b/gnu/installer/newt/network.scm index fb221483c3..0477a489be 100644 --- a/gnu/installer/newt/network.scm +++ b/gnu/installer/newt/network.scm @@ -65,12 +65,8 @@ Internet and return the selected technology. For now, only technologies with (G_ "Exit") (G_ "The install process requires Internet access but no \ network devices were found. Do you want to continue anyway?")) - ((1) (raise - (condition - (&installer-step-break)))) - ((2) (raise - (condition - (&installer-step-abort)))))) + ((1) (abort-to-prompt 'installer-step 'break)) + ((2) (abort-to-prompt 'installer-step 'abort)))) ((technology) ;; Since there's only one technology available, skip the selection ;; screen. @@ -86,9 +82,7 @@ network devices were found. Do you want to continue anyway?")) #:button-text (G_ "Exit") #:button-callback-procedure (lambda _ - (raise - (condition - (&installer-step-abort)))))))) + (abort-to-prompt 'installer-step 'abort)))))) (define (find-technology-by-type technologies type) "Find and return a technology with the given TYPE in TECHNOLOGIES list." @@ -156,9 +150,7 @@ FULL-VALUE tentatives, spaced by 1 second." (G_ "The selected network does not provide access to the \ Internet and the Guix substitute server, please try again.") (G_ "Connection error")) - (raise - (condition - (&installer-step-abort)))))) + (abort-to-prompt 'installer-step 'abort)))) (define (run-network-page) "Run a page to allow the user to configure connman so that it can access the diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm index 4209674c28..0f508a31c0 100644 --- a/gnu/installer/newt/page.scm +++ b/gnu/installer/newt/page.scm @@ -22,6 +22,7 @@ #:use-module (gnu installer steps) #:use-module (gnu installer utils) #:use-module (gnu installer newt utils) + #:use-module (guix build utils) #:use-module (guix i18n) #:use-module (ice-9 i18n) #:use-module (ice-9 match) @@ -43,6 +44,10 @@ run-scale-page run-checkbox-tree-page run-file-textbox-page + %ok-button + %exit-button + run-textbox-page + run-dump-page run-form-with-clients)) @@ -93,9 +98,9 @@ disconnect. Like 'run-form', return two values: the exit reason, and an \"argument\"." (define* (discard-client! port #:optional errno) (if errno - (syslog "removing client ~d due to ~s~%" + (installer-log-line "removing client ~d due to ~s" (fileno port) (strerror errno)) - (syslog "removing client ~d due to EOF~%" + (installer-log-line "removing client ~d due to EOF" (fileno port))) ;; XXX: Watch out! There's no 'form-unwatch-fd' procedure in Newt so we @@ -124,7 +129,7 @@ Like 'run-form', return two values: the exit reason, and an \"argument\"." (send-to-clients exp) (let loop () - (syslog "running form ~s (~s) with ~d clients~%" + (installer-log-line "running form ~s (~s) with ~d clients" form title (length (current-clients))) ;; Call 'watch-clients!' within the loop because there might be new @@ -146,7 +151,7 @@ Like 'run-form', return two values: the exit reason, and an \"argument\"." (discard-client! port) (loop)) (obj - (syslog "form ~s (~s): client ~d replied ~s~%" + (installer-log-line "form ~s (~s): client ~d replied ~s" form title (fileno port) obj) (values 'exit-fd-ready obj)))) (lambda args @@ -156,8 +161,9 @@ Like 'run-form', return two values: the exit reason, and an \"argument\"." ;; Accept a new client and send it EXP. (match (accept port) ((client . _) - (syslog "accepting new client ~d while on form ~s~%" - (fileno client) form) + (installer-log-line + "accepting new client ~d while on form ~s" + (fileno client) form) (catch 'system-error (lambda () (write exp client) @@ -486,7 +492,7 @@ the current listbox item has to be selected by key." (string=? str (listbox-item->text item)))) keys) ((key . item) item) - (#f (raise (condition (&installer-step-abort)))))) + (#f (abort-to-prompt 'installer-step 'abort)))) ;; On every listbox element change, check if we need to skip it. If yes, ;; depending on the 'last-listbox-key', jump forward or backward. If no, @@ -688,7 +694,7 @@ ITEMS when 'Ok' is pressed." (string=? str (item->text item)))) keys) ((key . item) item) - (#f (raise (condition (&installer-step-abort)))))) + (#f (abort-to-prompt 'installer-step 'abort)))) (add-form-to-grid grid form #t) (make-wrapped-grid-window grid title) @@ -726,8 +732,7 @@ ITEMS when 'Ok' is pressed." (newt-suspend) ;; Use Nano because it syntax-highlights Scheme by default. ;; TODO: Add a menu to choose an editor? - (run-command (list "/run/current-system/profile/bin/nano" file) - #:locale locale) + (invoke "nano" file) (newt-resume)) (define* (run-file-textbox-page #:key @@ -811,6 +816,151 @@ ITEMS when 'Ok' is pressed." (destroy-form-and-pop form)))) (if (and (eq? exit-reason 'exit-component) + edit-button (components=? argument edit-button)) (loop) ;recurse in tail position result))))) + +(define %ok-button + (cons (G_ "Ok") (lambda () #t))) + +(define %exit-button + (cons (G_ "Exit") (lambda () (abort-to-prompt 'installer-step 'abort)))) + +(define %default-buttons + (list %ok-button %exit-button)) + +(define (make-newt-buttons buttons-spec) + (map + (match-lambda ((title . proc) + (cons (make-button -1 -1 title) proc))) + buttons-spec)) + +(define* (run-textbox-page #:key + title + info-text + content + (buttons-spec %default-buttons)) + "Run a page to display INFO-TEXT followed by CONTENT to the user, who has to +choose an action among the buttons specified by BUTTONS-SPEC. + +BUTTONS-SPEC is an association list with button labels as keys, and callback +procedures as values. + +This procedure returns the result of the callback procedure of the button +chosen by the user." + (define info-textbox + (make-reflowed-textbox -1 -1 info-text + 50 + #:flags FLAG-BORDER)) + (define content-textbox + (make-textbox -1 -1 + 50 + 30 + (logior FLAG-SCROLL FLAG-BORDER))) + (define buttons + (make-newt-buttons buttons-spec)) + (define grid + (vertically-stacked-grid + GRID-ELEMENT-COMPONENT info-textbox + GRID-ELEMENT-COMPONENT content-textbox + GRID-ELEMENT-SUBGRID + (apply + horizontal-stacked-grid + (append-map (match-lambda ((button . proc) + (list GRID-ELEMENT-COMPONENT button))) + buttons)))) + (define form (make-form #:flags FLAG-NOF12)) + (add-form-to-grid grid form #t) + (make-wrapped-grid-window grid title) + (set-textbox-text content-textbox + (receive (_w _h text) + (reflow-text content + 50 + 0 0) + text)) + + (receive (exit-reason argument) + (run-form-with-clients form + `(contents-dialog (title ,title) + (text ,info-text) + (content ,content))) + (destroy-form-and-pop form) + (match exit-reason + ('exit-component + (let ((proc (assq-ref buttons argument))) + (if proc + (proc) + (raise + (condition + (&serious) + (&message + (message (format #f "Unable to find corresponding PROC for \ +component ~a." argument)))))))) + ;; TODO + ('exit-fd-ready + (raise (condition (&serious))))))) + +(define* (run-dump-page base-dir file-choices) + (define info-textbox + (make-reflowed-textbox -1 -1 "Please select files you wish to include in \ +the dump." + 50 + #:flags FLAG-BORDER)) + (define components + (map (match-lambda ((file . enabled) + (list + (make-compact-button -1 -1 "Edit") + (make-checkbox -1 -1 file (if enabled #\x #\ ) " x") + file))) + file-choices)) + + (define sub-grid (make-grid 2 (length components))) + + (for-each + (match-lambda* (((button checkbox _) index) + (set-grid-field sub-grid 0 index + GRID-ELEMENT-COMPONENT checkbox + #:anchor ANCHOR-LEFT) + (set-grid-field sub-grid 1 index + GRID-ELEMENT-COMPONENT button + #:anchor ANCHOR-LEFT))) + components (iota (length components))) + + (define grid + (vertically-stacked-grid + GRID-ELEMENT-COMPONENT info-textbox + GRID-ELEMENT-SUBGRID sub-grid + GRID-ELEMENT-COMPONENT (make-button -1 -1 "Create"))) + + (define form (make-form #:flags FLAG-NOF12)) + + (add-form-to-grid grid form #t) + (make-wrapped-grid-window grid "Installer dump") + + (define prompt-tag (make-prompt-tag)) + + (let loop () + (call-with-prompt prompt-tag + (lambda () + (receive (exit-reason argument) + (run-form-with-clients form + `(dump-page)) + (match exit-reason + ('exit-component + (let ((result + (map (match-lambda + ((edit checkbox filename) + (if (components=? edit argument) + (abort-to-prompt prompt-tag filename) + (cons filename (eq? #\x + (checkbox-value checkbox)))))) + components))) + (destroy-form-and-pop form) + result)) + ;; TODO + ('exit-fd-ready + (raise (condition (&serious))))))) + (lambda (k file) + (edit-file (string-append base-dir "/" file)) + (loop))))) diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm index ccc7686906..e7a97810ac 100644 --- a/gnu/installer/newt/partition.scm +++ b/gnu/installer/newt/partition.scm @@ -36,10 +36,8 @@ #:export (run-partitioning-page)) (define (button-exit-action) - "Raise the &installer-step-abort condition." - (raise - (condition - (&installer-step-abort)))) + "Abort the installer step." + (abort-to-prompt 'installer-step 'abort)) (define (run-scheme-page) "Run a page asking the user for a partitioning scheme." @@ -801,9 +799,9 @@ by pressing the Exit button.~%~%"))) ;; Make sure the disks are not in use before proceeding to formatting. (free-parted eligible-devices) (format-user-partitions user-partitions-with-pass) - (syslog "formatted ~a user partitions~%" + (installer-log-line "formatted ~a user partitions" (length user-partitions-with-pass)) - (syslog "user-partitions: ~a~%" user-partitions) + (installer-log-line "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 c218825813..9951ad2212 100644 --- a/gnu/installer/newt/services.scm +++ b/gnu/installer/newt/services.scm @@ -46,9 +46,7 @@ to choose from them later when you log in.") #:checkbox-tree-height 9 #:exit-button-callback-procedure (lambda () - (raise - (condition - (&installer-step-abort))))))) + (abort-to-prompt 'installer-step 'abort))))) (define (run-networking-cbt-page) "Run a page allowing the user to select networking services." @@ -65,9 +63,7 @@ system.") #:checkbox-tree-height 5 #:exit-button-callback-procedure (lambda () - (raise - (condition - (&installer-step-abort))))))) + (abort-to-prompt 'installer-step 'abort))))) (define (run-printing-services-cbt-page) "Run a page allowing the user to select document services such as CUPS." @@ -85,9 +81,7 @@ system.") #:checkbox-tree-height 9 #:exit-button-callback-procedure (lambda () - (raise - (condition - (&installer-step-abort))))))) + (abort-to-prompt 'installer-step 'abort))))) (define (run-console-services-cbt-page) "Run a page to select various system adminstration services for non-graphical @@ -130,9 +124,7 @@ client may be enough for a server.") #:button-text (G_ "Exit") #:button-callback-procedure (lambda _ - (raise - (condition - (&installer-step-abort))))))) + (abort-to-prompt 'installer-step 'abort))))) (define (run-services-page) (let ((desktop (run-desktop-environments-cbt-page))) diff --git a/gnu/installer/newt/timezone.scm b/gnu/installer/newt/timezone.scm index 67bf41ff84..bed9f9d5cb 100644 --- a/gnu/installer/newt/timezone.scm +++ b/gnu/installer/newt/timezone.scm @@ -65,9 +65,7 @@ returned." #:button-callback-procedure (if (null? path) (lambda _ - (raise - (condition - (&installer-step-abort)))) + (abort-to-prompt 'installer-step 'abort)) (lambda _ (loop (all-but-last path)))) #:listbox-callback-procedure diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm index 58bb86bf96..7c1cc2249d 100644 --- a/gnu/installer/newt/user.scm +++ b/gnu/installer/newt/user.scm @@ -20,7 +20,6 @@ (define-module (gnu installer newt user) #:use-module (gnu installer user) - #:use-module ((gnu installer steps) #:select (&installer-step-abort)) #:use-module (gnu installer newt page) #:use-module (gnu installer newt utils) #:use-module (gnu installer utils) @@ -144,7 +143,7 @@ REAL-NAME, and HOME-DIRECTORY as the initial values in the form." (name name) (real-name real-name) (home-directory home-directory) - (password password)) + (password (make-secret password))) (run-user-add-page #:name name #:real-name real-name #:home-directory @@ -257,9 +256,7 @@ administrator (\"root\").") (run users)) (reverse users)) ((components=? argument exit-button) - (raise - (condition - (&installer-step-abort)))))) + (abort-to-prompt 'installer-step 'abort)))) ('exit-fd-ready ;; Read the complete user list at once. (match argument @@ -269,7 +266,7 @@ administrator (\"root\").") (map (lambda (name real-name home password) (user (name name) (real-name real-name) (home-directory home) - (password password))) + (password (make-secret password)))) names real-names homes passwords)))))) (lambda () (destroy-form-and-pop form)))))) @@ -277,5 +274,5 @@ administrator (\"root\").") ;; Add a "root" user simply to convey the root password. (cons (user (name "root") (home-directory "/root") - (password (run-root-password-page))) + (password (make-secret (run-root-password-page)))) (run '()))) diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm index 5f461279e2..7a7ddfb7bd 100644 --- a/gnu/installer/newt/welcome.scm +++ b/gnu/installer/newt/welcome.scm @@ -84,7 +84,7 @@ we want this page to occupy all the screen space available." (string=? str (listbox-item->text item)))) keys) ((key . item) item) - (#f (raise (condition (&installer-step-abort)))))) + (#f (abort-to-prompt 'installer-step 'abort)))) (set-textbox-text logo-textbox (read-all logo)) diff --git a/gnu/installer/newt/wifi.scm b/gnu/installer/newt/wifi.scm index f5d8f1fdbf..8a87cbdf4b 100644 --- a/gnu/installer/newt/wifi.scm +++ b/gnu/installer/newt/wifi.scm @@ -237,9 +237,7 @@ force a wifi scan." (run-wifi-scan-page) (run-wifi-page)) ((components=? argument exit-button) - (raise - (condition - (&installer-step-abort)))) + (abort-to-prompt 'installer-step 'abort)) ((components=? argument listbox) (let ((result (connect-wifi-service listbox service-items))) (unless result |