X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=elpher.git;a=blobdiff_plain;f=elpher.el;h=e503a5c8748b07fb7c2118a3b6033f8f590a68ef;hp=4498c6c6396ccd2056b201008c0cafcb81f22f95;hb=refs%2Fheads%2Fspartan;hpb=eb650bff13f8ec7c9504c0937b4395617cfdfd53

diff --git a/elpher.el b/elpher.el
index 4498c6c..e503a5c 100644
--- a/elpher.el
+++ b/elpher.el
@@ -5,7 +5,7 @@
 
 ;; Author: Tim Vaughan <plugd@thelambdalab.xyz>
 ;; Created: 11 April 2019
-;; Version: 3.4.0
+;; Version: 3.4.1
 ;; Keywords: comm gopher
 ;; Homepage: https://thelambdalab.xyz/elpher
 ;; Package-Requires: ((emacs "27.1"))
@@ -70,7 +70,7 @@
 ;;; Global constants
 ;;
 
-(defconst elpher-version "3.4.0"
+(defconst elpher-version "3.4.1"
   "Current version of elpher.")
 
 (defconst elpher-margin-width 6
@@ -91,6 +91,7 @@
     ((gopher ?s) elpher-get-gopher-page elpher-render-download "snd" elpher-binary)
     ((gopher ?h) elpher-get-gopher-page elpher-render-html "htm" elpher-html)
     (gemini elpher-get-gemini-page elpher-render-gemini "gem" elpher-gemini)
+    (spartan elpher-get-spartan-page elpher-render-gemini "spt" elpher-spartan)
     (finger elpher-get-finger-page elpher-render-text "txt" elpher-text)
     (telnet elpher-get-telnet-page nil "tel" elpher-telnet)
     (other-url elpher-get-other-url-page nil "url" elpher-other-url)
@@ -274,6 +275,14 @@ meaningfully."
   '((t :inherit font-lock-constant-face))
   "Face used for Gemini type directory records.")
 
+(defface elpher-spartan
+  '((t :inherit font-lock-type-face))
+  "Face used for Spartan type directory records.")
+
+(defface elpher-spartan-post
+  '((t :inherit font-lock-string-face))
+  "Face used for Spartan type directory records.")
+
 (defface elpher-other-url
   '((t :inherit font-lock-comment-face))
   "Face used for other URL type links records.")
@@ -310,10 +319,6 @@ meaningfully."
   '((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.")
@@ -358,8 +363,8 @@ is not explicitly given."
               (when (or (equal (url-filename url) "")
                         (equal (url-filename url) "/"))
                 (setf (url-filename url) "/1")))
-            (when (equal "gemini" (url-type url))
-              ;; Gemini defaults
+            (when (member (url-type url) '("gemini" "spartan"))
+              ;; Gemini and Spartan defaults
               (if (equal (url-filename url) "")
                   (setf (url-filename url) "/"))))
           (elpher-remove-redundant-ports url))
@@ -423,6 +428,7 @@ address refers to, via the table `elpher-type-map'."
                ?1
              (string-to-char (substring (url-filename address) 1)))))
     ("gemini" 'gemini)
+    ("spartan" 'spartan)
     ("telnet" 'telnet)
     ("finger" 'finger)
     ("file" 'file)
@@ -1484,7 +1490,7 @@ Returns nil in the event that the contents of the line following the
 (defun elpher-gemini-get-link-display-string (link-line)
   "Extract the display string portion of LINK-LINE, a gemini map file link line.
 Return nil if this portion is not provided."
-  (let* ((rest (string-trim (elt (split-string link-line "=>") 1)))
+  (let* ((rest (string-trim (substring link-line 2)))
          (idx (string-match "[ \t]" rest)))
     (and idx
          (elpher-color-filter-apply (string-trim (substring rest (+ idx 1)))))))
@@ -1527,7 +1533,7 @@ treatment that a separate function is warranted."
         (setf (url-host address) (puny-encode-domain (url-host address))))
       (unless (url-type address)
         (setf (url-type address) (url-type current-address)))
-      (when (equal (url-type address) "gemini")
+      (when (member (url-type address) '("gemini" "spartan"))
         (setf (url-filename address)
               (elpher-collapse-dot-sequences (url-filename address)))))
     (elpher-remove-redundant-ports address)))
@@ -1642,7 +1648,6 @@ If non-nil, ALT-TEXT is displayed alongside the button."
 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 line) "\n")
-                      'face 'elpher-gemini-preformatted
                       'invisible pref-id
                       'rear-nonsticky t)))
 
@@ -1667,6 +1672,8 @@ can be used to toggle the display of the preformatted text."
           (elpher-gemini-insert-preformatted-line line preformatted))
          ((pred (string-prefix-p "=>"))
           (elpher-gemini-insert-link line))
+         ((pred (string-prefix-p "=:"))
+          (elpher-spartan-insert-query line))
          ((pred (string-prefix-p "#"))
           (elpher-gemini-insert-header line))
          (_ (elpher-gemini-insert-text line))))
@@ -1697,6 +1704,119 @@ can be used to toggle the display of the preformatted text."
       (reverse headers))))
 
 
+;; Spartan page retrieval
+
+(defvar elpher-spartan-redirect-chain)
+
+(defun elpher-get-spartan-page (renderer)
+  "Getter which retrieves and renders a Spartan page and renders it using RENDERER."
+  (let* ((address (elpher-page-address elpher-current-page))
+         (content (elpher-get-cached-content address)))
+    (condition-case the-error
+        (if (and content (funcall renderer nil))
+            (elpher-with-clean-buffer
+             (insert content)
+             (elpher-restore-pos))
+          (elpher-with-clean-buffer
+           (insert "LOADING SPARTAN... (use 'u' to cancel)\n"))
+          (setq elpher-spartan-redirect-chain nil)
+          (elpher-get-spartan-response address renderer))
+      (error
+       (elpher-network-error address the-error)))))
+
+(defun elpher-get-spartan-response (address renderer)
+  "Get response string from spartan server at ADDRESS and render using RENDERER."
+  (let* ((host (elpher-address-host address))
+         (path-and-query (url-path-and-query address))
+         (filename (car path-and-query))
+         (data (cdr path-and-query))
+         (data-len (length data)))
+    (elpher-get-host-response address 300
+                              (concat host " "
+                                      filename " "
+                                      (number-to-string data-len) "\r\n"
+                                      data)
+                              (lambda (response-string)
+                                (elpher-process-spartan-response response-string renderer)))))
+
+(defun elpher-parse-spartan-response (response)
+  "Parse the RESPONSE string and return a list of components.
+The list is of the form (code meta body).  A response of nil implies
+that the response was malformed."
+  (let ((header-end-idx (string-match "\r\n" response)))
+    (if header-end-idx
+        (let ((header (string-trim (substring response 0 header-end-idx)))
+              (body (substring response (+ header-end-idx 2))))
+          (if (>= (length header) 2)
+              (let ((code (substring header 0 1))
+                    (meta (string-trim (substring header 1))))
+                (list code meta body))
+            (error "Malformed response: No response status found in header %s" header)))
+      (error "Malformed response: No CRLF-delimited header found in response %s" response))))
+
+(defun elpher-process-spartan-response (response-string renderer)
+  "Process the spartan response RESPONSE-STRING and pass the result to RENDERER."
+  (let ((response-components (elpher-parse-spartan-response response-string)))
+    (let ((response-code (elt response-components 0))
+          (response-meta (elt response-components 1))
+          (response-body (elt response-components 2)))
+      (pcase (elt response-code 0)
+        (?2 ; Normal response
+         (funcall renderer response-body response-meta))
+        (?3 ; Redirect
+         (message "Following redirect to %s" response-meta)
+         (if (>= (length elpher-spartan-redirect-chain) 5)
+             (error "More than 5 consecutive redirects followed"))
+         (let* ((current-address (elpher-page-address elpher-current-page))
+                (redirect-address (elpher-address-from-url
+                                   (concat "spartan://"
+                                           (elpher-address-host current-address)
+                                           ":"
+                                           (elpher-address-port current-address)
+                                           "/"
+                                           response-meta))))
+           (if (member redirect-address elpher-spartan-redirect-chain)
+               (error "Redirect loop detected"))
+           (elpher-page-set-address elpher-current-page redirect-address)
+           (add-to-list 'elpher-spartan-redirect-chain redirect-address)
+           (elpher-get-spartan-response redirect-address renderer)))
+        (?4 ; Client error
+         (error "Spartan server reports CLIENT ERROR for this request: %s %s"
+                response-code response-meta))
+        (?5 ; Server error
+         (error "Spartan server reports SERVER ERROR for this request: %s %s"
+                response-code response-meta))
+        (_other
+         (error "Spartan server response unknown: %s %s"
+                response-code response-meta))))))
+
+(defun elpher-spartan-insert-query (query-line)
+  "Insert link described by QUERY-LINE into a text/gemini document."
+  (let ((url (elpher-gemini-get-link-url query-line)))
+    (when url
+      (let* ((address (elpher-address-from-gemini-url url))
+             (given-display-string (elpher-gemini-get-link-display-string query-line))
+             (fill-prefix (make-string (+ 1 (length elpher-gemini-link-string)) ?\s)))
+        (insert elpher-gemini-link-string)
+        (let ((display-string (or given-display-string url)))
+          (insert-text-button display-string
+                              'face 'elpher-spartan-post
+                              'display-string display-string
+                              'url (elpher-address-to-url address)
+                              'action #'elpher-spartan-post
+                              'follow-link t
+                              'help-echo #'elpher--page-button-help))
+        (newline)))))
+
+(defun elpher-spartan-post (button)
+  "Function called when the spartan post link BUTTON is clicked."
+  (let* ((display-string (button-get button 'display-string))
+         (url (button-get button 'url))
+         (post-url (concat url "?" (url-hexify-string (read-string "Text to post: ")))))
+    (elpher-visit-page (elpher-make-page
+                        display-string
+                        (elpher-address-from-url post-url)))))
+
 ;; Finger page connection
 
 (defun elpher-get-finger-page (renderer)
@@ -2107,9 +2227,10 @@ of gemini, gopher or finger."
     (let* ((url (elpher-info-current))
            (desc (car elpher-current-page))
            (protocol (cond
-                      ((string-prefix-p "gemini:" url) "gemini")
                       ((string-prefix-p "gopher:" url) "gopher")
                       ((string-prefix-p "finger:" url) "finger")
+                      ((string-prefix-p "gemini:" url) "gemini")
+                      ((string-prefix-p "spartan:" url) "spartan")
                       (t "elpher"))))
       (when (equal "elpher" protocol)
         ;; Weird link. Or special inner link?
@@ -2145,6 +2266,11 @@ supports the old protocol elpher, where the link is self-contained."
    :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
+   "spartan"
+   :export (lambda (link description format _plist)
+             (elpher-org-export-link link description format "spartan"))
+   :follow (lambda (link _arg) (elpher-org-follow-link link "spartan")))
   (org-link-set-parameters
    "finger"
    :export (lambda (link description format _plist)
@@ -2166,7 +2292,7 @@ supports the old protocol elpher, where the link is self-contained."
 (if (boundp 'browse-url-default-handlers)
     (add-to-list
      'browse-url-default-handlers
-     '("^\\(gopher\\|finger\\|gemini\\)://" . elpher-browse-url-elpher))
+     '("^\\(gopher\\|finger\\|gemini\\|spartan\\)://" . elpher-browse-url-elpher))
   ;; Patch `browse-url-browser-function' for older ones. The value of
   ;; that variable is `browse-url-default-browser' by default, so
   ;; that's the function that gets advised. If the value is an alist,
@@ -2177,7 +2303,7 @@ supports the old protocol elpher, where the link is self-contained."
 		(lambda (url &rest _args)
 		  "Handle gemini, gopher, and finger schemes using Elpher."
                   (let ((scheme (downcase (car (split-string url ":" t)))))
-                    (if (member scheme '("gemini" "gopher" "finger"))
+                    (if (member scheme '("gopher" "gemini" "spartan" "finger"))
 			;; `elpher-go' always returns nil, which will stop the
 			;; advice chain here in a before-while
 			(elpher-go url)
@@ -2192,13 +2318,13 @@ supports the old protocol elpher, where the link is self-contained."
 
 ;; Make mu4e aware of the gemini world
 (setq mu4e~view-beginning-of-url-regexp
-      "\\(?:https?\\|gopher\\|finger\\|gemini\\)://\\|mailto:")
+      "\\(?:https?\\|gopher\\|finger\\|gemini\\|spartan\\)://\\|mailto:")
 
 ;;; eww:
 
 ;; Let elpher handle gemini, gopher links in eww buffer.
 (setq eww-use-browse-url
-      "\\`mailto:\\|\\(\\`gemini\\|\\`gopher\\|\\`finger\\)://")
+      "\\`mailto:\\|\\(\\`gemini\\|\\`gopher\\|\\`finger\\|\\`spartan\\)://")
 
 
 ;;; Interactive procedures