From 61a2b3ca7d4afe3e3f77b77f59de3ad2f7159bfd Mon Sep 17 00:00:00 2001 From: Lars Ingebrigtsen Date: Tue, 24 Sep 2019 08:33:39 +0200 Subject: [PATCH] Allow scrolling the NSM window * lisp/net/nsm.el (nsm-query-user): Allow moving backwards/forwards in the NSM buffer if the window is too small to show all the details (bug#28069). --- lisp/net/nsm.el | 170 ++++++++++++++++++++++++++++-------------------- 1 file changed, 98 insertions(+), 72 deletions(-) diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index 11535a5a5a1..b8c84d5fdea 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -815,84 +815,110 @@ protocol." (defun nsm-query-user (message status) (let ((buffer (get-buffer-create "*Network Security Manager*")) (cert-buffer (get-buffer-create "*Certificate Details*")) - (certs (plist-get status :certificates))) + (certs (plist-get status :certificates)) + (accept-choices + '((?a "always" "Accept this certificate this session and for all future sessions.") + (?s "session only" "Accept this certificate this session only.") + (?n "no" "Refuse to use this certificate, and close the connection.") + (?d "details" "See certificate details"))) + (details-choices + '((?b "backward page" "See previous page") + (?f "forward page" "See next page") + (?n "next" "Next certificate") + (?p "previous" "Previous certificate") + (?q "quit" "Quit details view"))) + (done nil)) (save-window-excursion ;; First format the certificate and warnings. - (with-current-buffer-window - buffer nil nil - (when status (insert (nsm-format-certificate status))) - (insert message) - (goto-char (point-min)) - ;; Fill the first line of the message, which usually - ;; contains lots of explanatory text. - (fill-region (point) (line-end-position))) + (pop-to-buffer buffer) + (erase-buffer) + (let ((inhibit-read-only t)) + (when status + (insert (nsm-format-certificate status))) + (insert message) + (goto-char (point-min)) + ;; Fill the first line of the message, which usually + ;; contains lots of explanatory text. + (fill-region (point) (line-end-position)) + ;; If the window is too small, add navigation options. + (when (> (line-number-at-pos (point-max)) (window-height)) + (setq accept-choices + (append accept-choices + '((?b "backward page" "See previous page") + (?f "forward page" "See next page")))))) ;; Then ask the user what to do about it. (unwind-protect - (let* ((accept-choices '((?a "always" "Accept this certificate this session and for all future sessions.") - (?s "session only" "Accept this certificate this session only.") - (?n "no" "Refuse to use this certificate, and close the connection.") - (?d "details" "See certificate details"))) - (details-choices '((?b "backward page" "See previous page") - (?f "forward page" "See next page") - (?n "next" "Next certificate") - (?p "previous" "Previous certificate") - (?q "quit" "Quit details view"))) - (answer (read-multiple-choice "Continue connecting?" - accept-choices)) - (show-details (char-equal (car answer) ?d)) - (pems (cl-loop for cert in certs + (let* ((pems (cl-loop for cert in certs collect (gnutls-format-certificate (plist-get cert :pem)))) - (cert-index 0)) - (while show-details - (unless (get-buffer-window cert-buffer) - (set-window-buffer (get-buffer-window buffer) cert-buffer) - (with-current-buffer cert-buffer - (read-only-mode -1) - (insert (nth cert-index pems)) - (goto-char (point-min)) - (read-only-mode))) - - (setq answer (read-multiple-choice "Viewing certificate:" details-choices)) - - (cond - ((char-equal (car answer) ?q) - (setq show-details (not show-details)) - (set-window-buffer (get-buffer-window cert-buffer) buffer) - (setq show-details (char-equal - (car (setq answer - (read-multiple-choice - "Continue connecting?" - accept-choices))) - ?d))) - - ((char-equal (car answer) ?b) - (with-selected-window (get-buffer-window cert-buffer) - (with-current-buffer cert-buffer - (ignore-errors (scroll-down))))) - - ((char-equal (car answer) ?f) - (with-selected-window (get-buffer-window cert-buffer) - (with-current-buffer cert-buffer - (ignore-errors (scroll-up))))) - - ((char-equal (car answer) ?n) - (with-current-buffer cert-buffer - (read-only-mode -1) - (erase-buffer) - (setq cert-index (mod (1+ cert-index) (length pems))) - (insert (nth cert-index pems)) - (goto-char (point-min)) - (read-only-mode))) - - ((char-equal (car answer) ?p) - (with-current-buffer cert-buffer - (read-only-mode -1) - (erase-buffer) - (setq cert-index (mod (1- cert-index) (length pems))) - (insert (nth cert-index pems)) - (goto-char (point-min)) - (read-only-mode))))) + (cert-index 0) + show-details answer buf) + (while (not done) + (setq answer (if show-details + (read-multiple-choice "Viewing certificate:" + details-choices) + (read-multiple-choice "Continue connecting?" + accept-choices))) + (setq buf (if show-details cert-buffer buffer)) + + (cl-case (car answer) + (?q + ;; Exit the details window. + (set-window-buffer (get-buffer-window cert-buffer) buffer) + (setq show-details nil)) + + (?d + ;; Enter the details window. + (set-window-buffer (get-buffer-window buffer) cert-buffer) + (with-current-buffer cert-buffer + (read-only-mode -1) + (insert (nth cert-index pems)) + (goto-char (point-min)) + (read-only-mode)) + (setq show-details t)) + + (?b + ;; Scroll down. + (with-selected-window (get-buffer-window buf) + (with-current-buffer buf + (ignore-errors (scroll-down))))) + + (?f + ;; Scroll up. + (with-selected-window (get-buffer-window buf) + (with-current-buffer buf + (ignore-errors (scroll-up))))) + + (?n + ;; "No" or "next certificate". + (if show-details + (with-current-buffer cert-buffer + (read-only-mode -1) + (erase-buffer) + (setq cert-index (mod (1+ cert-index) (length pems))) + (insert (nth cert-index pems)) + (goto-char (point-min)) + (read-only-mode)) + (setq done t))) + + (?a + ;; "Always" + (setq done t)) + + (?s + ;; "Session only" + (setq done t)) + + (?p + ;; Previous certificate. + (with-current-buffer cert-buffer + (read-only-mode -1) + (erase-buffer) + (setq cert-index (mod (1- cert-index) (length pems))) + (insert (nth cert-index pems)) + (goto-char (point-min)) + (read-only-mode))))) + ;; Return the answer. (cadr answer)) (kill-buffer cert-buffer) (kill-buffer buffer))))) -- 2.39.2