;;; elpher.el --- A friendly gopher and gemini client -*- lexical-binding: t -*-
-;; Copyright (C) 2019-202
2 Tim Vaughan <plugd@thelambdalab.xyz>
+;; Copyright (C) 2019-202
3 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.3.2
-;; Keywords: comm gopher
+;; Version: 3.6.0
+;; Keywords: comm gopher gemini
;; Homepage: https://thelambdalab.xyz/elpher
;; Package-Requires: ((emacs "27.1"))
(require 'gnutls)
(require 'socks)
(require 'bookmark)
+(require 'rx)
;;; Global constants
;;
-(defconst elpher-version "3.3.2"
+(defconst elpher-version "3.6.0"
"Current version of elpher.")
(defconst elpher-margin-width 6
(declare-function org-link-store-props "ol")
(declare-function org-link-set-parameters "ol")
(defvar ansi-color-context)
+ (defvar xterm-color--current-fg)
+ (defvar xterm-color--current-bg)
(defvar bookmark-make-record-function)
(defvar mu4e~view-beginning-of-url-regexp)
(defvar eww-use-browse-url)
the start page."
:type '(string))
+(defcustom elpher-gemini-hide-preformatted nil
+ "Cause elpher to hide preformatted gemini text by default.
+When this option is enabled, preformatted text in text/gemini documents
+is replaced with a button which can be used to toggle its display.
+
+This is intended to improve accessibility, as preformatted text often
+includes art which can be difficult for screen readers to interpret
+meaningfully."
+ :type '(boolean))
+
+(defcustom elpher-gemini-preformatted-toggle-bullet "‣ "
+ "Margin symbol used to distinguish the preformatted text toggle."
+ :type '(string))
+
+(defcustom elpher-gemini-preformatted-toggle-label "[Toggle Preformatted Text]"
+ "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
'((t :inherit bold :height 1.2))
"Face used for gemini heading level 3.")
-(defface elpher-gemini-preformatted
- '((t :inherit fixed-pitch))
- "Face used for pre-formatted gemini text blocks.")
-
(defface elpher-gemini-quoted
'((t :inherit font-lock-doc-face))
"Face used for gemini quoted texts.")
+(defface elpher-gemini-preformatted
+ '((t :inherit default))
+ "Face used for gemini preformatted text.")
+
+(defface elpher-gemini-preformatted-toggle
+ '((t :inherit button))
+ "Face used for buttons used to toggle display of preformatted text.")
+
;;; Model
;;
(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!
(_ 'other-url)))
(defun elpher-address-about-p (address)
- "Return non-nil if ADDRESS is an about address."
+ "Return non-nil if ADDRESS is an about address."
(pcase (elpher-address-type address) (`(about ,_) t)))
(defun elpher-address-gopher-p (address)
- "Return non-nill if ADDRESS object is a gopher address."
+ "Return non-nil if ADDRESS object is a gopher address."
(pcase (elpher-address-type address) (`(gopher ,_) t)))
(defun elpher-address-protocol (address)
(defun elpher-address-host (address)
"Retrieve host from ADDRESS object."
- (let ((host-pre (url-host address)))
+ (pcase (url-host address)
;; The following strips out square brackets which sometimes enclose IPv6
;; addresses. Doing this here rather than at the parsing stage may seem
;; weird, but this lets us way we avoid having to muck with both URL parsing
;; and reconstruction. It's also more efficient, as this method is not
;; called during page rendering.
- (if (and (> (length host-pre) 2)
- (eq (elt host-pre 0) ?\[)
- (eq (elt host-pre (- (length host-pre) 1)) ?\]))
- (substring host-pre 1 (- (length host-pre) 1))
- host-pre)))
+ ((rx (: "[" (let ipv6 (* (not "]"))) "]"))
+ ipv6)
+ ;; The following is a work-around for a parsing bug that causes
+ ;; URLs with empty (but not absent, see RFC 1738) usernames to have
+ ;; @ prepended to the hostname.
+ ((rx (: "@" (let rest (+ anything))))
+ rest)
+ (addr
+ addr)))
(defun elpher-address-user (address)
"Retrieve user from ADDRESS object."
(defun elpher-address-port (address)
"Retrieve port from ADDRESS object.
-If no address is defined, returns 0. (This is for compatibility with the URL library.)"
- (url-port address))
+If no address is defined, returns 0. (This is for compatibility with
+the URL library.)"
+ (let ((port (url-portspec address))) ; (url-port) is too slow!
+ (if port port 0)))
(defun elpher-gopher-address-selector (address)
"Retrieve gopher selector from ADDRESS object."
(defun elpher-visit-page (page &optional renderer no-history)
"Visit PAGE using its own renderer or RENDERER, if non-nil.
Additionally, push PAGE onto the history stack and the list of
-previously-visited pages,unless NO-HISTORY is non-nil."
+previously-visited pages, unless NO-HISTORY is non-nil."
(elpher-save-pos)
(elpher-process-cleanup)
(unless no-history
(goto-char (point-min)))))
(defun elpher-get-default-url-scheme ()
- "Suggest a default URL scheme to use for visiting addresses based on the current page."
+ "Suggest default URL scheme for visiting addresses based on the current page."
(if elpher-current-page
(let* ((address (elpher-page-address elpher-current-page))
(current-type (elpher-address-type address)))
((or (and 'file (guard (not elpher-history)))
`(about ,_))
elpher-default-url-type)
- (`(about ,_)
- elpher-default-url-type)
(_
(url-type address))))
elpher-default-url-type))
(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)))
-;;; ANSI colors or XTerm colors (application and filtering)
+
+;; ANSI colors or XTerm colors (application and filtering)
(or (require 'xterm-color nil t)
(require 'ansi-color))
#'ansi-color-apply)
"A function to apply ANSI escape sequences.")
-;;; Processing text for display
+(defun elpher-text-has-ansi-escapes-p (string)
+ "Return non-nil if STRING includes an ANSI escape code."
+ (save-match-data
+ (string-match "\x1b\\[" string)))
+
+
+;; Processing text for display
(defun elpher-process-text-for-display (string)
"Perform any desired processing of STRING prior to display as text.
Currently includes buttonifying URLs and processing ANSI escape codes."
- (elpher-buttonify-urls (if elpher-filter-ansi-from-text
- (elpher-color-filter-apply string)
- (elpher-color-apply string))))
+ (elpher-buttonify-urls (if (elpher-text-has-ansi-escapes-p string)
+ (if elpher-filter-ansi-from-text
+ (elpher-color-filter-apply string)
+ (elpher-color-apply string))
+ string)))
-;;; Network error reporting
+;;; General network communication
;;
(defun elpher-network-error (address error)
"Press 'u' to return to the previous page.")))
-;;; General network communication
-;;
-
(defvar elpher-network-timer nil
"Timer used for network connections.")
nil force-ipv4))
(t
(elpher-network-error address "Connection time-out."))))))
- (proc (if socks (socks-open-network-stream "elpher-process" nil host service)
+ (proc (if socks
+ (socks-open-network-stream "elpher-process" nil host service)
(make-network-process :name "elpher-process"
:host host
:family (and (or force-ipv4
(cons 'gnutls-x509pki
(apply #'gnutls-boot-parameters
gnutls-params)))))))
+ (process-put proc 'elpher-buffer (current-buffer))
(setq elpher-network-timer timer)
(set-process-coding-system proc 'binary 'binary)
(set-process-query-on-exit-flag proc nil)
response-processor
use-tls t))
(response-string-parts
- (elpher-with-clean-buffer
- (insert "Data received. Rendering..."))
- (funcall response-processor
- (apply #'concat (reverse response-string-parts)))
- (elpher-restore-pos))
+ (with-current-buffer (process-get proc 'elpher-buffer)
+ (elpher-with-clean-buffer
+ (insert "Data received. Rendering..."))
+ (funcall response-processor
+ (apply #'concat (reverse response-string-parts)))
+ (elpher-restore-pos)))
(t
(error "No response from server")))
(error
(elpher-network-error address the-error)))))
(when socks
- (if use-tls (apply #'gnutls-negotiate :process proc gnutls-params))
+ (if use-tls
+ (apply #'gnutls-negotiate :process proc gnutls-params))
(funcall (process-sentinel proc) proc "open\n")))
(error
(elpher-process-cleanup)
;;; 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")
(error
(elpher-network-error address the-error))))))
-;; Index rendering
+
+;;; Gopher index rendering
+;;
(defun elpher-insert-margin (&optional type-name)
- "Insert index margin, optionally containing the TYPE-NAME, into the current buffer."
+ "Insert index margin, optionally containing the TYPE-NAME, into current buffer."
(if type-name
(progn
(insert (format (concat "%" (number-to-string (- elpher-margin-width 1)) "s")
(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 (via mouse or keypress)."
- (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-cache-content (elpher-page-address elpher-current-page)
(buffer-string)))))
-;; Text rendering
+
+;;; Gopher text rendering
+;;
(defun elpher-render-text (data &optional _mime-type-string)
"Render DATA as text. MIME-TYPE-STRING is unused."
(elpher-page-address elpher-current-page)
(buffer-string)))))
-;; Image retrieval
+
+;;; Image retrieval
+;;
(defun elpher-render-image (data &optional _mime-type-string)
"Display DATA as image. MIME-TYPE-STRING is unused."
(elpher-restore-pos))))
(elpher-render-download data))))
-;; Search retrieval and rendering
+
+;;; Gopher search retrieval and rendering
+;;
(defun elpher-get-gopher-query-page (renderer)
"Getter for gopher addresses requiring input.
(if aborted
(elpher-visit-previous-page))))))
-;; Raw server response rendering
+
+;;; Raw server response rendering
+;;
(defun elpher-render-raw (data &optional mime-type-string)
"Display raw DATA in buffer. MIME-TYPE-STRING is also displayed if provided."
(goto-char (point-min)))
(message "Displaying raw server response. Reload or redraw to return to standard view.")))
-;; File save "rendering"
+
+;;; File save "rendering"
+;;
(defun elpher-render-download (data &optional _mime-type-string)
"Save DATA to file. MIME-TYPE-STRING is unused."
(insert data)))
(message (format "Saved to file %s." filename))))))
-;; HTML rendering
+
+;;; HTML rendering
+;;
(defun elpher-render-html (data &optional _mime-type-string)
"Render DATA as HTML using shr. MIME-TYPE-STRING is unused."
(libxml-parse-html-region (point-min) (point-max)))))
(shr-insert-document dom)))))
-;; Gemini page retrieval
+
+;;; Gemini page retrieval
+;;
(defvar elpher-gemini-redirect-chain)
(elpher-with-clean-buffer
(insert "Gemini server is requesting input."))
(let* ((query-string
- (if (eq (elt response-code 1) ?1)
- (read-passwd (concat response-meta ": "))
- (read-string (concat response-meta ": "))))
+ (with-local-quit
+ (if (eq (elt response-code 1) ?1)
+ (read-passwd (concat response-meta ": "))
+ (read-string (concat response-meta ": ")))))
(query-address (seq-copy (elpher-page-address elpher-current-page)))
(old-fname (url-filename query-address)))
- (setf (url-filename query-address)
- (concat old-fname "?" (url-build-query-string `((,query-string)))))
- (elpher-get-gemini-response query-address renderer)))
+ (if (not query-string)
+ (elpher-visit-previous-page)
+ (setf (url-filename query-address)
+ (concat old-fname "?" (url-build-query-string `((,query-string)))))
+ (elpher-get-gemini-response query-address renderer))))
(?2 ; Normal response
(funcall renderer response-body response-meta))
(?3 ; Redirect
(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))))
(error
(elpher-network-error address the-error)))))
+;;; Gemini page rendering
+;;
+
(defun elpher-render-gemini (body &optional mime-type-string)
"Render gemini response BODY with rendering MIME-TYPE-STRING."
(if (not body)
(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)
text-line))
(fill-prefix (if line-prefix
(make-string (length (match-string 0 text-line)) ?\s)
- nil)))
+ "")))
(insert (elpher-process-text-for-display processed-text-line))
(newline)))
+(defun elpher-gemini-pref-expand-collapse (button)
+ "Function called when the preformatted text toggle BUTTON is activated."
+ (let ((id (button-get button 'pref-id)))
+ (if (invisible-p id)
+ (remove-from-invisibility-spec id)
+ (add-to-invisibility-spec id))
+ (redraw-display)))
+
+(defun elpher-gemini-insert-preformatted-toggler (alt-text)
+ "Insert a button for toggling the visibility of preformatted text.
+If non-nil, ALT-TEXT is displayed alongside the button."
+ (let* ((url-string (url-recreate-url (elpher-page-address elpher-current-page)))
+ (pref-id (intern (concat "pref-"
+ (number-to-string (point))
+ "-"
+ url-string))))
+ (insert elpher-gemini-preformatted-toggle-bullet)
+ (when alt-text
+ (insert (propertize (concat alt-text " ")
+ 'face 'elpher-gemin-preformatted)))
+ (insert-text-button elpher-gemini-preformatted-toggle-label
+ 'action #'elpher-gemini-pref-expand-collapse
+ 'pref-id pref-id
+ 'face 'elpher-gemini-preformatted-toggle)
+ (add-to-invisibility-spec pref-id)
+ (newline)
+ pref-id))
+
+(defun elpher-gemini-insert-preformatted-line (line &optional pref-id)
+ "Insert a LINE of preformatted text.
+PREF-ID is the value assigned to the \"invisible\" text attribute, which
+can be used to toggle the display of the preformatted text."
+ (insert (propertize (concat (elpher-process-text-for-display
+ (propertize line 'face 'elpher-gemini-preformatted))
+ "\n")
+ 'invisible pref-id
+ 'rear-nonsticky t)))
+
(defun elpher-render-gemini-map (data _parameters)
"Render DATA as a gemini map file, PARAMETERS is currently unused."
(elpher-with-clean-buffer
(auto-fill-mode 1)
+ (setq-local buffer-invisibility-spec nil)
(let ((preformatted nil)
(adaptive-fill-mode nil)) ;Prevent automatic setting of fill-prefix
(setq-local fill-column (min (window-width) elpher-gemini-max-fill-width))
(dolist (line (split-string data "\n"))
- (cond
- ((string-prefix-p "```" line) (setq preformatted (not preformatted)))
- (preformatted (insert (elpher-process-text-for-display
- (propertize line 'face 'elpher-gemini-preformatted))
- "\n"))
- ((string-prefix-p "=>" line)
- (elpher-gemini-insert-link line))
- ((string-prefix-p "#" line) (elpher-gemini-insert-header line))
- (t (elpher-gemini-insert-text line)))))
+ (pcase line
+ ((rx (: string-start "```" (opt (let alt-text (+ any)))))
+ (setq preformatted
+ (if preformatted
+ nil
+ (if elpher-gemini-hide-preformatted
+ (elpher-gemini-insert-preformatted-toggler alt-text)
+ t))))
+ ((guard preformatted)
+ (elpher-gemini-insert-preformatted-line line preformatted))
+ ((pred (string-prefix-p "=>"))
+ (elpher-gemini-insert-link line))
+ ((pred (string-prefix-p "#"))
+ (elpher-gemini-insert-header line))
+ (_ (elpher-gemini-insert-text line))))
(elpher-cache-content
(elpher-page-address elpher-current-page)
- (buffer-string))))
+ (buffer-string)))))
(defun elpher-render-gemini-plain-text (data _parameters)
"Render DATA as plain text file. PARAMETERS is currently unused."
headers))
(reverse headers))))
-;; Finger page connection
+
+;;; Finger page connection
+;;
(defun elpher-get-finger-page (renderer)
"Opens a finger connection to the current page address.
(elpher-network-error address the-error))))))
-;; Telnet page connection
+;;; Telnet page connection
+;;
(defun elpher-get-telnet-page (renderer)
"Opens a telnet connection to the current page address (RENDERER must be nil)."
(telnet host))))
-;; Other URL page opening
+;;; Other URL page opening
+;;
(defun elpher-get-other-url-page (renderer)
- "Getter which attempts to open the URL specified by the current page (RENDERER must be nil)."
+ "Getter which attempts to open the URL specified by the current page.
+The RENDERER argument to this getter must be nil."
(when renderer
(elpher-visit-previous-page)
(error "Command not supported for general URLs"))
(browse-web url)
(browse-url url))))
-;; File page
+
+;;; File page
+;;
(defun elpher-get-file-page (renderer)
"Getter which renders a local file using RENDERER.
(filename (elpher-address-filename address)))
(unless (file-exists-p filename)
(elpher-visit-previous-page)
- (error "File not found"))
+ (error "File not found"))
(unless (file-readable-p filename)
(elpher-visit-previous-page)
- (error "Could not read from file"))
+ (error "Could not read from file"))
(let ((body (with-temp-buffer
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary))
(elpher-restore-pos))))
-;; Welcome page retrieval
+;;; Welcome page retrieval
+;;
(defun elpher-get-welcome-page (renderer)
"Getter which displays the welcome page (RENDERER must be nil)."
"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"
'help-echo help-string))
(insert "\n")
(insert (propertize
- (concat "(These documents should be available if you have installed Elpher \n"
- " using MELPA. Otherwise you may have to install the manual yourself.)\n")
+ (concat "(These documents should be available if you have installed Elpher\n"
+ " from MELPA or non-GNU ELPA. Otherwise you may have to install the\n"
+ " manual yourself.)\n")
'face 'shadow))
(elpher-restore-pos)))
-;; History page retrieval
+
+;;; History page retrieval
+;;
(defun elpher-show-history ()
"Show the current contents of elpher's history stack.
;;; Bookmarks
+;;
;; This code allows Elpher to use the standard Emacs bookmarks: `C-x r
;; m' to add a bookmark, `C-x r l' to list bookmarks (which is where
: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)
(add-hook 'org-mode-hook #'elpher-org-mode-integration)
-;;; Browse URL
+;; Browse URL
;;;###autoload
(defun elpher-browse-url-elpher (url &rest _args)
(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)
(with-eval-after-load 'thingatpt
(add-to-list 'thing-at-point-uri-schemes "gemini://"))
-;;; Mu4e:
+;; Mu4e:
;; 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:
+;; 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)
"Go to a particular gopher site HOST-OR-URL.
When run interactively HOST-OR-URL is read from the minibuffer."
(interactive (list
- (read-string (format "Visit URL (default scheme %s): " (elpher-get-default-url-scheme)))))
+ (read-string (format "Visit URL (default scheme %s): "
+ (elpher-get-default-url-scheme)))))
(let ((trimmed-host-or-url (string-trim host-or-url)))
(unless (string-empty-p trimmed-host-or-url)
(let ((page (elpher-page-from-url trimmed-host-or-url
nil)))) ; non-nil value is displayed by eshell
(defun elpher-go-current ()
- "Go to a particular site read from the minibuffer, initialized with the current URL."
+ "Go to a particular URL which is read from the minibuffer.
+Unlike `elpher-go', the reader is initialized with the URL of the
+current page."
(interactive)
(let* ((address (elpher-page-address elpher-current-page))
- (url (read-string (format "Visit URL (default scheme %s): " (elpher-get-default-url-scheme))
+ (url (read-string (format "Visit URL (default scheme %s): "
+ (elpher-get-default-url-scheme))
(elpher-address-to-url address))))
- (unless (string-empty-p (string-trim url))
- (elpher-visit-page (elpher-page-from-url url)))))
+ (let ((trimmed-url (string-trim url)))
+ (unless (string-empty-p trimmed-url)
+ (elpher-with-clean-buffer
+ (elpher-visit-page
+ (elpher-page-from-url trimmed-url (elpher-get-default-url-scheme))))))))
(defun elpher-redraw ()
"Redraw current page."
(if (elpher-address-about-p (elpher-page-address elpher-current-page))
(error "Cannot download %s"
(elpher-page-display-string elpher-current-page))
- (elpher-visit-page (elpher-make-page
- (elpher-page-display-string elpher-current-page)
- (elpher-page-address elpher-current-page))
+ (elpher-visit-page elpher-current-page
#'elpher-render-download
t)))
(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