Merged Michel Salim's patch. Thanks!

[elpher.git] / elpher.el

diff --git a/elpher.el b/elpher.el
index 25de855..20aa3b5 100644 (file)
--- a/elpher.el
+++ b/elpher.el
@@ -4,7 +4,7 @@
 
 ;; Author: Tim Vaughan <plugd@thelambdalab.xyz>
 ;; Created: 11 April 2019
 
 ;; Author: Tim Vaughan <plugd@thelambdalab.xyz>
 ;; Created: 11 April 2019

-;; Version: 2.9.1
+;; Version: 2.10.0

 ;; Keywords: comm gopher
 ;; Homepage: http://thelambdalab.xyz/elpher
 ;; Package-Requires: ((emacs "26.2"))
 ;; Keywords: comm gopher
 ;; Homepage: http://thelambdalab.xyz/elpher
 ;; Package-Requires: ((emacs "26.2"))


@@ -71,7 +71,7 @@
 ;;; Global constants
 ;;
 
 ;;; Global constants
 ;;
 

-(defconst elpher-version "2.9.1"
+(defconst elpher-version "2.10.0"

   "Current version of elpher.")
 
 (defconst elpher-margin-width 6
   "Current version of elpher.")
 
 (defconst elpher-margin-width 6


@@ -209,7 +209,7 @@ some servers which do not support IPv6 can take a long time to time-out."
   "Face used for html type directory records.")
 
 (defface elpher-gemini
   "Face used for html type directory records.")
 
 (defface elpher-gemini

-  '((t :inherit font-lock-regexp-grouping-backslash))
+  '((t :inherit font-lock-constant-face))

   "Face used for Gemini type directory records.")
 
 (defface elpher-other-url
   "Face used for Gemini type directory records.")
 
 (defface elpher-other-url


@@ -664,7 +664,8 @@ the host operating system and the local network capabilities."
                                       (t
                                        (elpher-network-error address "Connection time-out.")))))))
           (setq elpher-network-timer timer)
                                       (t
                                        (elpher-network-error address "Connection time-out.")))))))
           (setq elpher-network-timer timer)

-          (elpher-buffer-message (concat "Connecting to " host "..."))
+          (elpher-buffer-message (concat "Connecting to " host "..."
+                                         " (press 'u' to abort)"))

           (set-process-filter proc
                               (lambda (_proc string)
                                 (when timer
           (set-process-filter proc
                               (lambda (_proc string)
                                 (when timer


@@ -689,7 +690,8 @@ the host operating system and the local network capabilities."
                                       (cond
                                        ((string-prefix-p "open" event)    ; request URL
                                         (elpher-buffer-message
                                       (cond
                                        ((string-prefix-p "open" event)    ; request URL
                                         (elpher-buffer-message

-                                         (concat "Connected to " host ". Receiving data..."))
+                                         (concat "Connected to " host ". Receiving data..."
+                                                 " (press 'u' to abort)"))

                                         (let ((inhibit-eol-conversion t))
                                           (process-send-string proc query-string)))
                                        ((string-prefix-p "deleted" event)) ; do nothing
                                         (let ((inhibit-eol-conversion t))
                                           (process-send-string proc query-string)))
                                        ((string-prefix-p "deleted" event)) ; do nothing


@@ -761,8 +763,8 @@ longer needed for this session."
          (cert-file (concat temporary-file-directory file-base ".crt")))
     (elpher-generate-certificate file-base key-file cert-file t)))
 
          (cert-file (concat temporary-file-directory file-base ".crt")))
     (elpher-generate-certificate file-base key-file cert-file t)))
 

-(defun elpher-generate-permanent-certificate (file-base common-name)
-  "Generate and return details of a persistant certificate.
+(defun elpher-generate-persistent-certificate (file-base common-name)
+  "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 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.


@@ -783,15 +785,34 @@ the directory `elpher-certificate-directory'."
           (expand-file-name key-file)
           (expand-file-name cert-file))))
 
           (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)
+  "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."
+  (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))
+    (copy-file key-file-src key-file)
+    (copy-file cert-file-src cert-file)
+    (list (elpher-address-host (elpher-page-address elpher-current-page))
+          nil
+          (expand-file-name key-file)
+          (expand-file-name cert-file))))
+

 (defun elpher-list-existing-certificates ()
 (defun elpher-list-existing-certificates ()

-  "Return a list of the persistant certificates in `elpher-certificate-directory'."
+  "Return a list of the persistent certificates in `elpher-certificate-directory'."
+  (unless (file-directory-p elpher-certificate-directory)
+    (make-directory elpher-certificate-directory))

   (mapcar
    (lambda (file)
      (file-name-sans-extension file))
    (directory-files elpher-certificate-directory nil "\.key$")))
 
 (defun elpher-forget-current-certificate ()
   (mapcar
    (lambda (file)
      (file-name-sans-extension file))
    (directory-files elpher-certificate-directory nil "\.key$")))
 
 (defun elpher-forget-current-certificate ()

-  "Causes any current certificate to be forgotten.
+  "Causes any current certificate to be forgotten.)

 In the case of throwaway certificates, the key and certificate files
 are also deleted."
   (interactive)
 In the case of throwaway certificates, the key and certificate files
 are also deleted."
   (interactive)


@@ -1155,40 +1176,62 @@ that the response was malformed."
             (insert "Gemini server is requesting a valid TLS certificate:\n\n"))
           (auto-fill-mode 1)
           (elpher-gemini-insert-text response-meta))
             (insert "Gemini server is requesting a valid TLS certificate:\n\n"))
           (auto-fill-mode 1)
           (elpher-gemini-insert-text response-meta))

-         (let* ((read-answer-short t))
-           (pcase (read-answer "What do you want to do? "
-                               '(("throwaway" ?t
-                                  "generate and use throw-away certificate")
-                                 ("permanent" ?p
-                                  "generate new or use existing permanent certificate")
-                                 ("abort" ?a
-                                  "stop immediately")))
-             ("throwaway"
-              (setq elpher-client-certificate (elpher-generate-throwaway-certificate)))
-             ("permanent"
-              (let* ((existing-certificates (elpher-list-existing-certificates))
-                     (file-base (completing-read
-                                 "Name of new or existing certificate (autocompletes, empty response aborts): "
-                                 existing-certificates)))
-                (if (string-empty-p (string-trim file-base))
-                    (error "Gemini server requires certificate and none was provided")
-                  (if (member file-base existing-certificates)
-                      (setq elpher-client-certificate
-                            (elpher-get-existing-certificate file-base))
-                    (let ((common-name (read-string "Common Name field for new certificate: "
-                                                    file-base)))
-                      (setq elpher-client-certificate
-                            (elpher-generate-permanent-certificate file-base common-name))
-                      (message "New key and self-signed certificate written to %s"
-                               elpher-certificate-directory))))))
-             ("abort"
-              (error "Gemini server requires a client certificate and none was provided")))
-           (elpher-with-clean-buffer)
-           (elpher-get-gemini-response (elpher-page-address elpher-current-page) renderer)))
+         (let ((chosen-certificate (elpher-choose-client-certificate)))
+           (unless chosen-certificate
+             (error "Gemini server requires a client certificate and none was provided"))
+           (setq 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))))))
 
         (_other
          (error "Gemini server response unknown: %s %s"
                 response-code response-meta))))))
 

+(defun elpher-choose-client-certificate ()
+  "Prompt for a client certificate to use to establish a TLS connection."
+  (let* ((read-answer-short t))
+    (pcase (read-answer "What do you want to do? "
+                        '(("throwaway" ?t
+                           "generate and use throw-away certificate")
+                          ("persistent" ?p
+                           "generate new or use existing persistent certificate")
+                          ("abort" ?a
+                           "stop immediately")))
+      ("throwaway"
+       (setq elpher-client-certificate (elpher-generate-throwaway-certificate)))
+      ("persistent"
+       (let* ((existing-certificates (elpher-list-existing-certificates))
+              (file-base (completing-read
+                          "Nickname for new or existing certificate (autocompletes, empty response aborts): "
+                          existing-certificates)))
+         (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))
+             (pcase (read-answer "Generate new certificate or install externally-generated one? "
+                                 '(("new" ?n
+                                    "generate new certificate")
+                                   ("install" ?i
+                                    "install existing certificate")
+                                   ("abort" ?a
+                                    "stop immediately")))
+               ("new"
+                (let ((common-name (read-string "Common Name field for 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)))
+               ("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)))
+               ("abort" nil))))))
+      ("abort" nil))))
+

 (defun elpher-get-gemini-page (renderer)
   "Getter which retrieves and renders a Gemini page and renders it using RENDERER."
   (let* ((address (elpher-page-address elpher-current-page))
 (defun elpher-get-gemini-page (renderer)
   "Getter which retrieves and renders a Gemini page and renders it using RENDERER."
   (let* ((address (elpher-page-address elpher-current-page))


@@ -1205,7 +1248,6 @@ that the response was malformed."
       (error
        (elpher-network-error address the-error)))))
 
       (error
        (elpher-network-error address the-error)))))
 

-

 (defun elpher-render-gemini (body &optional mime-type-string)
   "Render gemini response BODY with rendering MIME-TYPE-STRING."
   (if (not body)
 (defun elpher-render-gemini (body &optional mime-type-string)
   "Render gemini response BODY with rendering MIME-TYPE-STRING."
   (if (not body)


@@ -1272,7 +1314,10 @@ For instance, the filename /a/b/../c/./d will reduce to /a/c/d"
     (string-join (reverse path-reversed-normalized) "/")))
 
 (defun elpher-address-from-gemini-url (url)
     (string-join (reverse path-reversed-normalized) "/")))
 
 (defun elpher-address-from-gemini-url (url)

-  "Extract address from URL with defaults as per gemini map files."
+  "Extract address from URL with defaults as per gemini map files.
+While there's obviously some redundancy here between this function and
+`elpher-address-from-url', gemini map file URLs require enough special
+treatment that a separate function is warranted."

   (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
   (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