From 17401274b51f44e35f2ea27ada0c153edf05662a Mon Sep 17 00:00:00 2001 From: cage Date: Thu, 28 Jan 2021 15:35:26 +0100 Subject: [PATCH] - [gemini] added support for favicon.txt the implementation more or less follow gemini://mozz.us/files/rfc_gemini_favicon.gmi but it does render the first character of the file instead of checking for emoji characters. --- etc/default-theme.conf | 2 +- src/gemini-viewer.lisp | 27 ++++++++++++++++++++++++--- src/gemini/client.lisp | 29 +++++++++++++++++++++++++++++ src/gemini/package.lisp | 4 +++- src/gemini/subscription.lisp | 29 ----------------------------- src/package.lisp | 2 ++ src/program-events.lisp | 4 ++-- src/software-configuration.lisp | 6 ++++++ 8 files changed, 67 insertions(+), 36 deletions(-) diff --git a/etc/default-theme.conf b/etc/default-theme.conf index 17f8fbe..a3a6604 100644 --- a/etc/default-theme.conf +++ b/etc/default-theme.conf @@ -471,7 +471,7 @@ open-message-link-window.input.selected.foreground = #FFB200 # gemini browser -gemini.current.url.prefix = "🌍 " +gemini.favicon = "🌍" gemini.link.scheme.gemini.prefix = "→ " diff --git a/src/gemini-viewer.lisp b/src/gemini-viewer.lisp index ee5de51..661f775 100644 --- a/src/gemini-viewer.lisp +++ b/src/gemini-viewer.lisp @@ -312,8 +312,27 @@ :payload response :append-text append-text)))) +(let ((cache ())) + (defun fetch-favicon (parsed-url) + (flet ((fetch-from-cache (key) + (assoc-value cache key :test #'string=))) + (multiple-value-bind (actual-iri host path query port fragment) + (displace-iri parsed-url) + (declare (ignore actual-iri path query fragment)) + (or (fetch-from-cache host) + (ignore-errors + (let* ((favicon-url (gemini-parser:make-gemini-iri host + "/favicon.txt" + :port port)) + (response-body (gemini-client:slurp-gemini-url favicon-url)) + (favicon (misc:safe-subseq (babel:octets-to-string response-body :errorp t) + 0 1))) + (setf cache (acons host favicon cache)) + (fetch-favicon parsed-url))) + (swconf:gemini-default-favicon)))))) + (defun request-stream-gemini-document-thread (wrapper-object host - port path query fragment) + port path query fragment favicon) (with-accessors ((download-socket download-socket) (download-stream download-stream) (octect-count octect-count) @@ -328,7 +347,7 @@ :query query :port port :fragment fragment)) - (url-header (format nil "-> ~a~%" url)) + (url-header (format nil "~a ~a~2%" favicon url)) (parsed-url (gemini-parser:parse-gemini-file url-header)) (url-response (gemini-client:make-gemini-file-response nil nil @@ -559,13 +578,15 @@ :stream-status starting-status :download-stream response :download-socket socket)) + (favicon (fetch-favicon parsed-iri)) (thread-fn (request-stream-gemini-document-thread gemini-stream host port path query - fragment)) + fragment + favicon)) (enqueue-event (make-instance 'program-events:gemini-enqueue-download-event :payload gemini-stream))) (program-events:push-event enqueue-event) diff --git a/src/gemini/client.lisp b/src/gemini/client.lisp index 024ae57..4032d7e 100644 --- a/src/gemini/client.lisp +++ b/src/gemini/client.lisp @@ -368,3 +368,32 @@ (defmethod build-redirect-iri (meta (iri-from string)) (build-redirect-iri meta (iri:iri-parse iri-from))) + +(define-constant +maximum-redirections+ 5 :test `=) + +(defun slurp-gemini-url (url &optional (redirect-count 0)) + "Read 'full' data from gemini address `url'; note that specs says +that gemini flow is streamed by default so this function has limited +use as there is a chance that it would not returns. Anyway for gemlog +subscription (for example) could be used. + +TODO: Add client certificate." + (let ((iri (iri:iri-parse url))) + (multiple-value-bind (status description meta response socket) + (request (uri:host iri) + (uri:path iri) + :query (uri:query iri) + :port (uri:port iri) + :fragment (uri:fragment iri)) + (declare (ignore description)) + (cond + ((response-success-p status) + (let ((data (misc:make-fresh-array 0 0 '(unsigned-byte 8) nil))) + (loop for new-byte = (read-byte response nil nil) + while new-byte do + (vector-push-extend new-byte data)) + (close-ssl-socket socket) + data)) + ((and (response-redirect-p status) + (< redirect-count +maximum-redirections+)) + (slurp-gemini-url (build-redirect-iri meta iri) (1+ redirect-count))))))) diff --git a/src/gemini/package.lisp b/src/gemini/package.lisp index 1dda83f..9fd65e0 100644 --- a/src/gemini/package.lisp +++ b/src/gemini/package.lisp @@ -92,6 +92,7 @@ :error-code :error-description :gemini-tofu-error + :*gemini-page-theme* :make-gemini-file-response :host :response-certificate-requested-p @@ -117,7 +118,8 @@ :request :gemini-file-stream-p :fetch-cached-certificate - :build-redirect-iri)) + :build-redirect-iri + :slurp-gemini-url)) (defpackage :gemini-subscription (:use diff --git a/src/gemini/subscription.lisp b/src/gemini/subscription.lisp index 3943357..79d5b12 100644 --- a/src/gemini/subscription.lisp +++ b/src/gemini/subscription.lisp @@ -16,35 +16,6 @@ (in-package :gemini-subscription) -(define-constant +maximum-redirections+ 5 :test `=) - -(defun slurp-gemini-url (url &optional (redirect-count 0)) - "Read 'full' data from gemini address `url'; note that specs says -that gemini flow is streamed by default so this function has limited -use as there is a chance that it would not returns. Anyway for gemlog -subscription (for example) could be used. - -TODO: Add client certificate." - (let ((iri (iri:iri-parse url))) - (multiple-value-bind (status description meta response socket) - (gemini-client:request (uri:host iri) - (uri:path iri) - :query (uri:query iri) - :port (uri:port iri) - :fragment (uri:fragment iri)) - (declare (ignore description)) - (cond - ((response-success-p status) - (let ((data (misc:make-fresh-array 0 0 '(unsigned-byte 8) nil))) - (loop for new-byte = (read-byte response nil nil) - while new-byte do - (vector-push-extend new-byte data)) - (gemini-client:close-ssl-socket socket) - data)) - ((and (response-redirect-p status) - (< redirect-count +maximum-redirections+)) - (slurp-gemini-url (gemini-client:build-redirect-iri meta iri) (1+ redirect-count))))))) - (defun link-post-timestamp (link-text) "Returns a local-time object parsing a gemlog entry's link text diff --git a/src/package.lisp b/src/package.lisp index dc7e79d..ff05333 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -1072,6 +1072,7 @@ :perform-missing-value-check :load-config-file :external-editor + :gemini-default-favicon :gemini-link-prefix-to-gemini :gemini-link-prefix-to-other :gemini-quote-prefix @@ -2175,6 +2176,7 @@ :abort-download-stream :db-entry-to-foreground :gemini-metadata-p + :maybe-initialize-metadata :make-gemini-metadata :gemini-metadata-links :gemini-metadata-source-file diff --git a/src/program-events.lisp b/src/program-events.lisp index 7adb9cc..9432448 100644 --- a/src/program-events.lisp +++ b/src/program-events.lisp @@ -1212,8 +1212,8 @@ (uri:host url) (uri:port url) (uri:path url))) - (theme gemini-client::*gemini-page-theme*)) - (gemini-viewer::maybe-initialize-metadata specials:*message-window*) + (theme gemini-client:*gemini-page-theme*)) + (gemini-viewer:maybe-initialize-metadata specials:*message-window*) (refresh-gemini-message-window links gemini-page (gemini-parser:sexp->text parsed theme) diff --git a/src/software-configuration.lisp b/src/software-configuration.lisp index 445886d..707ecde 100644 --- a/src/software-configuration.lisp +++ b/src/software-configuration.lisp @@ -397,6 +397,7 @@ command-window command-separator gemini + favicon tree branch arrow @@ -475,6 +476,11 @@ keys))) value))) +(defun gemini-default-favicon () + (access-non-null-conf-value *software-configuration* + +key-gemini+ + +key-favicon+)) + (defun gemini-link-prefix (scheme) (access-non-null-conf-value *software-configuration* +key-gemini+