;;; elpher.el --- A friendly gopher and gemini client -*- lexical-binding: t -*-
-;; Copyright (C) 2019-2023 Tim Vaughan <plugd@thelambdalab.xyz>
+;; Copyright (C) 2019-2024 Tim Vaughan <plugd@thelambdalab.xyz>
;; Copyright (C) 2020-2022 Elpher contributors (See info manual for full list)
;; Author: Tim Vaughan <plugd@thelambdalab.xyz>
;; Created: 11 April 2019
-;; Version: 3.4.2
-;; Keywords: comm gopher
+;; Version: 3.6.2
+;; Keywords: comm gopher gemini
;; Homepage: https://thelambdalab.xyz/elpher
;; Package-Requires: ((emacs "27.1"))
;;; Global constants
;;
-(defconst elpher-version "3.4.2"
+(defconst elpher-version "3.6.2"
"Current version of elpher.")
(defconst elpher-margin-width 6
"Label of button used to toggle formatted text."
:type '(string))
+(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
(defgroup elpher-faces nil
(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)))
+ (define-key map (kbd "S-<down-mouse-1>") 'ignore) ;Prevent buffer face popup
+ (define-key map (kbd "S-<mouse-1>") #'elpher--open-link-new-buffer-mouse)
+ (define-key map (kbd "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)))
;;; Client-side TLS Certificate Management
;;
-(defun elpher-generate-certificate (common-name key-file cert-file &optional temporary)
+(defun elpher-generate-certificate (common-name key-file cert-file url-prefix
+ &optional temporary)
"Generate a key and a self-signed client TLS certificate using openssl.
The Common Name field of the certificate is set to COMMON-NAME. The
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))
"-subj" (concat "/CN=" common-name)
"-keyout" exp-key-file
"-out" exp-cert-file)
- (list (elpher-address-host (elpher-page-address elpher-current-page))
- temporary exp-key-file exp-cert-file))
+ (list url-prefix temporary exp-key-file exp-cert-file))
(error
(message "Check that openssl is installed, or customize `elpher-openssl-command`.")
(error "Program 'openssl', required for certificate generation, not found")))))
-(defun elpher-generate-throwaway-certificate ()
+(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")))
- (elpher-generate-certificate file-base key-file cert-file t)))
+ (elpher-generate-certificate file-base key-file cert-file url-prefix t)))
-(defun elpher-generate-persistent-certificate (file-base common-name)
+(defun elpher-generate-persistent-certificate (file-base common-name url-prefix)
"Generate and return details of a persistent certificate.
The argument FILE-BASE is used as the base for the key and certificate
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)))
+ (elpher-generate-certificate common-name key-file cert-file url-prefix)))
-(defun elpher-get-existing-certificate (file-base)
+(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-host (elpher-page-address elpher-current-page))
+ (list url-prefix
nil
(expand-file-name key-file)
(expand-file-name cert-file))))
-(defun elpher-install-and-use-existing-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)
(file-exists-p cert-file))
(error "A certificate with base name %s is already installed" file-base))
+ (unless (and (file-exists-p key-file-src)
+ (file-exists-p cert-file-src))
+ (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-host (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= (car elpher-client-certificate)
- (elpher-address-host address))
+ (if (string-prefix-p (car elpher-client-certificate)
+ (elpher-address-to-url address))
(list (cddr elpher-client-certificate))
(elpher-forget-current-certificate)
(message "Disabling client certificate for new host")
(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
(insert "Gemini server is requesting a valid TLS certificate:\n\n"))
(auto-fill-mode 1)
(elpher-gemini-insert-text response-meta))
- (let ((chosen-certificate (elpher-choose-client-certificate)))
+ (let ((chosen-certificate
+ (with-local-quit
+ (elpher-acquire-client-certificate
+ (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
(error "Gemini server response unknown: %s %s"
response-code response-meta))))))
+(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-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-certificate-map
+ #'string-prefix-p)))
+ (if entry
+ (let ((cert-url-prefix (car entry))
+ (cert-name (cadr entry)))
+ (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--read-answer-polyfill (question answers)
"Polyfill for `read-answer' in Emacs 26.1.
QUESTION is a string containing a question, and ANSWERS
-is a list of possible answers."
- (completing-read question (mapcar 'identity answers)))
+is a list of possible answers, or an alist whose keys
+are the possible answers."
+ (completing-read question answers))
(if (fboundp 'read-answer)
(defalias 'elpher-read-answer 'read-answer)
(defalias 'elpher-read-answer 'elpher--read-answer-polyfill))
-(defun elpher-choose-client-certificate ()
- "Prompt for a client certificate to use to establish a TLS connection."
+
+
+(defun elpher-prompt-for-client-certificate (url-prefix)
+ "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
- (elpher-get-existing-certificate file-base))
+ (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
"generate new certificate")
file-base)))
(message "New key and self-signed certificate written to %s"
elpher-certificate-directory)
- (elpher-generate-persistent-certificate file-base common-name)))
+ (elpher-generate-persistent-certificate file-base
+ common-name
+ url-prefix)))
("install"
(let* ((cert-file (read-file-name "Certificate file: " nil nil t))
(key-file (read-file-name "Key file: " nil nil t)))
(message "Key and certificate installed in %s for future use"
elpher-certificate-directory)
- (elpher-install-and-use-existing-certificate key-file
- cert-file
- file-base)))
+ (elpher-install-certificate key-file cert-file file-base
+ url-prefix)))
("abort" nil))))))
("abort" nil))))
(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)"
(elpher-make-gopher-address ?7 "/v2/vs" "gopher.floodgap.com" 70))
- (elpher-insert-index-record "Gemini Search Engine (geminispace.info)"
- (elpher-address-from-url "gemini://geminispace.info/search"))
+ (elpher-insert-index-record "Gemini Search Engine (auragem.letz.dev)"
+ (elpher-address-from-url "gemini://auragem.letz.dev/search/s"))
(insert "\n"
"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"
:export (lambda (link description format _plist)
(elpher-org-export-link link description format "gopher"))
:follow (lambda (link _arg) (elpher-org-follow-link link "gopher")))
+ (org-link-set-parameters
+ "gophers"
+ :export (lambda (link description format _plist)
+ (elpher-org-export-link link description format "gophers"))
+ :follow (lambda (link _arg) (elpher-org-follow-link link "gophers")))
(org-link-set-parameters
"finger"
:export (lambda (link description format _plist)
(if (boundp 'browse-url-default-handlers)
(add-to-list
'browse-url-default-handlers
- '("^\\(gopher\\|finger\\|gemini\\)://" . elpher-browse-url-elpher))
+ '("^\\(gopher\\|gophers\\|finger\\|gemini\\)://" . elpher-browse-url-elpher))
;; Patch `browse-url-browser-function' for older ones. The value of
;; that variable is `browse-url-default-browser' by default, so
;; that's the function that gets advised. If the value is an alist,
(lambda (url &rest _args)
"Handle gemini, gopher, and finger schemes using Elpher."
(let ((scheme (downcase (car (split-string url ":" t)))))
- (if (member scheme '("gemini" "gopher" "finger"))
+ (if (member scheme '("gemini" "gopher" "gophers" "finger"))
;; `elpher-go' always returns nil, which will stop the
;; advice chain here in a before-while
(elpher-go url)
;; Make mu4e aware of the gemini world
(setq mu4e~view-beginning-of-url-regexp
- "\\(?:https?\\|gopher\\|finger\\|gemini\\)://\\|mailto:")
+ "\\(?:https?\\|gopher\\|gophers\\|finger\\|gemini\\)://\\|mailto:")
;; eww:
;; Let elpher handle gemini, gopher links in eww buffer.
(setq eww-use-browse-url
- "\\`mailto:\\|\\(\\`gemini\\|\\`gopher\\|\\`finger\\)://")
+ "\\`mailto:\\|\\(\\`gemini\\|\\`gopher\\|\\`gophers\\|\\`finger\\)://")
;;; Interactive procedures
(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.")