Github/emacs
2
0
Fork 1
mirror of git://git.sv.gnu.org/emacs.git synced 2026-02-16 09:14:18 +00:00
Code Issues Projects Releases Packages Wiki Activity

Allow scrolling the NSM window

Browse source 
* 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).
This commit is contained in:
Lars Ingebrigtsen 2019-09-24 08:33:39 +02:00
parent d3f8279422
commit 61a2b3ca7d
1 changed files with 92 additions and 66 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

158
lisp/net/nsm.el
View file

@ -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)))
(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))
(setq answer (read-multiple-choice "Viewing certificate:" details-choices))
(cl-case (car answer)
(?q
;; Exit the details window.
(set-window-buffer (get-buffer-window cert-buffer) buffer)
(setq show-details nil))
(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)))
(?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))
((char-equal (car answer) ?b)
(with-selected-window (get-buffer-window cert-buffer)
(with-current-buffer cert-buffer
(ignore-errors (scroll-down)))))
(?b
;; Scroll down.
(with-selected-window (get-buffer-window buf)
(with-current-buffer buf
(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)))))
(?f
;; Scroll up.
(with-selected-window (get-buffer-window buf)
(with-current-buffer buf
(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)))
(?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)))
((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)))))
(?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)))))