Can now install externally-generated certs from within elpher.

[elpher.git] / elpher.el

diff --git a/elpher.el b/elpher.el
index 5762afa..f2a8188 100644 (file)
--- a/elpher.el
+++ b/elpher.el
@@ -286,9 +286,23 @@ some servers which do not support IPv6 can take a long time to time-out."
               ;; Gemini defaults
               (if (equal (url-filename url) "")
                   (setf (url-filename url) "/"))))
               ;; Gemini defaults
               (if (equal (url-filename url) "")
                   (setf (url-filename url) "/"))))

-          url)
+          (elpher-remove-redundant-ports url))

       (set-match-data data))))
 
       (set-match-data data))))
 

+(defun elpher-remove-redundant-ports (address)
+  "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))
+           (eq (url-portspec address) ; (url-port) is too slow!
+               (pcase (url-type address)
+                 ("gemini" 1965)
+                 ((or "gopher" "gophers") 70)
+                 ("finger" 79)
+                 (_ -1))))
+      (setf (url-portspec address) nil))
+  address)
+

 (defun elpher-make-gopher-address (type selector host port &optional tls)
   "Create an ADDRESS object using gopher directory record attributes.
 The basic attributes include: TYPE, SELECTOR, HOST and PORT.
 (defun elpher-make-gopher-address (type selector host port &optional tls)
   "Create an ADDRESS object using gopher directory record attributes.
 The basic attributes include: TYPE, SELECTOR, HOST and PORT.


@@ -650,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


@@ -675,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


@@ -769,6 +785,23 @@ 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 ()
   "Return a list of the persistant certificates in `elpher-certificate-directory'."
   (mapcar
 (defun elpher-list-existing-certificates ()
   "Return a list of the persistant certificates in `elpher-certificate-directory'."
   (mapcar


@@ -777,7 +810,7 @@ the directory `elpher-certificate-directory'."
    (directory-files elpher-certificate-directory nil "\.key$")))
 
 (defun elpher-forget-current-certificate ()
    (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)


@@ -1141,40 +1174,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")
+                          ("persistant" ?p
+                           "generate new or use existing persistant certificate")
+                          ("abort" ?a
+                           "stop immediately")))
+      ("throwaway"
+       (setq elpher-client-certificate (elpher-generate-throwaway-certificate)))
+      ("persistant"
+       (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-permanent-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))


@@ -1191,7 +1246,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)


@@ -1258,7 +1312,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


@@ -1274,10 +1331,10 @@ For instance, the filename /a/b/../c/./d will reduce to /a/c/d"
                         (url-filename address)))))
       (unless (url-type address)
         (setf (url-type address) "gemini"))
                         (url-filename address)))))
       (unless (url-type address)
         (setf (url-type address) "gemini"))

-      (if (equal (url-type address) "gemini")
-          (setf (url-filename address)
-                (elpher-collapse-dot-sequences (url-filename address)))))
-    address))
+      (when (equal (url-type address) "gemini")
+        (setf (url-filename address)
+              (elpher-collapse-dot-sequences (url-filename address)))))
+    (elpher-remove-redundant-ports address)))

 
 (defun elpher-gemini-insert-link (link-line)
   "Insert link described by LINK-LINE into a text/gemini document."
 
 (defun elpher-gemini-insert-link (link-line)
   "Insert link described by LINK-LINE into a text/gemini document."