;; Author: Tim Vaughan <plugd@thelambdalab.xyz>
;; Created: 11 April 2019
-;; Version: 3.4.3
+;; Version: 3.6.0
;; Keywords: comm gopher gemini
;; Homepage: https://thelambdalab.xyz/elpher
;; Package-Requires: ((emacs "27.1"))
;;; Global constants
;;
-(defconst elpher-version "3.4.3"
+(defconst elpher-version "3.6.0"
"Current version of elpher.")
(defconst elpher-margin-width 6
"Label of button used to toggle formatted text."
:type '(string))
-(defcustom elpher-client-certificate-map nil
- "An alist representing a mapping between gemini URLs and the names
-of client certificates which will be automatically activated for those
-URLs. Beware that the certificates will also be active for all
-subdirectories of the given URLs."
+(defcustom elpher-certificate-map nil
+ "Register client certificates to be used for gemini URLs.
+This variable contains an alist representing a mapping between gemini
+URLs and the names of client certificates which will be automatically
+activated for those URLs. Beware that the certificates will also be
+active for all subdirectories of the given URLs."
:type '(alist :key-type string :value-type string))
;; Face customizations
(defun elpher-remove-redundant-ports (address)
"Remove redundant port specifiers from ADDRESS.
-Here 'redundant' means that the specified port matches the default
+Here `redundant' means that the specified port matches the default
for that protocol, eg 70 for gopher."
(if (and (not (elpher-address-about-p address))
(eq (url-portspec address) ; (url-port) is too slow!
(replace-match string))
(set-match-data data))))))
+;;; Link button definitions
+;;
+
+(defvar elpher-link-keymap
+ (let ((map (make-sparse-keymap)))
+ (keymap-set map "S-<down-mouse-1>" 'ignore) ;Prevent buffer face popup
+ (keymap-set map "S-<mouse-1>" #'elpher--open-link-new-buffer-mouse)
+ (keymap-set map "S-<return>" #'elpher--open-link-new-buffer)
+ (set-keymap-parent map button-map)
+ map))
+
+(defun elpher--click-link (button)
+ "Function called when the gopher link BUTTON is activated."
+ (let ((page (button-get button 'elpher-page)))
+ (elpher-visit-page page)))
+
+(defun elpher--open-link-new-buffer ()
+ "Internal function used by Elpher to open links in a new buffer."
+ (interactive)
+ (let ((page (button-get (button-at (point)) 'elpher-page))
+ (new-buf (generate-new-buffer (default-value 'elpher-buffer-name))))
+ (pop-to-buffer new-buf)
+ (elpher-mode)
+ (elpher-visit-page page)))
+
+(defun elpher--open-link-new-buffer-mouse (event)
+ "Internal function used by Elpher to open links in a new buffer.
+The EVENT argument is the mouse event which caused this function to be
+called."
+ (interactive "e")
+ (mouse-set-point event)
+ (elpher--open-link-new-buffer))
+
+(defun elpher--page-button-help (_window buffer pos)
+ "Function called by Emacs to generate mouse-over text.
+The arguments specify the BUFFER and the POS within the buffer of the item
+for which help is required. The function returns the help to be
+displayed. The _WINDOW argument is currently unused."
+ (with-current-buffer buffer
+ (let ((button (button-at pos)))
+ (when button
+ (let* ((page (button-get button 'elpher-page))
+ (address (elpher-page-address page)))
+ (format "mouse-1, RET: open '%s'" (elpher-address-to-url address)))))))
+
+(define-button-type 'elpher-link
+ 'action #'elpher--click-link
+ 'keymap elpher-link-keymap
+ 'follow-link t
+ 'help-echo #'elpher--page-button-help
+ 'face 'button)
;;; Text Processing
;;
(let ((page (elpher-page-from-url (substring-no-properties (match-string 0)))))
(make-text-button (match-beginning 0)
(match-end 0)
- 'elpher-page page
- 'action #'elpher-click-link
- 'follow-link t
- 'help-echo #'elpher--page-button-help
- 'face 'button)))
+ 'elpher-page page
+ :type 'elpher-link)))
(buffer-string)))
Otherwise, the certificate will be given a 100 year expiration period
and the files will not be deleted.
-The function returns a list containing the current host name, the
+The function returns a list containing the URL-PREFIX of addresses
+for which the certificate should be used in this session, the
temporary flag, and the key and cert file names in the form required
by `gnutls-boot-parameters`."
(let ((exp-key-file (expand-file-name key-file))
(defun elpher-generate-throwaway-certificate (url-prefix)
"Generate and return details of a throwaway certificate.
The key and certificate files will be deleted when they are no
-longer needed for this session."
+longer needed for this session.
+
+The certificate will be marked as applying to all addresses with URLs
+starting with URL-PREFIX."
(let* ((file-base (make-temp-name "elpher"))
(key-file (concat temporary-file-directory file-base ".key"))
(cert-file (concat temporary-file-directory file-base ".crt")))
files, while COMMON-NAME specifies the common name field of the
certificate.
-The key and certificate files are written to in `elpher-certificate-directory'."
+The key and certificate files are written to in `elpher-certificate-directory'.
+
+In this session, the certificate will remain active for all addresses
+having URLs starting with URL-PREFIX."
(let* ((key-file (concat elpher-certificate-directory file-base ".key"))
(cert-file (concat elpher-certificate-directory file-base ".crt")))
(elpher-generate-certificate common-name key-file cert-file url-prefix)))
(defun elpher-get-existing-certificate (file-base url-prefix)
"Return a certificate object corresponding to an existing certificate.
It is assumed that the key files FILE-BASE.key and FILE-BASE.crt exist in
-the directory `elpher-certificate-directory'."
+the directory `elpher-certificate-directory'.
+
+In this session, the certificate will remain active for all addresses
+having URLs starting with URL-PREFIX."
(let* ((key-file (concat elpher-certificate-directory file-base ".key"))
(cert-file (concat elpher-certificate-directory file-base ".crt")))
- (list (elpher-address-to-url (elpher-page-address elpher-current-page))
+ (list url-prefix
nil
(expand-file-name key-file)
(expand-file-name cert-file))))
-(defun elpher-install-certificate (key-file-src cert-file-src file-base)
+(defun elpher-install-certificate (key-file-src cert-file-src file-base url-prefix)
"Install a key+certificate file pair in `elpher-certificate-directory'.
The strings KEY-FILE-SRC and CERT-FILE-SRC are the existing key and
certificate files to install. The argument FILE-BASE is used as the
-base for the installed key and certificate files."
+base for the installed key and certificate files.
+
+In this session, the certificate will remain active for all addresses
+having URLs starting with URL-PREFIX."
(let* ((key-file (concat elpher-certificate-directory file-base ".key"))
(cert-file (concat elpher-certificate-directory file-base ".crt")))
(if (or (file-exists-p key-file)
(error "Either of the key or certificate files do not exist"))
(copy-file key-file-src key-file)
(copy-file cert-file-src cert-file)
- (list (elpher-address-to-url (elpher-page-address elpher-current-page))
+ (list url-prefix
nil
(expand-file-name key-file)
(expand-file-name cert-file))))
(when (cadr elpher-client-certificate)
(delete-file (elt elpher-client-certificate 2))
(delete-file (elt elpher-client-certificate 3)))
- (setq elpher-client-certificate nil)
+ (setq-local elpher-client-certificate nil)
(if (called-interactively-p 'any)
(message "Client certificate forgotten.")))))
"Retrieve the `gnutls-boot-parameters'-compatable keylist.
This is obtained from the client certificate described by
-`elpher-current-certificate', if one is available and the host for
-that certificate matches the host in ADDRESS.
+`elpher-current-certificate', if one is available and the
+URL prefix for that certificate matches ADDRESS.
-If `elpher-current-certificate' is non-nil, and its host name doesn't
+If `elpher-current-certificate' is non-nil, and its URL prefix doesn't
match that of ADDRESS, the certificate is forgotten."
(if elpher-client-certificate
(if (string-prefix-p (car elpher-client-certificate)
(insert " "))
(insert (make-string elpher-margin-width ?\s))))
-(defun elpher--page-button-help (_window buffer pos)
- "Function called by Emacs to generate mouse-over text.
-The arguments specify the BUFFER and the POS within the buffer of the item
-for which help is required. The function returns the help to be
-displayed. The _WINDOW argument is currently unused."
- (with-current-buffer buffer
- (let ((button (button-at pos)))
- (when button
- (let* ((page (button-get button 'elpher-page))
- (address (elpher-page-address page)))
- (format "mouse-1, RET: open '%s'" (elpher-address-to-url address)))))))
-
(defun elpher-insert-index-record (display-string &optional address)
"Function to insert an index record into the current buffer.
The contents of the record are dictated by DISPLAY-STRING and ADDRESS.
If ADDRESS is not supplied or nil the record is rendered as an
-'information' line."
+`information' line."
(let* ((type (if address (elpher-address-type address) nil))
(type-map-entry (cdr (assoc type elpher-type-map))))
(if type-map-entry
(insert-text-button filtered-display-string
'face face
'elpher-page page
- 'action #'elpher-click-link
- 'follow-link t
- 'help-echo #'elpher--page-button-help))
+ :type 'elpher-link))
(pcase type
('nil ;; Information
(elpher-insert-margin)
'face 'elpher-unknown)))))
(insert "\n")))
-(defun elpher-click-link (button)
- "Function called when the gopher link BUTTON is activated."
- (let ((page (button-get button 'elpher-page)))
- (elpher-visit-page page)))
-
(defun elpher-render-index (data &optional _mime-type-string)
"Render DATA as an index. MIME-TYPE-STRING is unused."
(elpher-with-clean-buffer
(elpher-address-to-url (elpher-page-address elpher-current-page))))))
(unless chosen-certificate
(error "Gemini server requires a client certificate and none was provided"))
- (setq elpher-client-certificate chosen-certificate))
+ (setq-local elpher-client-certificate chosen-certificate))
(elpher-with-clean-buffer)
(elpher-get-gemini-response (elpher-page-address elpher-current-page) renderer))
(_other
(defun elpher-acquire-client-certificate (url-prefix)
"Select a pre-defined client certificate or prompt for one.
In this case, \"pre-defined\" means a certificate provided by
-the `elpher-client-certificate-map' variable."
+the `elpher-certificate-map' variable.
+
+For this session, the certificate will remain active for all addresses
+having URLs begining with URL-PREFIX."
(let ((entry (assoc url-prefix
- elpher-client-certificate-map
+ elpher-certificate-map
#'string-prefix-p)))
(if entry
(let ((cert-url-prefix (car entry))
(cert-name (cadr entry)))
- (message "Using certificate \"%s\" specified in elpher-client-certificate-map"
- cert-name)
+ (message "Using certificate \"%s\" specified in elpher-certificate-map with prefix \"%s\""
+ cert-name cert-url-prefix)
(elpher-get-existing-certificate cert-name cert-url-prefix))
(elpher-prompt-for-client-certificate url-prefix))))
(defun elpher-prompt-for-client-certificate (url-prefix)
- "Prompt for a client certificate to use to establish a TLS connection."
+ "Prompt for a client certificate to use to establish a TLS connection.
+
+In this session, the chosen certificate will remain active for all
+addresses with URLs matching URL-PREFIX."
(let* ((read-answer-short t))
(pcase (read-answer "What do you want to do? "
'(("throwaway" ?t
("abort" ?a
"stop immediately")))
("throwaway"
- (setq elpher-client-certificate (elpher-generate-throwaway-certificate)))
+ (setq-local elpher-client-certificate (elpher-generate-throwaway-certificate url-prefix)))
("persistent"
(let* ((existing-certificates (elpher-list-existing-certificates))
(file-base (completing-read
(if (string-empty-p (string-trim file-base))
nil
(if (member file-base existing-certificates)
- (setq elpher-client-certificate
+ (setq-local elpher-client-certificate
(elpher-get-existing-certificate file-base url-prefix))
(pcase (read-answer "Generate new certificate or install externally-generated one? "
'(("new" ?n
(if (string-empty-p (url-filename address))
(setf (url-filename address) "/")) ;ensure empty filename is marked as absolute
(setf (url-host address) (url-host current-address))
- (setf (url-fullness address) (url-host address)) ; set fullness to t if host is set
- (setf (url-portspec address) (url-portspec current-address)) ; (url-port) too slow!
- (unless (string-prefix-p "/" (url-filename address)) ;deal with relative links
+ (setf (url-fullness address) (url-host address)) ;set fullness to t if host is set
+ (setf (url-portspec address) (url-portspec current-address)) ;(url-port) too slow!
+ (cond
+ ((string-prefix-p "/" (url-filename address))) ;do nothing for absolute case
+ ((string-prefix-p "?" (url-filename address)) ;handle query-only links
+ (setf (url-filename address)
+ (concat (url-filename current-address)
+ (url-filename address))))
+ (t ;deal with relative links
(setf (url-filename address)
(concat (file-name-directory (url-filename current-address))
- (url-filename address)))))
+ (url-filename address))))))
(when (url-host address)
(setf (url-host address) (puny-encode-domain (url-host address))))
(unless (url-type address)
(insert-text-button display-string
'face face
'elpher-page page
- 'action #'elpher-click-link
- 'follow-link t
- 'help-echo #'elpher--page-button-help))
+ :type 'elpher-link))
(newline))))))
(defun elpher-gemini-insert-header (header-line)
"Default bindings:\n"
"\n"
" - TAB/Shift-TAB: next/prev item on current page\n"
- " - RET/mouse-1: open item under cursor\n"
+ " - RET/mouse-1: open item under cursor (with Shift to open in new buffer)\n"
" - m: select an item on current page by name (autocompletes)\n"
" - u/mouse-3/U: return to previous page or to the start page\n"
" - g: go to a particular address (gopher, gemini, finger)\n"
(elpher-insert-index-record "Floodgap Systems Gopher Server"
(elpher-make-gopher-address ?1 "" "gopher.floodgap.com" 70))
(elpher-insert-index-record "Project Gemini home page"
- (elpher-address-from-url "gemini://gemini.circumlunar.space/"))
+ (elpher-address-from-url "gemini://geminiprotocol.net/"))
(insert "\n"
"Alternatively, select a search engine and enter some search terms:\n")
(elpher-insert-index-record "Gopher Search Engine (Veronica-2)"
"Your bookmarks are stored in your ")
(insert-text-button "bookmark list"
'face 'link
- 'action #'elpher-click-link
- 'follow-link t
- 'help-echo #'elpher--page-button-help
'elpher-page
(elpher-make-page "Elpher Bookmarks"
- (elpher-make-about-address 'bookmarks)))
+ (elpher-make-about-address 'bookmarks))
+ :type 'elpher-link)
(insert ".\n")
(insert (propertize
"(Bookmarks from legacy elpher-bookmarks files will be automatically imported.)\n"
(defun elpher-follow-current-link ()
"Open the link or url at point."
(interactive)
- (push-button))
+ (elpher--click-link (button-at (point))))
+
+(defun elpher-follow-current-link-new-buffer ()
+ "Open the link or url at point."
+ (interactive)
+ (elpher--open-link-new-buffer))
;;;###autoload
(defun elpher-go (host-or-url)
(define-key map (kbd "F") 'elpher-forget-current-certificate)
(when (fboundp 'evil-define-key*)
(evil-define-key*
- 'motion map
- (kbd "TAB") 'elpher-next-link
- (kbd "C-") 'elpher-follow-current-link
- (kbd "C-t") 'elpher-back
- (kbd "u") 'elpher-back
- (kbd "-") 'elpher-back
- (kbd "^") 'elpher-back
- [mouse-3] 'elpher-back
- (kbd "U") 'elpher-back-to-start
- (kbd "g") 'elpher-go
- (kbd "o") 'elpher-go-current
- (kbd "O") 'elpher-root-dir
- (kbd "s") 'elpher-show-history
- (kbd "S") 'elpher-show-visited-pages
- (kbd "r") 'elpher-redraw
- (kbd "R") 'elpher-reload
- (kbd "T") 'elpher-toggle-tls
- (kbd ".") 'elpher-view-raw
- (kbd "d") 'elpher-download
- (kbd "D") 'elpher-download-current
- (kbd "m") 'elpher-jump
- (kbd "i") 'elpher-info-link
- (kbd "I") 'elpher-info-current
- (kbd "c") 'elpher-copy-link-url
- (kbd "C") 'elpher-copy-current-url
- (kbd "a") 'elpher-bookmark-link
- (kbd "A") 'elpher-bookmark-current
- (kbd "B") 'elpher-show-bookmarks
- (kbd "!") 'elpher-set-gopher-coding-system
- (kbd "F") 'elpher-forget-current-certificate))
+ 'motion map
+ (kbd "TAB") 'elpher-next-link
+ (kbd "C-t") 'elpher-back
+ (kbd "u") 'elpher-back
+ (kbd "-") 'elpher-back
+ (kbd "^") 'elpher-back
+ [mouse-3] 'elpher-back
+ (kbd "U") 'elpher-back-to-start
+ (kbd "g") 'elpher-go
+ (kbd "o") 'elpher-go-current
+ (kbd "O") 'elpher-root-dir
+ (kbd "s") 'elpher-show-history
+ (kbd "S") 'elpher-show-visited-pages
+ (kbd "r") 'elpher-redraw
+ (kbd "R") 'elpher-reload
+ (kbd "T") 'elpher-toggle-tls
+ (kbd ".") 'elpher-view-raw
+ (kbd "d") 'elpher-download
+ (kbd "D") 'elpher-download-current
+ (kbd "m") 'elpher-jump
+ (kbd "i") 'elpher-info-link
+ (kbd "I") 'elpher-info-current
+ (kbd "c") 'elpher-copy-link-url
+ (kbd "C") 'elpher-copy-current-url
+ (kbd "a") 'elpher-bookmark-link
+ (kbd "A") 'elpher-bookmark-current
+ (kbd "B") 'elpher-show-bookmarks
+ (kbd "!") 'elpher-set-gopher-coding-system
+ (kbd "F") 'elpher-forget-current-certificate))
map)
"Keymap for gopher client.")
The Lambda Lab / projects / elpher.git / blobdiff