[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/02: DRAFT installer: Implement a dialog on /var/guix/installer-socket
|
From: |
guix-commits |
|
Subject: |
02/02: DRAFT installer: Implement a dialog on /var/guix/installer-socket. |
|
Date: |
Sun, 9 Feb 2020 18:04:56 -0500 (EST) |
civodul pushed a commit to branch wip-installer-test
in repository guix.
commit a25df1e04a6dd6a18ff7c818f6f9aeed8bdf08d5
Author: Ludovic Courtès <address@hidden>
AuthorDate: Wed Jan 22 22:57:14 2020 +0100
DRAFT installer: Implement a dialog on /var/guix/installer-socket.
DRAFT We might need to instrument some more pages.
This will allow us to automate testing of the installer.
* gnu/installer/utils.scm (%client-socket-file)
(current-server-socket, current-clients): New variables.
(open-server-socket, call-with-server-socket): New procedure.
(with-server-socket): New macro.
(run-shell-command): Add call to 'send-to-clients'. Select on both
current-input-port and current-clients.
* gnu/installer/steps.scm (run-installer-steps): Wrap 'call-with-prompt'
in 'with-socket-server'.
* gnu/installer/newt/page.scm (watch-clients!, call-with-client): New
procedures.
(with-client): New macro.
(send-to-clients): New procedures.
(draw-info-page): Add call to 'send-to-clients'.
(run-input-page): Add calls to 'watch-clients!' and 'send-to-clients'.
Handle EXIT-REASON equal to 'exit-fd-ready.
(run-confirmation-page): Likewise.
(run-listbox-selection-page): Add #:client-callback-procedure
parameter. Wrap body in 'loop'. Add calls to 'watch-clients!' and
'send-to-clients'. Define 'choice->item' and use it.
(run-checkbox-tree-page): Likewise.
(run-file-textbox-page): Add calls to 'watch-clients!' and
'send-to-clients'. Handle 'exit-fd-ready'.
* gnu/installer/newt/partition.scm (run-disk-page): Pass
#:client-callback-procedure to 'run-listbox-selection-page'.
* gnu/installer/newt/user.scm (run-user-page): Add calls to
'watch-clients!' and 'send-to-clients'. Handle 'exit-fd-ready'.
* gnu/installer/newt/welcome.scm (run-menu-page): Define
'choice->item' and use it. Add calls to 'watch-clients!' and
'send-to-clients'. Wrap body in 'loop'.
---
gnu/installer/newt/page.scm | 531 ++++++++++++++++++++++++---------------
gnu/installer/newt/partition.scm | 8 +-
gnu/installer/newt/user.scm | 69 +++--
gnu/installer/newt/welcome.scm | 59 +++--
gnu/installer/steps.scm | 21 +-
gnu/installer/utils.scm | 70 +++++-
6 files changed, 510 insertions(+), 248 deletions(-)
diff --git a/gnu/installer/newt/page.scm b/gnu/installer/newt/page.scm
index 8aea5a1..ac43763 100644
--- a/gnu/installer/newt/page.scm
+++ b/gnu/installer/newt/page.scm
@@ -19,6 +19,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu installer newt page)
+ #:use-module (gnu installer steps)
#:use-module (gnu installer utils)
#:use-module (gnu installer newt utils)
#:use-module (guix i18n)
@@ -27,6 +28,8 @@
#:use-module (ice-9 receive)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (newt)
#:export (draw-info-page
draw-connecting-page
@@ -36,7 +39,10 @@
run-listbox-selection-page
run-scale-page
run-checkbox-tree-page
- run-file-textbox-page))
+ run-file-textbox-page
+
+ watch-clients!
+ with-client))
;;; Commentary:
;;;
@@ -49,9 +55,46 @@
;;;
;;; Code:
+(define (watch-clients! form)
+ "Have FORM watch the file descriptors corresponding to current client
+connections. Consequently, FORM may exit with the 'exit-fd-ready' reason."
+ (when (current-server-socket)
+ (form-watch-fd form (fileno (current-server-socket))
+ FD-READ))
+
+ (for-each (lambda (client)
+ (form-watch-fd form (fileno client)
+ (logior FD-READ FD-EXCEPT)))
+ (current-clients)))
+
+(define (call-with-client fd proc fallback)
+ (match (fdes->ports fd)
+ ((port _ ...)
+ (if (memq port (current-clients))
+ (if (catch 'system-error
+ (lambda ()
+ (eof-object? (peek-char port)))
+ (const #t)) ;ECONNRESET, etc.
+ (begin
+ (close-port port)
+ (current-clients (delq port (current-clients)))
+ (fallback))
+ (proc port))
+ (match (accept port)
+ ((client . _)
+ (current-clients (cons client (current-clients)))
+ (fallback)))))))
+
+(define-syntax-rule (with-client fd port exp fallback)
+ "Evaluate EXP with PORT bound to the client connection corresponding to FD.
+Alternately, if FD is not available for reading (e.g., because the client
+disconnected), evaluate FALLBACK."
+ (call-with-client fd (lambda (port) exp) (lambda () fallback)))
+
(define (draw-info-page text title)
"Draw an informative page with the given TEXT as content. Set the title of
this page to TITLE."
+ (send-to-clients `(info (title ,title) (text ,text)))
(let* ((text-box
(make-reflowed-textbox -1 -1 text 40
#:flags FLAG-BORDER))
@@ -109,6 +152,11 @@ input box, such as FLAG-PASSWORD."
GRID-ELEMENT-COMPONENT ok-button))
(form (make-form #:flags FLAG-NOF12)))
+ (watch-clients! form)
+ (send-to-clients
+ `(input (title ,title) (text ,text)
+ (default ,default-text)))
+
(add-component-callback
input-visible-cb
(lambda (component)
@@ -127,19 +175,24 @@ input box, such as FLAG-PASSWORD."
(let loop ()
(receive (exit-reason argument)
(run-form form)
- (let ((input (entry-value input-entry)))
- (if (and (not allow-empty-input?)
- (eq? exit-reason 'exit-component)
- (string=? input ""))
- (begin
- ;; Display the error page.
- (error-page)
- ;; Set the focus back to the input input field.
- (set-current-component form input-entry)
- (loop))
- (begin
- (destroy-form-and-pop form)
- input))))))))
+ (let ((input (if (eq? exit-reason 'exit-fd-ready)
+ (with-client argument port
+ (read port)
+ #f)
+ (entry-value input-entry))))
+ (cond ((not input) ;client disconnect or something
+ (loop))
+ ((and (not allow-empty-input?)
+ (eq? exit-reason 'exit-component)
+ (string=? input ""))
+ ;; Display the error page.
+ (error-page)
+ ;; Set the focus back to the input input field.
+ (set-current-component form input-entry)
+ (loop))
+ (else
+ (destroy-form-and-pop form)
+ input))))))))
(define (run-error-page text title)
"Run a page to inform the user of an error. The page contains the given TEXT
@@ -186,18 +239,28 @@ of the page is set to TITLE."
(add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title)
+ (watch-clients! form)
+ (send-to-clients
+ `(confirmation (title ,title) (text ,text)))
+
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
- (case exit-reason
- ((exit-component)
+ (match exit-reason
+ ('exit-component
(cond
((components=? argument ok-button)
#t)
((components=? argument exit-button)
- (exit-button-procedure))))))
+ (exit-button-procedure))))
+ ('exit-fd-ready
+ (with-client argument port
+ (if (read port)
+ #t
+ (exit-button-procedure))
+ #f)))) ;FIXME: retry
(lambda ()
(destroy-form-and-pop form))))))
@@ -222,6 +285,8 @@ of the page is set to TITLE."
(const #t))
(listbox-callback-procedure
identity)
+ (client-callback-procedure
+ listbox-callback-procedure)
(hotkey-callback-procedure
(const #t)))
"Run a page asking the user to select an item in a listbox. The page
@@ -254,9 +319,9 @@ Each time the listbox current item changes, call
SKIP-ITEM-PROCEDURE? with the
current listbox item as argument. If it returns #t, skip the element and jump
to the next/previous one depending on the previous item, otherwise do
nothing."
-
- (define (fill-listbox listbox items)
- "Append the given ITEMS to LISTBOX, once they have been converted to text
+ (let loop ()
+ (define (fill-listbox listbox items)
+ "Append the given ITEMS to LISTBOX, once they have been converted to text
with LISTBOX-ITEM->TEXT. Each item appended to the LISTBOX is given a key by
newt. Save this key by returning an association list under the form:
@@ -264,144 +329,176 @@ newt. Save this key by returning an association list
under the form:
where NEWT-LISTBOX-KEY is the key returned by APPEND-ENTRY-TO-LISTBOX, when
ITEM was inserted into LISTBOX."
- (map (lambda (item)
- (let* ((text (listbox-item->text item))
- (key (append-entry-to-listbox listbox text)))
- (cons key item)))
- items))
-
- (define (sort-listbox-items listbox-items)
- "Return LISTBOX-ITEMS sorted using the 'string-locale<?' procedure on the
text
+ (map (lambda (item)
+ (let* ((text (listbox-item->text item))
+ (key (append-entry-to-listbox listbox text)))
+ (cons key item)))
+ items))
+
+ (define (sort-listbox-items listbox-items)
+ "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)))
- listbox-items))
- (sorted-items
- (sort items (lambda (a b)
- (let ((text-a (cdr a))
- (text-b (cdr b)))
- (string-locale<? text-a text-b))))))
- (map car sorted-items)))
-
- ;; Store the last selected listbox item's key.
- (define last-listbox-key (make-parameter #f))
-
- (define (previous-key keys key)
- (let ((index (list-index (cut eq? key <>) keys)))
- (and index
- (> index 0)
- (list-ref keys (- index 1)))))
-
- (define (next-key keys key)
- (let ((index (list-index (cut eq? key <>) keys)))
- (and index
- (< index (- (length keys) 1))
- (list-ref keys (+ index 1)))))
-
- (define (set-default-item listbox listbox-keys default-item)
- "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
+ (let* ((items (map (lambda (item)
+ (cons item (listbox-item->text item)))
+ listbox-items))
+ (sorted-items
+ (sort items (lambda (a b)
+ (let ((text-a (cdr a))
+ (text-b (cdr b)))
+ (string-locale<? text-a text-b))))))
+ (map car sorted-items)))
+
+ ;; Store the last selected listbox item's key.
+ (define last-listbox-key (make-parameter #f))
+
+ (define (previous-key keys key)
+ (let ((index (list-index (cut eq? key <>) keys)))
+ (and index
+ (> index 0)
+ (list-ref keys (- index 1)))))
+
+ (define (next-key keys key)
+ (let ((index (list-index (cut eq? key <>) keys)))
+ (and index
+ (< index (- (length keys) 1))
+ (list-ref keys (+ index 1)))))
+
+ (define (set-default-item listbox listbox-keys default-item)
+ "Set the default item of LISTBOX to DEFAULT-ITEM. LISTBOX-KEYS is the
association list returned by the FILL-LISTBOX procedure. It is used because
the current listbox item has to be selected by key."
- (for-each (match-lambda
- ((key . item)
- (when (equal? item default-item)
- (set-current-listbox-entry-by-key listbox key))))
- listbox-keys))
-
- (let* ((listbox (make-listbox
- -1 -1
- listbox-height
- (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
- (if listbox-allow-multiple?
- FLAG-MULTIPLE
- 0))))
- (form (make-form #:flags FLAG-NOF12))
- (info-textbox
- (make-reflowed-textbox -1 -1 info-text
- info-textbox-width
- #:flags FLAG-BORDER))
- (button (make-button -1 -1 button-text))
- (button2 (and button2-text
- (make-button -1 -1 button2-text)))
- (grid (vertically-stacked-grid
- GRID-ELEMENT-COMPONENT info-textbox
- GRID-ELEMENT-COMPONENT listbox
- GRID-ELEMENT-SUBGRID
- (apply
- horizontal-stacked-grid
- GRID-ELEMENT-COMPONENT button
- `(,@(if button2
- (list GRID-ELEMENT-COMPONENT button2)
- '())))))
- (sorted-items (if sort-listbox-items?
- (sort-listbox-items listbox-items)
- listbox-items))
- (keys (fill-listbox listbox sorted-items)))
-
- ;; 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,
- ;; do nothing.
- (add-component-callback
- listbox
- (lambda (component)
- (let* ((current-key (current-listbox-entry listbox))
- (listbox-keys (map car keys))
- (last-key (last-listbox-key))
- (item (assoc-ref keys current-key))
- (prev-key (previous-key listbox-keys current-key))
- (next-key (next-key listbox-keys current-key)))
- ;; Update last-listbox-key before a potential call to
- ;; set-current-listbox-entry-by-key, because it will immediately
- ;; cause this callback to be called for the new entry.
- (last-listbox-key current-key)
- (when (skip-item-procedure? item)
- (when (eq? prev-key last-key)
- (if next-key
- (set-current-listbox-entry-by-key listbox next-key)
- (set-current-listbox-entry-by-key listbox prev-key)))
- (when (eq? next-key last-key)
- (if prev-key
- (set-current-listbox-entry-by-key listbox prev-key)
- (set-current-listbox-entry-by-key listbox next-key)))))))
-
- (when listbox-default-item
- (set-default-item listbox keys listbox-default-item))
-
- (when allow-delete?
- (form-add-hotkey form KEY-DELETE))
+ (for-each (match-lambda
+ ((key . item)
+ (when (equal? item default-item)
+ (set-current-listbox-entry-by-key listbox key))))
+ listbox-keys))
+
+ (let* ((listbox (make-listbox
+ -1 -1
+ listbox-height
+ (logior FLAG-SCROLL FLAG-BORDER FLAG-RETURNEXIT
+ (if listbox-allow-multiple?
+ FLAG-MULTIPLE
+ 0))))
+ (form (make-form #:flags FLAG-NOF12))
+ (info-textbox
+ (make-reflowed-textbox -1 -1 info-text
+ info-textbox-width
+ #:flags FLAG-BORDER))
+ (button (make-button -1 -1 button-text))
+ (button2 (and button2-text
+ (make-button -1 -1 button2-text)))
+ (grid (vertically-stacked-grid
+ GRID-ELEMENT-COMPONENT info-textbox
+ GRID-ELEMENT-COMPONENT listbox
+ GRID-ELEMENT-SUBGRID
+ (apply
+ horizontal-stacked-grid
+ GRID-ELEMENT-COMPONENT button
+ `(,@(if button2
+ (list GRID-ELEMENT-COMPONENT button2)
+ '())))))
+ (sorted-items (if sort-listbox-items?
+ (sort-listbox-items listbox-items)
+ listbox-items))
+ (keys (fill-listbox listbox sorted-items)))
+
+ (define (choice->item str)
+ ;; Return the item that corresponds to STR.
+ (match (find (match-lambda
+ ((key . item)
+ (string=? str (listbox-item->text item))))
+ keys)
+ ((key . item) item)
+ (#f (raise (condition (&installer-step-abort))))))
+
+ (watch-clients! form)
+
+ ;; 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,
+ ;; do nothing.
+ (add-component-callback
+ listbox
+ (lambda (component)
+ (let* ((current-key (current-listbox-entry listbox))
+ (listbox-keys (map car keys))
+ (last-key (last-listbox-key))
+ (item (assoc-ref keys current-key))
+ (prev-key (previous-key listbox-keys current-key))
+ (next-key (next-key listbox-keys current-key)))
+ ;; Update last-listbox-key before a potential call to
+ ;; set-current-listbox-entry-by-key, because it will immediately
+ ;; cause this callback to be called for the new entry.
+ (last-listbox-key current-key)
+ (when (skip-item-procedure? item)
+ (when (eq? prev-key last-key)
+ (if next-key
+ (set-current-listbox-entry-by-key listbox next-key)
+ (set-current-listbox-entry-by-key listbox prev-key)))
+ (when (eq? next-key last-key)
+ (if prev-key
+ (set-current-listbox-entry-by-key listbox prev-key)
+ (set-current-listbox-entry-by-key listbox next-key)))))))
+
+ (when listbox-default-item
+ (set-default-item listbox keys listbox-default-item))
+
+ (when allow-delete?
+ (form-add-hotkey form KEY-DELETE))
- (add-form-to-grid grid form #t)
- (make-wrapped-grid-window grid title)
+ (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 button)
- (button-callback-procedure))
- ((and button2
- (components=? argument button2))
- (button2-callback-procedure))
- ((components=? argument listbox)
- (if listbox-allow-multiple?
- (let* ((entries (listbox-selection listbox))
- (items (map (lambda (entry)
- (assoc-ref keys entry))
- entries)))
- (listbox-callback-procedure items))
- (let* ((entry (current-listbox-entry listbox))
- (item (assoc-ref keys entry)))
- (listbox-callback-procedure item))))))
- ((exit-hotkey)
- (let* ((entry (current-listbox-entry listbox))
- (item (assoc-ref keys entry)))
- (hotkey-callback-procedure argument item)))))
- (lambda ()
- (destroy-form-and-pop form))))))
+ (send-to-clients
+ `(list-selection (title ,title)
+ (multiple-choices? ,listbox-allow-multiple?)
+ (items ,(map listbox-item->text listbox-items))))
+
+ (receive (exit-reason argument)
+ (run-form form)
+ (define &retry
+ (list 'retry))
+
+ (define result
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (match exit-reason
+ ('exit-component
+ (cond
+ ((components=? argument button)
+ (button-callback-procedure))
+ ((and button2
+ (components=? argument button2))
+ (button2-callback-procedure))
+ ((components=? argument listbox)
+ (if listbox-allow-multiple?
+ (let* ((entries (listbox-selection listbox))
+ (items (map (lambda (entry)
+ (assoc-ref keys entry))
+ entries)))
+ (listbox-callback-procedure items))
+ (let* ((entry (current-listbox-entry listbox))
+ (item (assoc-ref keys entry)))
+ (listbox-callback-procedure item))))))
+ ('exit-fd-ready
+ (with-client argument port
+ (let* ((choice (read port))
+ (item (if listbox-allow-multiple?
+ (map choice->item choice)
+ (choice->item choice))))
+ (client-callback-procedure item))
+ &retry))
+ ('exit-hotkey
+ (let* ((entry (current-listbox-entry listbox))
+ (item (assoc-ref keys entry)))
+ (hotkey-callback-procedure argument item)))))
+ (lambda ()
+ (destroy-form-and-pop form))))
+
+ (if (eq? &retry result)
+ (loop)
+ result)))))
(define* (run-scale-page #:key
title
@@ -498,48 +595,75 @@ ITEMS when 'Ok' is pressed."
items
selection))
- (let* ((checkbox-tree
- (make-checkboxtree -1 -1
- checkbox-tree-height
- FLAG-BORDER))
- (info-textbox
- (make-reflowed-textbox -1 -1 info-text
- info-textbox-width
- #:flags FLAG-BORDER))
- (ok-button (make-button -1 -1 (G_ "OK")))
- (exit-button (make-button -1 -1 (G_ "Exit")))
- (grid (vertically-stacked-grid
- GRID-ELEMENT-COMPONENT info-textbox
- GRID-ELEMENT-COMPONENT checkbox-tree
- GRID-ELEMENT-SUBGRID
- (horizontal-stacked-grid
- GRID-ELEMENT-COMPONENT ok-button
- GRID-ELEMENT-COMPONENT exit-button)))
- (keys (fill-checkbox-tree checkbox-tree items))
- (form (make-form #:flags FLAG-NOF12)))
+ (let loop ()
+ (let* ((checkbox-tree
+ (make-checkboxtree -1 -1
+ checkbox-tree-height
+ FLAG-BORDER))
+ (info-textbox
+ (make-reflowed-textbox -1 -1 info-text
+ info-textbox-width
+ #:flags FLAG-BORDER))
+ (ok-button (make-button -1 -1 (G_ "OK")))
+ (exit-button (make-button -1 -1 (G_ "Exit")))
+ (grid (vertically-stacked-grid
+ GRID-ELEMENT-COMPONENT info-textbox
+ GRID-ELEMENT-COMPONENT checkbox-tree
+ GRID-ELEMENT-SUBGRID
+ (horizontal-stacked-grid
+ GRID-ELEMENT-COMPONENT ok-button
+ GRID-ELEMENT-COMPONENT exit-button)))
+ (keys (fill-checkbox-tree checkbox-tree items))
+ (form (make-form #:flags FLAG-NOF12)))
- (add-form-to-grid grid form #t)
- (make-wrapped-grid-window grid title)
+ (define (choice->item str)
+ ;; Return the item that corresponds to STR.
+ (match (find (match-lambda
+ ((key . item)
+ (string=? str (item->text item))))
+ keys)
+ ((key . item) item)
+ (#f (raise (condition (&installer-step-abort))))))
- (receive (exit-reason argument)
- (run-form form)
- (dynamic-wind
- (const #t)
- (lambda ()
- (case exit-reason
- ((exit-component)
- (cond
- ((components=? argument ok-button)
- (let* ((entries (current-checkbox-selection checkbox-tree))
- (current-items (map (lambda (entry)
- (assoc-ref keys entry))
- entries)))
- (ok-button-callback-procedure)
- current-items))
- ((components=? argument exit-button)
- (exit-button-callback-procedure))))))
- (lambda ()
- (destroy-form-and-pop form))))))
+ (add-form-to-grid grid form #t)
+ (make-wrapped-grid-window grid title)
+
+ (watch-clients! form)
+ (send-to-clients
+ `(checkbox-list (title ,title) (text ,info-text)
+ (items ,(map item->text items))))
+
+ (receive (exit-reason argument)
+ (run-form form)
+ (define &retry
+ (list 'retry))
+
+ (define result
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (match exit-reason
+ ('exit-component
+ (cond
+ ((components=? argument ok-button)
+ (let* ((entries (current-checkbox-selection checkbox-tree))
+ (current-items (map (lambda (entry)
+ (assoc-ref keys entry))
+ entries)))
+ (ok-button-callback-procedure)
+ current-items))
+ ((components=? argument exit-button)
+ (exit-button-callback-procedure))))
+ ('exit-fd-ready
+ (with-client argument port
+ (map choice->item (read port))
+ &retry))))
+ (lambda ()
+ (destroy-form-and-pop form))))
+
+ (if (eq? result &retry)
+ (loop)
+ result)))))
(define* (edit-file file #:key locale)
"Spawn an editor for FILE."
@@ -595,6 +719,12 @@ ITEMS when 'Ok' is pressed."
'())))))
(form (make-form #:flags FLAG-NOF12)))
+ (watch-clients! form)
+ (send-to-clients
+ `(file-dialog (title ,title)
+ (text ,info-text)
+ (file ,file)))
+
(add-form-to-grid grid form #t)
(make-wrapped-grid-window grid title)
@@ -611,8 +741,8 @@ ITEMS when 'Ok' is pressed."
(dynamic-wind
(const #t)
(lambda ()
- (case exit-reason
- ((exit-component)
+ (match exit-reason
+ ('exit-component
(cond
((components=? argument ok-button)
(ok-button-callback-procedure))
@@ -621,10 +751,17 @@ ITEMS when 'Ok' is pressed."
(exit-button-callback-procedure))
((and edit-button?
(components=? argument edit-button))
- (edit-file file))))))
+ (edit-file file))))
+ ('exit-fd-ready
+ (with-client argument port
+ (if (read port)
+ (ok-button-callback-procedure)
+ (exit-button-callback-procedure))
+ #f)))) ;FIXME: retry
(lambda ()
(destroy-form-and-pop form))))
- (if (components=? argument edit-button)
+ (if (and (eq? exit-reason 'exit-component)
+ (components=? argument edit-button))
(loop) ;recurse in tail position
result)))))
diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm
index 3cba7f7..c925e41 100644
--- a/gnu/installer/newt/partition.scm
+++ b/gnu/installer/newt/partition.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019 Mathieu Othacehe <address@hidden>
-;;; Copyright © 2019 Ludovic Courtès <address@hidden>
+;;; Copyright © 2019, 2020 Ludovic Courtès <address@hidden>
;;; Copyright © 2020 Tobias Geerinckx-Rice <address@hidden>
;;;
;;; This file is part of GNU Guix.
@@ -682,6 +682,12 @@ by pressing the Exit button.~%~%")))
#:allow-delete? #t
#:button-text (G_ "OK")
#:button-callback-procedure button-ok-action
+
+ ;; Consider client replies equivalent to hitting the "OK" button.
+ ;; XXX: In practice this means that clients cannot do anything but
+ ;; approve the predefined list of partitions.
+ #:client-callback-procedure (lambda (_) (button-ok-action))
+
#:button2-text (G_ "Exit")
#:button2-callback-procedure button-exit-action
#:listbox-callback-procedure listbox-action
diff --git a/gnu/installer/newt/user.scm b/gnu/installer/newt/user.scm
index b01d521..ae54268 100644
--- a/gnu/installer/newt/user.scm
+++ b/gnu/installer/newt/user.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <address@hidden>
-;;; Copyright © 2019 Ludovic Courtès <address@hidden>
+;;; Copyright © 2019, 2020 Ludovic Courtès <address@hidden>
;;; Copyright © 2019 Tobias Geerinckx-Rice <address@hidden>
;;;
;;; This file is part of GNU Guix.
@@ -23,6 +23,7 @@
#: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)
#:use-module (guix i18n)
#:use-module (newt)
#:use-module (ice-9 match)
@@ -115,6 +116,7 @@ REAL-NAME, and HOME-DIRECTORY as the initial values in the
form."
GRID-ELEMENT-SUBGRID entry-grid
GRID-ELEMENT-SUBGRID button-grid)
title)
+
(let ((error-page
(lambda ()
(run-error-page (G_ "Empty inputs are not allowed.")
@@ -229,34 +231,53 @@ administrator (\"root\").")
(set-current-component form add-button)
(set-current-component form ok-button))
+ (watch-clients! form)
+ (send-to-clients `(add-users))
+
(receive (exit-reason argument)
(run-form form)
(dynamic-wind
(const #t)
(lambda ()
- (when (eq? exit-reason 'exit-component)
- (cond
- ((components=? argument add-button)
- (run (cons (run-user-add-page) users)))
- ((components=? argument del-button)
- (let* ((current-user-key (current-listbox-entry listbox))
- (users
- (map (cut assoc-ref <> 'user)
- (remove (lambda (element)
- (equal? (assoc-ref element 'key)
- current-user-key))
- listbox-elements))))
- (run users)))
- ((components=? argument ok-button)
- (when (null? users)
- (run-error-page (G_ "Please create at least one user.")
- (G_ "No user"))
- (run users))
- (reverse users))
- ((components=? argument exit-button)
- (raise
- (condition
- (&installer-step-abort)))))))
+ (match exit-reason
+ ('exit-component
+ (cond
+ ((components=? argument add-button)
+ (run (cons (run-user-add-page) users)))
+ ((components=? argument del-button)
+ (let* ((current-user-key (current-listbox-entry listbox))
+ (users
+ (map (cut assoc-ref <> 'user)
+ (remove (lambda (element)
+ (equal? (assoc-ref element 'key)
+ current-user-key))
+ listbox-elements))))
+ (run users)))
+ ((components=? argument ok-button)
+ (when (null? users)
+ (run-error-page (G_ "Please create at least one user.")
+ (G_ "No user"))
+ (run users))
+ (reverse users))
+ ((components=? argument exit-button)
+ (raise
+ (condition
+ (&installer-step-abort))))))
+ ('exit-fd-ready
+ ;; Read the complete user list at once.
+ (with-client argument port
+ (match (read port)
+ ((('user ('name names) ('real-name real-names)
+ ('home-directory homes) ('password passwords))
+ ..1)
+ (map (lambda (name real-name home password)
+ (user (name name) (real-name real-name)
+ (home-directory home)
+ (password password)))
+ names real-names homes passwords)))
+ (raise
+ (condition
+ (&installer-step-abort)))))))
(lambda ()
(destroy-form-and-pop form))))))
diff --git a/gnu/installer/newt/welcome.scm b/gnu/installer/newt/welcome.scm
index aec3e7a..3fac57d 100644
--- a/gnu/installer/newt/welcome.scm
+++ b/gnu/installer/newt/welcome.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <address@hidden>
+;;; Copyright © 2020 Ludovic Courtès <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -11,16 +12,20 @@
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu installer newt welcome)
+ #:use-module (gnu installer steps)
#:use-module (gnu installer utils)
+ #:use-module (gnu installer newt page)
#:use-module (gnu installer newt utils)
#:use-module (guix build syscalls)
#:use-module (guix i18n)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (newt)
@@ -66,26 +71,48 @@ we want this page to occupy all the screen space available."
GRID-ELEMENT-COMPONENT options-listbox))
(form (make-form)))
+ (define (choice->item str)
+ ;; Return the item that corresponds to STR.
+ (match (find (match-lambda
+ ((key . item)
+ (string=? str (listbox-item->text item))))
+ keys)
+ ((key . item) item)
+ (#f (raise (condition (&installer-step-abort))))))
+
(set-textbox-text logo-textbox (read-all logo))
(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 ()
- (when (eq? exit-reason 'exit-component)
- (cond
- ((components=? argument options-listbox)
- (let* ((entry (current-listbox-entry options-listbox))
- (item (assoc-ref keys entry)))
- (match item
- ((text . proc)
- (proc))))))))
- (lambda ()
- (destroy-form-and-pop form))))))
+ (watch-clients! form)
+ (send-to-clients
+ `(menu (title ,title) (text ,info-text)
+ (items ,(map listbox-item->text listbox-items))))
+
+ (let loop ()
+ (receive (exit-reason argument)
+ (run-form form)
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (match exit-reason
+ ('exit-component
+ (let* ((entry (current-listbox-entry options-listbox))
+ (item (assoc-ref keys entry)))
+ (match item
+ ((text . proc)
+ (proc)))))
+ ('exit-fd-ready
+ (with-client argument port
+ (let* ((choice (read port))
+ (item (choice->item choice)))
+ (match item
+ ((text . proc)
+ (proc))))
+ (loop)))))
+ (lambda ()
+ (destroy-form-and-pop form)))))))
(define (run-welcome-page logo)
"Run a welcome page with the given textual LOGO displayed at the center of
diff --git a/gnu/installer/steps.scm b/gnu/installer/steps.scm
index 4e90f32..e1a257b 100644
--- a/gnu/installer/steps.scm
+++ b/gnu/installer/steps.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019 Mathieu Othacehe <address@hidden>
+;;; Copyright © 2020 Ludovic Courtès <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -19,6 +20,7 @@
(define-module (gnu installer steps)
#:use-module (guix records)
#:use-module (guix build utils)
+ #:use-module (gnu installer utils)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
@@ -184,13 +186,14 @@ return the accumalated result so far."
#:todo-steps rest-steps
#:done-steps (append done-steps (list step))))))))
- (call-with-prompt 'raise-above
- (lambda ()
- (run '()
- #:todo-steps steps
- #:done-steps '()))
- (lambda (k condition)
- (raise condition))))
+ (with-server-socket
+ (call-with-prompt 'raise-above
+ (lambda ()
+ (run '()
+ #:todo-steps steps
+ #:done-steps '()))
+ (lambda (k condition)
+ (raise condition)))))
(define (find-step-by-id steps id)
"Find and return the step in STEPS whose id is equal to ID."
@@ -248,3 +251,7 @@ found in RESULTS."
(pretty-print part port)))
configuration)
(flush-output-port port))))
+
+;;; Local Variables:
+;;; eval: (put 'with-server-socket 'scheme-indent-function 0)
+;;; End:
diff --git a/gnu/installer/utils.scm b/gnu/installer/utils.scm
index ddb96bc..987b99e 100644
--- a/gnu/installer/utils.scm
+++ b/gnu/installer/utils.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Mathieu Othacehe <address@hidden>
-;;; Copyright © 2019 Ludovic Courtès <address@hidden>
+;;; Copyright © 2019, 2020 Ludovic Courtès <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,6 +22,7 @@
#:use-module (guix build utils)
#:use-module (guix i18n)
#:use-module (srfi srfi-34)
+ #:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 textual-ports)
@@ -29,7 +30,12 @@
read-all
nearest-exact-integer
read-percentage
- run-shell-command))
+ run-shell-command
+
+ with-server-socket
+ current-server-socket
+ current-clients
+ send-to-clients))
(define* (read-lines #:optional (port (current-input-port)))
"Read lines from PORT and return them as a list."
@@ -62,7 +68,11 @@ number. If no percentage is found, return #f"
COMMAND exited successfully, #f otherwise."
(define (pause)
(format #t (G_ "Press Enter to continue.~%"))
- (read-line (current-input-port)))
+ (send-to-clients '(pause))
+ (match (select (cons (current-input-port) (current-clients))
+ '() '())
+ (((port _ ...) _ _)
+ (read-line port))))
(call-with-temporary-output-file
(lambda (file port)
@@ -91,3 +101,57 @@ COMMAND exited successfully, #f otherwise."
(newline)
(pause)
#t))))
+
+
+;;;
+;;; Client protocol.
+;;;
+
+(define %client-socket-file
+ ;; Unix-domain socket where the installer accepts connections.
+ "/var/guix/installer-socket")
+
+(define current-server-socket
+ ;; Socket on which the installer is currently accepting connections, or #f.
+ (make-parameter #f))
+
+(define current-clients
+ ;; List of currently connected clients.
+ (make-parameter '()))
+
+(define* (open-server-socket
+ #:optional (socket-file %client-socket-file))
+ "Open SOCKET-FILE as a Unix-domain socket to accept incoming connections and
+return it."
+ (mkdir-p (dirname socket-file))
+ (when (file-exists? socket-file)
+ (delete-file socket-file))
+ (let ((sock (socket AF_UNIX SOCK_STREAM 0)))
+ (bind sock AF_UNIX socket-file)
+ (listen sock 0)
+ sock))
+
+(define (call-with-server-socket thunk)
+ (if (current-server-socket)
+ (thunk)
+ (let ((socket (open-server-socket)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (parameterize ((current-server-socket socket))
+ (thunk)))
+ (lambda ()
+ (close-port socket))))))
+
+(define-syntax-rule (with-server-socket exp ...)
+ "Evaluate EXP with 'current-server-socket' parameterized to a currently
+accepting socket."
+ (call-with-server-socket (lambda () exp ...)))
+
+(define (send-to-clients exp)
+ "Send EXP to all the current clients."
+ (for-each (lambda (client)
+ (write exp client)
+ (newline client)
+ (force-output client))
+ (current-clients)))