;;; elpher.el --- A friendly gopher and gemini client -*- lexical-binding: t -*-
-;; Copyright (C) 2021 Jens Östlund <jostlund@gmail.com>
-;; Copyright (C) 2021 F. Jason Park <jp@neverwas.me>
-;; Copyright (C) 2021 Christopher Brannon <chris@the-brannons.com>
-;; Copyright (C) 2021 Omar Polo <op@omarpolo.com>
-;; Copyright (C) 2021 Noodles! <nnoodle@chiru.no>
-;; Copyright (C) 2021 Abhiseck Paira <abhiseckpaira@disroot.org>
-;; Copyright (C) 2020-2021 Alex Schroeder <alex@gnu.org>
-;; Copyright (C) 2020 Zhiwei Chen <chenzhiwei03@kuaishou.com>
-;; Copyright (C) 2020 condy0919 <condy0919@gmail.com>
-;; Copyright (C) 2020 Alexis <flexibeast@gmail.com>
-;; Copyright (C) 2020 Étienne Deparis <etienne@depar.is>
-;; Copyright (C) 2020 Simon Nicolussi <sinic@sinic.name>
-;; Copyright (C) 2020 Michel Alexandre Salim <michel@michel-slm.name>
-;; Copyright (C) 2020 Koushk Roy <kroy@twilio.com>
-;; Copyright (C) 2020 Vee <vee@vnsf.xyz>
-;; Copyright (C) 2020 Simon South <simon@simonsouth.net>
-;; Copyright (C) 2019-2021 Tim Vaughan <plugd@thelambdalab.xyz>
+;; Copyright (C) 2019-2023 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.1.0
-;; Keywords: comm gopher
+;; Version: 3.5.1
+;; 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.1.0"
+(defconst elpher-version "3.5.1"
"Current version of elpher.")
(defconst elpher-margin-width 6
(telnet elpher-get-telnet-page nil "tel" elpher-telnet)
(other-url elpher-get-other-url-page nil "url" elpher-other-url)
(file elpher-get-file-page nil "~" elpher-gemini)
- ((special welcome) elpher-get-welcome-page nil "E" elpher-index)
- ((special bookmarks) elpher-get-bookmarks-page nil "E" elpher-index)
- ((special history) elpher-get-history-page nil "E" elpher-index)
- ((special visited-pages) elpher-get-visited-pages-page nil "E" elpher-index))
+ ((about welcome) elpher-get-welcome-page nil "E" elpher-index)
+ ((about bookmarks) elpher-get-bookmarks-page nil "E" elpher-index)
+ ((about history) elpher-get-history-page nil "E" elpher-index)
+ ((about visited-pages) elpher-get-visited-pages-page nil "E" elpher-index))
"Association list from types to getters, renderers, margin codes and index faces.")
(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)
- (defvar thing-at-point-uri-schemes)
- (defvar xterm-color-preserve-properties))
+ (defvar thing-at-point-uri-schemes))
;;; Customization group
(defcustom elpher-filter-ansi-from-text nil
"If non-nil, filter ANSI escape sequences from text.
-The default behaviour is to use the ansi-color package to interpret these
-sequences."
+The default behaviour is to use the ansi-color package (or xterm-color if it is
+available) to interpret these sequences."
:type '(boolean))
(defcustom elpher-certificate-directory
page within which all of the standard elpher keybindings are active."
:type '(boolean))
+(defcustom elpher-start-page-url "about:welcome"
+ "Specify the page displayed initially by elpher.
+The default welcome screen is \"about:welcome\", while the bookmarks list
+is \"about:bookmarks\". You can also specify local files via \"file:\".
+
+Beware that using \"about:bookmarks\" as a start page in combination with
+the `elpher-use-bookmark-menu' variable set to non-nil will prevent the
+Emacs bookmark menu being accessible via \\[elpher-show-bookmarks] from
+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
;;
;; Address
;; An elpher "address" object is either a url object or a symbol.
-;; Symbol addresses are "special", corresponding to pages generated
+;; Addresses with the "about" type, corresponding to pages generated
;; dynamically for and by elpher. All others represent pages which
;; rely on content retrieved over the network.
-(defun elpher-address-from-url (url-string)
- "Create a ADDRESS object corresponding to the given URL-STRING."
+(defun elpher-address-from-url (url-string &optional default-scheme)
+ "Create a ADDRESS object corresponding to the given URL-STRING.
+If DEFAULT-SCHEME is non-nil, this sets the scheme of the URL when one
+is not explicitly given."
(let ((data (match-data))) ; Prevent parsing clobbering match data
(unwind-protect
(let ((url (url-generic-parse-url url-string)))
(unless (and (not (url-fullness url)) (url-type url))
- (setf (url-fullness url) t)
(unless (url-type url)
- (setf (url-type url) elpher-default-url-type))
+ (setf (url-type url) default-scheme))
(unless (url-host url)
(let ((p (split-string (url-filename url) "/" nil nil)))
(setf (url-host url) (car p))
(if (cdr p)
(concat "/" (mapconcat #'identity (cdr p) "/"))
""))))
+ (when (not (string-empty-p (url-host url)))
+ (setf (url-fullness url) t)
+ (setf (url-host url) (puny-encode-domain (url-host url))))
(when (or (equal "gopher" (url-type url))
(equal "gophers" (url-type url)))
;; Gopher defaults
"Remove redundant port specifiers from ADDRESS.
Here 'redundant' means that the specified port matches the default
for that protocol, eg 70 for gopher."
- (if (and (not (elpher-address-special-p address))
+ (if (and (not (elpher-address-about-p address))
(eq (url-portspec address) ; (url-port) is too slow!
(pcase (url-type address)
("gemini" 1965)
"/" (string type)
selector)))))
-(defun elpher-make-special-address (type)
- "Create an ADDRESS object corresponding to the given special address symbol TYPE."
+(defun elpher-make-about-address (type)
+ "Create an ADDRESS object corresponding to the given about address TYPE."
(elpher-address-from-url (concat "about:" (symbol-name type))))
(defun elpher-address-to-url (address)
- "Get string representation of ADDRESS, or nil if ADDRESS is special."
- (if (elpher-address-special-p address)
- nil
- (url-encode-url (url-recreate-url address))))
+ "Get string representation of ADDRESS."
+ (url-encode-url (url-recreate-url address)))
(defun elpher-address-type (address)
"Retrieve type of ADDRESS object.
This is used to determine how to retrieve and render the document the
address refers to, via the table `elpher-type-map'."
- (let ((protocol (url-type address)))
- (pcase (url-type address)
- ("about"
- (list 'special (intern (url-filename address))))
- ((or "gopher" "gophers")
- (list 'gopher
- (if (member (url-filename address) '("" "/"))
- ?1
- (string-to-char (substring (url-filename address) 1)))))
- ("gemini" 'gemini)
- ("telnet" 'telnet)
- ("finger" 'finger)
- ("file" 'file)
- (_ 'other-url))))
-
-(defun elpher-address-special-p (address)
- "Return non-nil if ADDRESS is a special address."
- (let ((type (url-type address)))
- (and type
- (listp type)
- (eq (car type) 'special))))
+ (pcase (url-type address)
+ ("about"
+ (list 'about (intern (url-filename address))))
+ ((or "gopher" "gophers")
+ (list 'gopher
+ (if (member (url-filename address) '("" "/"))
+ ?1
+ (string-to-char (substring (url-filename address) 1)))))
+ ("gemini" 'gemini)
+ ("telnet" 'telnet)
+ ("finger" 'finger)
+ ("file" 'file)
+ (_ 'other-url)))
+
+(defun elpher-address-about-p (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-nil if ADDRESS object is a gopher address."
+ (pcase (elpher-address-type address) (`(gopher ,_) t)))
(defun elpher-address-protocol (address)
- "Retrieve the transport protocol for ADDRESS. This is nil for special addresses."
- (if (elpher-address-special-p address)
- nil
- (url-type address)))
+ "Retrieve the transport protocol for ADDRESS."
+ (url-type address))
(defun elpher-address-filename (address)
"Retrieve the filename component of ADDRESS.
For gopher addresses this is a combination of the selector type and selector."
- (if (symbolp address)
- nil
- (url-unhex-string (url-filename address))))
+ (url-unhex-string (url-filename address)))
(defun elpher-address-host (address)
"Retrieve host from ADDRESS object."
- (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.
+ ((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.)"
- (if (elpher-address-special-p address)
- 0
- (url-port address)))
-
-(defun elpher-address-gopher-p (address)
- "Return non-nill if ADDRESS object is a gopher address."
- (eq 'gopher (elpher-address-type 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."
"Create a page with DISPLAY-STRING and ADDRESS."
(list display-string address))
-(defun elpher-make-welcome-page ()
- "Create the welcome page."
- (elpher-make-page "Elpher Welcome Page"
- (elpher-make-special-address 'welcome)))
+(defun elpher-make-start-page ()
+ "Create the start page."
+ (elpher-make-page "Start Page"
+ (elpher-address-from-url elpher-start-page-url)))
(defun elpher-page-display-string (page)
"Retrieve the display string corresponding to PAGE."
"Set the address corresponding to PAGE to NEW-ADDRESS."
(setcar (cdr page) new-address))
+(defun elpher-page-from-url (url &optional default-scheme)
+ "Create a page with address and display string defined by URL.
+The URL is unhexed prior to its use as a display string to improve
+readability.
+
+If DEFAULT-SCHEME is non-nil, this scheme is applied to the URL
+in the instance that URL itself doesn't specify one."
+ (let ((address (elpher-address-from-url url default-scheme)))
+ (elpher-make-page (elpher-address-to-iri address) address)))
+
+(defun elpher-address-to-iri (address)
+ "Return an IRI for ADDRESS.
+Decode percent-escapes and handle punycode in the domain name.
+Drop the password, if any."
+ (let ((data (match-data)) ; Prevent parsing clobbering match data
+ (host (url-host address))
+ (pass (url-password address)))
+ (unwind-protect
+ (let* ((host (url-host address))
+ (pass (url-password address)))
+ (when host
+ (setf (url-host address) (puny-decode-domain host)))
+ (when pass ; RFC 3986 says we should not render
+ (setf (url-password address) nil)) ; the password as clear text
+ (elpher-decode (url-unhex-string (url-recreate-url address))))
+ (setf (url-host address) host)
+ (setf (url-password address) pass)
+ (set-match-data data))))
+
(defvar elpher-current-page nil
"The current page for this Elpher buffer.")
(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
- (unless (equal (elpher-page-address elpher-current-page)
- (elpher-page-address page))
+ (unless (or (not elpher-current-page)
+ (equal (elpher-page-address elpher-current-page)
+ (elpher-page-address page)))
(push elpher-current-page elpher-history)
- (unless (or (elpher-address-special-p (elpher-page-address page))
+ (unless (or (elpher-address-about-p (elpher-page-address page))
(and elpher-visited-pages
(equal page (car elpher-visited-pages))))
(push page elpher-visited-pages))))
(defun elpher-visit-previous-page ()
"Visit the previous page in the history."
- (let ((previous-page (pop elpher-history)))
- (if previous-page
- (elpher-visit-page previous-page nil t)
- (error "No previous page"))))
+ (if elpher-history
+ (elpher-visit-page (pop elpher-history) nil t)
+ (error "No previous page")))
(defun elpher-reload-current-page ()
"Reload the current page, discarding any existing cached content."
(goto-char pos)
(goto-char (point-min)))))
+(defun elpher-get-default-url-scheme ()
+ "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)))
+ (pcase current-type
+ ((or (and 'file (guard (not elpher-history)))
+ `(about ,_))
+ elpher-default-url-type)
+ (_
+ (url-type address))))
+ elpher-default-url-type))
+
;;; Buffer preparation
;;
(defun elpher-update-header ()
"If `elpher-use-header' is true, display current page info in window header."
- (if elpher-use-header
+ (if (and elpher-use-header elpher-current-page)
(let* ((display-string (elpher-page-display-string elpher-current-page))
+ (sanitized-display-string (replace-regexp-in-string "%" "%%" display-string))
(address (elpher-page-address elpher-current-page))
- (tls-string (if (and (not (elpher-address-special-p address))
+ (tls-string (if (and (not (elpher-address-about-p address))
(member (elpher-address-protocol address)
'("gophers" "gemini")))
" [TLS encryption]"
""))
- (header (concat display-string
+ (header (concat sanitized-display-string
(propertize tls-string 'face 'bold))))
(setq header-line-format header))))
;; avoid resetting buffer-local variables
(elpher-mode))
(let ((inhibit-read-only t)
- (ansi-color-context nil)) ;; clean ansi interpreter state
+ (ansi-color-context nil)) ;; clean ansi interpreter state (also next 2 lines)
+ (setq-local xterm-color--current-fg nil)
+ (setq-local xterm-color--current-bg nil)
(setq-local network-security-level
(default-value 'network-security-level))
(erase-buffer)
(insert string)
(goto-char (point-min))
(while (re-search-forward elpher-url-regex nil t)
- (let ((page (elpher-make-page (substring-no-properties (match-string 0))
- (elpher-address-from-url (match-string 0)))))
+ (let ((page (elpher-page-from-url (substring-no-properties (match-string 0)))))
(make-text-button (match-beginning 0)
(match-end 0)
'elpher-page page
'face 'button)))
(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.")
(elpher-process-cleanup)
(cond
; Try again with IPv4
- ((not (or force-ipv4 socks))
+ ((not (or elpher-ipv4-always force-ipv4 socks))
(message "Connection timed out. Retrying with IPv4.")
(elpher-get-host-response address default-port
query-string
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 force-ipv4 'ipv4)
+ :family (and (or force-ipv4
+ elpher-ipv4-always)
+ 'ipv4)
:service service
:buffer nil
:nowait t
(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
-
-(defun elpher-insert-index (string)
- "Insert the index corresponding to STRING into the current buffer."
- ;; Should be able to split directly on CRLF, but some non-conformant
- ;; LF-only servers sadly exist, hence the following.
- (let ((str-processed (elpher-preprocess-text-response string)))
- (dolist (line (split-string str-processed "\n"))
- (ignore-errors
- (unless (= (length line) 0)
- (let* ((type (elt line 0))
- (fields (split-string (substring line 1) "\t"))
- (display-string (elt fields 0))
- (selector (elt fields 1))
- (host (elt fields 2))
- (port (if (elt fields 3)
- (string-to-number (elt fields 3))
- nil))
- (address (elpher-make-gopher-address type selector host port)))
- (elpher-insert-index-record display-string address)))))))
+
+;;; 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")
(when button
(let* ((page (button-get button 'elpher-page))
(address (elpher-page-address page)))
- (format "mouse-1, RET: open '%s'" (if (elpher-address-special-p address)
- address
- (elpher-address-to-url address))))))))
+ (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.
(insert "\n")))
(defun elpher-click-link (button)
- "Function called when the gopher link BUTTON is activated (via mouse or keypress)."
+ "Function called when the gopher link BUTTON is activated."
(let ((page (button-get button 'elpher-page)))
(elpher-visit-page page)))
(elpher-with-clean-buffer
(if (not data)
t
- (elpher-insert-index data)
+ (let ((data-processed (elpher-preprocess-text-response data)))
+ (dolist (line (split-string data-processed "\n"))
+ (ignore-errors
+ (unless (= (length line) 0)
+ (let* ((type (elt line 0))
+ (fields (split-string (substring line 1) "\t"))
+ (display-string (elt fields 0))
+ (selector (elt fields 1))
+ (host (elt fields 2))
+ (port (if (elt fields 3)
+ (string-to-number (elt fields 3))
+ nil))
+ (address (elpher-make-gopher-address type selector host port)))
+ (elpher-insert-index-record display-string address))))))
(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."
(if (display-images-p)
(let* ((image (create-image
data
- nil t))
- (window (get-buffer-window elpher-buffer-name)))
- (when window
- (setf (image-property image :max-width) (window-pixel-width window))
- (setf (image-property image :max-height) (window-pixel-height window)))
- (elpher-with-clean-buffer
- (insert-image image)
- (elpher-restore-pos)))
+ nil t)))
+ (if (not image)
+ (error "Unsupported image format")
+ (let ((window (get-buffer-window elpher-buffer-name)))
+ (when window
+ (setf (image-property image :max-width) (window-body-width window t))
+ (setf (image-property image :max-height) (window-body-height window t))))
+ (elpher-with-clean-buffer
+ (insert-image image)
+ (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)
(defun elpher-gemini-get-link-display-string (link-line)
"Extract the display string portion of LINK-LINE, a gemini map file link line.
-Returns the url portion in the event that the display-string portion is empty."
+Return nil if this portion is not provided."
(let* ((rest (string-trim (elt (split-string link-line "=>") 1)))
(idx (string-match "[ \t]" rest)))
- (string-trim (if idx
- (substring rest (+ idx 1))
- rest))))
+ (and idx
+ (elpher-color-filter-apply (string-trim (substring rest (+ idx 1)))))))
(defun elpher-collapse-dot-sequences (filename)
- "Collapse dot sequences in FILENAME.
-For instance, the filename /a/b/../c/./d will reduce to /a/c/d"
- (let* ((path (split-string filename "/"))
+ "Collapse dot sequences in the (absolute) FILENAME.
+For instance, the filename \"/a/b/../c/./d\" will reduce to \"/a/c/d\""
+ (let* ((path (split-string filename "/" t))
+ (is-directory (string-match-p (rx (: (or "." ".." "/") line-end)) filename))
(path-reversed-normalized
(seq-reduce (lambda (a b)
- (cond ((and a (equal b "..") (cdr a)))
- ((and (not a) (equal b "..")) a) ;leading .. are dropped
+ (cond ((equal b "..") (cdr a))
((equal b ".") a)
(t (cons b a))))
- path nil)))
- (string-join (reverse path-reversed-normalized) "/")))
+ path nil))
+ (path-normalized (reverse path-reversed-normalized)))
+ (if path-normalized
+ (concat "/" (string-join path-normalized "/") (and is-directory "/"))
+ "/")))
(defun elpher-address-from-gemini-url (url)
"Extract address from URL with defaults as per gemini map files.
(let ((address (url-generic-parse-url url))
(current-address (elpher-page-address elpher-current-page)))
(unless (and (url-type address) (not (url-fullness address))) ;avoid mangling mailto: urls
- (setf (url-fullness address) t)
(if (url-host address) ;if there is an explicit host, filenames are absolute
(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-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)
- (setf (url-type address) "gemini"))
+ (setf (url-type address) (url-type current-address)))
(when (equal (url-type address) "gemini")
(setf (url-filename address)
(elpher-collapse-dot-sequences (url-filename address)))))
(defun elpher-gemini-insert-link (link-line)
"Insert link described by LINK-LINE into a text/gemini document."
- (let* ((url (elpher-gemini-get-link-url link-line))
- (display-string (elpher-gemini-get-link-display-string link-line))
- (address (elpher-address-from-gemini-url url))
- (type (if address (elpher-address-type address) nil))
- (type-map-entry (cdr (assoc type elpher-type-map))))
- (when display-string
- (insert elpher-gemini-link-string)
- (if type-map-entry
+ (let ((url (elpher-gemini-get-link-url link-line)))
+ (when url
+ (let* ((given-display-string (elpher-gemini-get-link-display-string link-line))
+ (address (elpher-address-from-gemini-url url))
+ (type (if address (elpher-address-type address) nil))
+ (type-map-entry (cdr (assoc type elpher-type-map)))
+ (fill-prefix (make-string (+ 1 (length elpher-gemini-link-string)) ?\s)))
+ (when type-map-entry
+ (insert elpher-gemini-link-string)
(let* ((face (elt type-map-entry 3))
- (filtered-display-string (elpher-color-filter-apply display-string))
- (page (elpher-make-page filtered-display-string address)))
- (insert-text-button filtered-display-string
+ (display-string (or given-display-string
+ (elpher-address-to-iri address)))
+ (page (elpher-make-page display-string
+ address)))
+ (insert-text-button display-string
'face face
'elpher-page page
'action #'elpher-click-link
'follow-link t
'help-echo #'elpher--page-button-help))
- (insert (propertize display-string 'face 'elpher-unknown)))
- (insert "\n"))))
-
-(defvar elpher--gemini-page-headings nil
- "List of headings on the page.")
+ (newline))))))
(defun elpher-gemini-insert-header (header-line)
"Insert header described by HEADER-LINE into a text/gemini document.
(/ (* fill-column
(font-get (font-spec :name (face-font 'default)) :size))
(font-get (font-spec :name (face-font face)) :size)) fill-column)))
- (setq elpher--gemini-page-headings (cons (cons header (point))
- elpher--gemini-page-headings))
(unless (display-graphic-p)
(insert (make-string level ?#) " "))
- (insert (propertize header 'face face))
+ (insert (propertize header
+ 'face face
+ 'gemini-heading t
+ 'rear-nonsticky t))
(newline))))
(defun elpher-gemini-insert-text (text-line)
"Insert a plain non-preformatted TEXT-LINE into a text/gemini document.
This function uses Emacs' auto-fill to wrap text sensibly to a maximum
width defined by `elpher-gemini-max-fill-width'."
- (string-match "\\(^[ \t]*\\)\\(\\*[ \t]+\\|>[ \t]*\\)?" text-line)
- (let* ((line-prefix (match-string 2 text-line))
+ (string-match
+ (rx (: line-start
+ (optional
+ (group (or (: "*" (+ (any " \t")))
+ (: ">" (* (any " \t"))))))))
+ text-line)
+ (let* ((line-prefix (match-string 1 text-line))
(processed-text-line
(if line-prefix
(cond ((string-prefix-p "*" line-prefix)
(propertize text-line 'face 'elpher-gemini-quoted))
(t text-line))
text-line))
- (adaptive-fill-mode t)
- ;; fill-prefix is important for adaptive-fill-mode: without
- ;; it, multi-line list items are not indented correct
- (fill-prefix (if (match-string 2 text-line)
- (replace-regexp-in-string "[>\*]" " " (match-string 0 text-line))
- nil)))
+ (fill-prefix (if line-prefix
+ (make-string (length (match-string 0 text-line)) ?\s)
+ "")))
(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
- (setq elpher--gemini-page-headings nil)
- (let ((preformatted nil))
- (auto-fill-mode 1)
+ (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)))))
- (setq elpher--gemini-page-headings (nreverse elpher--gemini-page-headings))
+ (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."
(elpher-page-address elpher-current-page)
(buffer-string))))
-
-;; Finger page connection
+(defun elpher-build-current-imenu-index ()
+ "Build imenu index for current elpher buffer."
+ (save-excursion
+ (goto-char (point-min))
+ (let ((match nil)
+ (headers nil))
+ (while (setq match (text-property-search-forward 'gemini-heading t t))
+ (push (cons
+ (buffer-substring-no-properties (prop-match-beginning match)
+ (prop-match-end match))
+ (prop-match-beginning match))
+ headers))
+ (reverse headers))))
+
+
+;;; 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 retrieves the contents of a local file and renders it using RENDERER."
+ "Getter which renders a local file using RENDERER.
+Assumes UTF-8 encoding for all text files."
(let* ((address (elpher-page-address elpher-current-page))
(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"))
- (funcall
- (if renderer
- renderer
- (pcase (file-name-extension filename)
- ((or "gmi" "gemini") #'elpher-render-gemini-map)
- ((or "htm" "html") #'elpher-render-html)
- ((or "jpg" "jpeg" "gif" "png" "bmp" "tif" "tiff")
- #'elpher-render-image)
- ((or "txt" "") #'elpher-render-text)
- (t
- #'elpher-render-download)))
- (with-temp-buffer
+ (error "Could not read from file"))
+ (let ((body (with-temp-buffer
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary))
(insert-file-contents-literally filename)
- (string-as-unibyte (buffer-string))))
- nil)))
-
-
-;; Welcome page retrieval
+ (encode-coding-string (buffer-string) 'raw-text)))))
+ (if renderer
+ (funcall renderer body nil)
+ (pcase (file-name-extension filename)
+ ((or "gmi" "gemini")
+ (elpher-render-gemini-map (decode-coding-string body 'utf-8) nil))
+ ((or "htm" "html")
+ (elpher-render-html (decode-coding-string body 'utf-8)))
+ ((or "txt" "")
+ (elpher-render-text (decode-coding-string body 'utf-8)))
+ ((or "jpg" "jpeg" "gif" "png" "bmp" "tif" "tiff")
+ (elpher-render-image body))
+ ((or "gopher" "gophermap")
+ (elpher-render-index (elpher-decode body)))
+ (_
+ (elpher-render-download body))))
+ (elpher-restore-pos))))
+
+
+;;; Welcome page retrieval
+;;
(defun elpher-get-welcome-page (renderer)
"Getter which displays the welcome page (RENDERER must be nil)."
(elpher-address-from-url "gemini://geminispace.info/search"))
(insert "\n"
"Your bookmarks are stored in your ")
- (let ((help-string "RET,mouse-1: Open bookmark list"))
- (insert-text-button "bookmark list"
- 'face 'link
- 'action (lambda (_)
- (interactive)
- (call-interactively #'elpher-show-bookmarks))
- 'follow-link t
- 'help-echo help-string))
+ (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)))
(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.
(interactive)
(elpher-visit-page
(elpher-make-page "Current History Stack"
- (elpher-make-special-address 'history))))
+ (elpher-make-about-address 'history))))
(defun elpher-show-visited-pages ()
"Show the all the pages you've visited using Elpher.
(interactive)
(elpher-visit-page
(elpher-make-page "Elpher Visted Pages"
- (elpher-make-special-address 'visited-pages))))
+ (elpher-make-about-address 'visited-pages))))
(defun elpher-get-history-page (renderer)
"Getter which displays the history page (RENDERER must be nil)."
(error "Command not supported for history page"))
(elpher-display-history-links
(seq-filter (lambda (page)
- (not (elpher-address-special-p (elpher-page-address page))))
+ (not (elpher-address-about-p (elpher-page-address page))))
elpher-visited-pages)
"All visited pages"))
;;; 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
return a bookmark record for that link. Otherwise, return a bookmark
record for the current elpher page."
(let* ((button (and elpher-bookmark-link (button-at (point))))
- (page (if button
- (button-get button 'elpher-page)
- elpher-current-page))
- (address (elpher-page-address page))
- (url (elpher-address-to-url address))
- (display-string (elpher-page-display-string page))
- (pos (if button nil (point))))
- (if (elpher-address-special-p address)
- (error "Cannot bookmark %s" display-string)
- `(,display-string
- (defaults . (,display-string))
- (position . ,pos)
- (location . ,url)
- (handler . elpher-bookmark-jump)))))
+ (page (if button
+ (button-get button 'elpher-page)
+ elpher-current-page)))
+ (unless page
+ (error "Cannot bookmark this link"))
+ (let* ((address (elpher-page-address page))
+ (url (elpher-address-to-url address))
+ (display-string (elpher-page-display-string page))
+ (pos (if button nil (point))))
+ (if (elpher-address-about-p address)
+ (error "Cannot bookmark %s" display-string)
+ `(,display-string
+ (defaults . (,display-string))
+ (position . ,pos)
+ (location . ,url)
+ (handler . elpher-bookmark-jump))))))
;;;###autoload
(defun elpher-bookmark-jump (bookmark)
to the buffer."
(let* ((url (cdr (assq 'location bookmark)))
(cleaned-url (string-trim url))
- (address (elpher-address-from-url cleaned-url))
- (page (elpher-make-page cleaned-url address)))
+ (page (elpher-page-from-url cleaned-url))
+ (buffer (get-buffer-create elpher-buffer-name)))
(elpher-with-clean-buffer
(elpher-visit-page page))
- (set-buffer (get-buffer elpher-buffer-name))
+ (set-buffer buffer)
nil))
(defun elpher-bookmark-link ()
(bookmark-save))
(defun elpher-get-bookmarks-page (renderer)
- "Getter which displays the history page (RENDERER must be nil)."
+ "Getter which displays the bookmarks (RENDERER must be nil)."
(when renderer
(elpher-visit-previous-page)
(error "Command not supported for bookmarks page"))
- (elpher-with-clean-buffer
- (insert " ---- Elpher Bookmarks ---- \n\n")
- (bookmark-maybe-load-default-file)
- (dolist (bookmark (bookmark-maybe-sort-alist))
- (when (eq #'elpher-bookmark-jump (alist-get 'handler (cdr bookmark)))
- (let* ((name (car bookmark))
- (url (alist-get 'location (cdr bookmark)))
- (address (elpher-address-from-url url)))
- (elpher-insert-index-record name address))))
- (when (<= (line-number-at-pos) 3)
- (insert "No bookmarked pages found.\n"))
- (insert "\n --------------------------\n\n"
- "Select an entry or press 'u' to return to the previous page.\n\n"
- "Bookmarks can be renamed or deleted via the ")
- (insert-text-button "Emacs bookmark menu"
- 'action (lambda (_)
- (interactive)
- (call-interactively #'bookmark-bmenu-list))
- 'follow-link t
- 'help-echo "RET,mouse-1: open Emacs bookmark menu")
- (insert (substitute-command-keys
- ",\nwhich can also be opened from anywhere using '\\[bookmark-bmenu-list]'."))
- (elpher-restore-pos)))
-(defun elpher-show-bookmarks ()
- "Display the current list of elpher bookmarks.
-This will also check for a legacy bookmark file and offer to import it."
- (interactive)
(let ((old-bookmarks-file (or (and (boundp 'elpher-bookmarks-file)
elpher-bookmarks-file)
(locate-user-emacs-file "elpher-bookmarks"))))
"\" found. Import now?")))
(elpher-bookmark-import old-bookmarks-file)
(rename-file old-bookmarks-file (concat old-bookmarks-file "-legacy"))))
- (if elpher-use-emacs-bookmark-menu
- (call-interactively #'bookmark-bmenu-list)
- (elpher-visit-page
- (elpher-make-page "Elpher Bookmarks"
- (elpher-make-special-address 'bookmarks)))))
+
+ (if (and elpher-use-emacs-bookmark-menu
+ elpher-history)
+ (progn
+ (elpher-visit-previous-page)
+ (call-interactively #'bookmark-bmenu-list))
+ (elpher-with-clean-buffer
+ (insert " ---- Elpher Bookmarks ---- \n\n")
+ (bookmark-maybe-load-default-file)
+ (dolist (bookmark (bookmark-maybe-sort-alist))
+ (when (eq #'elpher-bookmark-jump (alist-get 'handler (cdr bookmark)))
+ (let* ((name (car bookmark))
+ (url (alist-get 'location (cdr bookmark)))
+ (address (elpher-address-from-url url)))
+ (elpher-insert-index-record name address))))
+ (when (<= (line-number-at-pos) 3)
+ (insert "No bookmarked pages found.\n"))
+ (insert "\n --------------------------\n\n"
+ "Select an entry or press 'u' to return to the previous page.\n\n"
+ "Bookmarks can be renamed or deleted via the ")
+ (insert-text-button "Emacs bookmark menu"
+ 'action (lambda (_)
+ (interactive)
+ (call-interactively #'bookmark-bmenu-list))
+ 'follow-link t
+ 'help-echo "RET,mouse-1: open Emacs bookmark menu")
+ (insert (substitute-command-keys
+ ",\nwhich can also be opened from anywhere using '\\[bookmark-bmenu-list]'."))
+ (elpher-restore-pos))))
+
+(defun elpher-show-bookmarks ()
+ "Interactive function to display the current list of elpher bookmarks."
+ (interactive)
+ (elpher-visit-page
+ (elpher-make-page "Elpher Bookmarks"
+ (elpher-make-about-address 'bookmarks))))
;;; Integrations
: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.
- (advice-add browse-url-browser-function :before-while
- (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"))
- ;; `elpher-go' always returns nil, which will stop the
- ;; advice chain here in a before-while
- (elpher-go url)
- ;; chain must continue, then return t.
- t)))))
+ ;; that's the function that gets advised. If the value is an alist,
+ ;; however, we don't know what to do. Better not interfere?
+ (when (and (symbolp browse-url-browser-function)
+ (fboundp browse-url-browser-function))
+ (advice-add browse-url-browser-function :before-while
+ (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" "gophers" "finger"))
+ ;; `elpher-go' always returns nil, which will stop the
+ ;; advice chain here in a before-while
+ (elpher-go url)
+ ;; chain must continue, then return t.
+ t))))))
;; Register "gemini://" as a URI scheme so `browse-url' does the right thing
(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-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 "sGopher or Gemini URL: ")
+ (interactive (list
+ (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* ((address (elpher-address-from-url trimmed-host-or-url))
- (page (elpher-make-page trimmed-host-or-url address)))
- (switch-to-buffer elpher-buffer-name)
+ (let ((page (elpher-page-from-url trimmed-host-or-url
+ (elpher-get-default-url-scheme))))
+ (unless (get-buffer-window elpher-buffer-name t)
+ (switch-to-buffer elpher-buffer-name))
(elpher-with-clean-buffer
(elpher-visit-page page))
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 "Gopher or Gemini URL: "
- (unless (elpher-address-special-p address)
- (elpher-address-to-url address)))))
- (unless (string-empty-p (string-trim url))
- (elpher-visit-page (elpher-make-page url (elpher-address-from-url url))))))
+ (url (read-string (format "Visit URL (default scheme %s): "
+ (elpher-get-default-url-scheme))
+ (elpher-address-to-url address))))
+ (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."
(defun elpher-view-raw ()
"View raw server response for current page."
(interactive)
- (if (elpher-address-special-p (elpher-page-address elpher-current-page))
+ (if (elpher-address-about-p (elpher-page-address elpher-current-page))
(error "This page was not generated by a server")
(elpher-visit-page elpher-current-page
#'elpher-render-raw)))
(interactive)
(setq-local elpher-current-page nil)
(setq-local elpher-history nil)
- (elpher-visit-page (elpher-make-welcome-page)))
+ (elpher-visit-page (elpher-make-start-page)))
(defun elpher-download ()
"Download the link at point."
(let ((button (button-at (point))))
(if button
(let ((page (button-get button 'elpher-page)))
- (if (elpher-address-special-p (elpher-page-address page))
- (error "Cannot download %s"
- (elpher-page-display-string page))
- (elpher-visit-page (button-get button 'elpher-page)
- #'elpher-render-download)))
+ (unless page
+ (error "Not an elpher page"))
+ (when (elpher-address-about-p (elpher-page-address page))
+ (error "Cannot download %s" (elpher-page-display-string page)))
+ (elpher-visit-page (button-get button 'elpher-page)
+ #'elpher-render-download))
(error "No link selected"))))
(defun elpher-download-current ()
"Download the current page."
(interactive)
- (if (elpher-address-special-p (elpher-page-address elpher-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)))
"Visit root of current server."
(interactive)
(let ((address (elpher-page-address elpher-current-page)))
- (if (not (elpher-address-special-p address))
+ (if (not (elpher-address-about-p address))
(if (or (member (url-filename address) '("/" ""))
(and (elpher-address-gopher-p address)
(= (length (elpher-gopher-address-selector address)) 0)))
(error "Command invalid for %s" (elpher-page-display-string elpher-current-page)))))
(defun elpher-info-page (page)
- "Display information on PAGE."
- (let ((display-string (elpher-page-display-string page))
- (address (elpher-page-address page)))
- (if (elpher-address-special-p address)
- (message "Special page: %s" display-string)
- (message "%s" (elpher-address-to-url address)))))
+ "Display URL of PAGE in minibuffer."
+ (let* ((address (elpher-page-address page))
+ (url (elpher-address-to-url address))
+ (iri (elpher-address-to-iri address)))
+ (if (equal url iri)
+ (message "%s" url)
+ (message "%s (Raw: %s)" iri url))))
(defun elpher-info-link ()
"Display information on page corresponding to link at point."
(interactive)
(let ((button (button-at (point))))
- (if button
- (elpher-info-page (button-get button 'elpher-page))
- (error "No item selected"))))
+ (unless button
+ (error "No item selected"))
+ (let ((page (button-get button 'elpher-page)))
+ (unless page
+ (error "Not an elpher page"))
+ (elpher-info-page page))))
(defun elpher-info-current ()
"Display information on current page."
(defun elpher-copy-page-url (page)
"Copy URL representation of address of PAGE to `kill-ring'."
- (let ((address (elpher-page-address page)))
- (if (elpher-address-special-p address)
- (error (format "Cannot represent %s as URL" (elpher-page-display-string page)))
- (let ((url (elpher-address-to-url address)))
- (message "Copied \"%s\" to kill-ring/clipboard." url)
- (kill-new url)))))
+ (let* ((address (elpher-page-address page))
+ (url (elpher-address-to-url address)))
+ (message "Copied \"%s\" to kill-ring/clipboard." url)
+ (kill-new url)))
(defun elpher-copy-link-url ()
"Copy URL of item at point to `kill-ring'."
(interactive)
(let ((button (button-at (point))))
- (if button
- (elpher-copy-page-url (button-get button 'elpher-page))
- (error "No item selected"))))
+ (unless button
+ (error "No item selected"))
+ (let ((page (button-get button 'elpher-page)))
+ (unless page
+ (error "Not an elpher page"))
+ (elpher-copy-page-url page))))
(defun elpher-copy-current-url ()
"Copy URL of current page to `kill-ring'."
This mode is automatically enabled by the interactive
functions which initialize the client, namely
`elpher', and `elpher-go'."
- (setq-local elpher--gemini-page-headings nil)
(setq-local elpher-current-page nil)
(setq-local elpher-history nil)
(setq-local elpher-buffer-name (buffer-name))
(setq-local bookmark-make-record-function #'elpher-bookmark-make-record)
- (setq-local imenu-create-index-function (lambda () elpher--gemini-page-headings))
- (setq-local xterm-color-preserve-properties t))
+ (setq-local imenu-create-index-function #'elpher-build-current-imenu-index))
(when (fboundp 'evil-set-initial-state)
(evil-set-initial-state 'elpher-mode 'motion))
(pop-to-buffer-same-window buf)
(unless (buffer-modified-p)
(elpher-mode)
- (elpher-visit-page (elpher-make-welcome-page))
+ (elpher-visit-page (elpher-make-start-page))
"Started Elpher."))); Otherwise (elpher) evaluates to start page string.
;;; elpher.el ends here