diff --git a/src/gemini/client.lisp b/src/gemini/client.lisp index cd0291e..792e857 100644 --- a/src/gemini/client.lisp +++ b/src/gemini/client.lisp @@ -108,41 +108,103 @@ (code= (status-code header) code-class)) -(defun header-input-request-p (header) - (or (header-code= header +10+) - (header-code= header +11+))) +(defgeneric header-input-request-p (object)) -(defun header-success-p (header) - (header-code= header +20+)) +(defmethod header-input-request-p ((object gemini-response)) + (or (header-code= object +10+) + (header-code= object +11+))) -(defun header-redirect-p (header) - (or (header-code= header +30+) - (header-code= header +31+))) +(defmethod header-input-request-p ((object number)) + (or (code= object +10+) + (code= object +11+))) -(defun header-temporary-failure-p (header) - (or (header-code= header +40+) - (header-code= header +41+) - (header-code= header +42+) - (header-code= header +43+) - (header-code= header +44+))) +(defgeneric header-success-p (object)) -(defun header-permanent-failure-p (header) - (or (header-code= header +50+) - (header-code= header +51+) - (header-code= header +52+) - (header-code= header +53+) - (header-code= header +59+))) +(defmethod header-success-p ((object gemini-response)) + (header-code= object +20+)) -(defun header-certificate-failure-p (header) - (or (header-code= header +61+) - (header-code= header +62+))) +(defmethod header-success-p ((object number)) + (code= object +20+)) -(defun header-not-implemented-p (header) - (declare (ignore header)) +(defgeneric header-redirect-p (object)) + +(defmethod header-redirect-p ((object gemini-response)) + (or (header-code= object +30+) + (header-code= object +31+))) + +(defmethod header-redirect-p ((object number)) + (or (code= object +30+) + (code= object +31+))) + +(defgeneric header-temporary-failure-p (object)) + +(defmethod header-temporary-failure-p ((object gemini-response)) + (or (header-code= object +40+) + (header-code= object +41+) + (header-code= object +42+) + (header-code= object +43+) + (header-code= object +44+))) + +(defmethod header-temporary-failure-p ((object number)) + (or (code= object +40+) + (code= object +41+) + (code= object +42+) + (code= object +43+) + (code= object +44+))) + +(defgeneric header-permanent-failure-p (object)) + +(defmethod header-permanent-failure-p ((object gemini-response)) + (or (header-code= object +50+) + (header-code= object +51+) + (header-code= object +52+) + (header-code= object +53+) + (header-code= object +59+))) + +(defmethod header-permanent-failure-p ((object number)) + (or (code= object +50+) + (code= object +51+) + (code= object +52+) + (code= object +53+) + (code= object +59+))) + +(defgeneric header-certificate-failure-p (object)) + +(defmethod header-certificate-failure-p ((object gemini-response)) + (or (header-code= object +61+) + (header-code= object +62+))) + +(defmethod header-certificate-failure-p ((object number)) + (or (code= object +61+) + (code= object +62+))) + +(defun header-not-implemented-p (object) + (declare (ignore object)) nil) -(defun header-certificate-requested-p (header) - (header-code= header +60+)) +(defgeneric header-certificate-requested-p (object)) + +(defmethod header-certificate-requested-p ((object gemini-response)) + (header-code= object +60+)) + +(defmethod header-certificate-requested-p ((object number)) + (code= object +60+)) + +(defgeneric header-input-p (object)) + +(defmethod header-input-p ((object gemini-response)) + (header-code= object +10+)) + +(defmethod header-input-p ((object number)) + (response-input-p object)) + +(defgeneric header-sensitive-input-p (object)) + +(defmethod header-sensitive-input-p ((object gemini-response)) + (header-code= object +11+)) + +(defmethod header-sensitive-input-p ((object number)) + (response-sensitive-input-p object)) (defun response-input-p (code) (code= code +10+)) diff --git a/src/gemini/package.lisp b/src/gemini/package.lisp index 72fd690..b61a088 100644 --- a/src/gemini/package.lisp +++ b/src/gemini/package.lisp @@ -146,6 +146,14 @@ :+certificate-not-valid+ :mime-gemini-p :mime-text-stream + :header-success-p + :header-redirect-p + :header-temporary-failure-p + :header-permanent-failure-p + :header-certificate-failure-p + :header-certificate-requested-p + :header-input-p + :header-sensitive-input-p :gemini-protocol-error :error-code :error-description diff --git a/src/gui/client/main-window.lisp b/src/gui/client/main-window.lisp index 12e23da..a1ad1df 100644 --- a/src/gui/client/main-window.lisp +++ b/src/gui/client/main-window.lisp @@ -174,29 +174,121 @@ (getf match-results :indices)))) hint))) -(defun start-stream-iri-clsr (widget use-cache) +(defmacro gen-ir-access (key) + `(defun ,(misc:format-fn-symbol t "ir-~a" key) (line) + (getf line ,(a:make-keyword key)))) + +(gen-ir-access type) + +(gen-ir-access source-id) + +(gen-ir-access header-group-id) + +(gen-ir-access source-line) + +(gen-ir-access line) + +(gen-ir-access href) + +(defun collect-ir-lines (main-window lines) + (with-accessors ((ir-lines ir-lines) + (ir-rendered-lines ir-rendered-lines)) main-window + (flet ((push-prefixed (prefix ir) + (let ((raw-line (format nil "~a~a" prefix (ir-line ir)))) + (vector-push-extend raw-line ir-rendered-lines))) + (linkify (line) + (let* ((link-name (ir-line line)) + (link-value (ir-href line)) + (prefix-gemini (gui-conf:gemini-link-prefix-to-gemini)) + (prefix-www (gui-conf:gemini-link-prefix-to-http)) + (prefix-other (gui-conf:gemini-link-prefix-to-other)) + (link-text (if (text-utils:starting-emoji link-name) + (format nil + "~a~a" + (trim-blanks prefix-other) + link-name) + (cond + ((gemini-parser::gemini-link-iri-p link-value) + (format nil "~a~a" prefix-gemini link-name)) + ((html-utils::http-link-iri-p link-value) + (format nil "~a~a" prefix-www link-name)) + (t + (format nil "~a~a" prefix-other link-name)))))) + (vector-push-extend link-text ir-rendered-lines)))) + (loop for line in lines do + (vector-push-extend line ir-lines) + (let ((type (ir-type line))) + (ecase (format-keyword type) + (:vertical-space + (vector-push-extend (format nil "~%") ir-rendered-lines)) + (:as-is + (vector-push-extend (ir-line line) ir-rendered-lines)) + (:text + (vector-push-extend (ir-line line) ir-rendered-lines)) + (:h1 + (push-prefixed (gui-conf:gemini-h1-prefix) line)) + (:h2 + (push-prefixed (gui-conf:gemini-h1-prefix) line)) + (:h3 + (push-prefixed (gui-conf:gemini-h1-prefix) line)) + (:li + (push-prefixed (gui-conf:gemini-bullet-prefix) line)) + (:quote + (push-prefixed (gui-conf:gemini-quote-prefix) line)) + (:pre + (vector-push-extend (format nil "~%") ir-rendered-lines)) + (:pre-end + (vector-push-extend (format nil "~%") ir-rendered-lines)) + (:a + (linkify line)))))))) + +(defun displace-gemini-response (response) + (values (getf response :status) + (getf response :status-description) + (getf response :meta) + (getf response :cached) + (getf response :iri))) + +(defun start-stream-iri-clsr (main-window use-cache &optional (status :streaming)) (lambda () - (with-accessors ((iri-entry iri-entry)) widget - (let ((iri (gui:text iri-entry))) - (slurp-gemini-stream iri - :use-cache use-cache - :process-function (lambda (lines) - (misc:dbg "lines ~a" lines))))))) + (with-accessors ((tool-bar tool-bar)) main-window + (with-accessors ((iri-entry iri-entry)) tool-bar + (let* ((iri (trim-blanks (gui:text iri-entry))) + (connecting-response (cev:enqueue-request-and-wait-results :gemini-request + 1 + ev:+maximum-event-priority+ + iri + use-cache))) + (multiple-value-bind (status-code + status-description + meta + cached + original-iri) + (displace-gemini-response connecting-response) + (cond + ((gemini-client:header-success-p status-code) + (start-streaming-thread iri + :use-cache nil + :process-function (lambda (lines) + (collect-ir-lines main-window lines) + (misc:dbg "lines ~a" lines)) + :status status))))))))) (defun setup-main-window-events (main-window) - (with-accessors ((iri-entry iri-entry) - (back-button back-button) - (reload-button reload-button) - (up-button up-button) - (go-button go-button)) main-window - (let ((entry-autocomplete (gui-mw:autocomplete-entry-widget iri-entry))) - (gui:bind entry-autocomplete - #$$ - (lambda (e) - (declare (ignore e)) - (funcall (start-stream-iri-clsr main-window t))) - :append nil)) - (setf (gui:command go-button) (start-stream-iri-clsr main-window t)))) + (with-accessors ((tool-bar tool-bar)) main-window + (with-accessors ((iri-entry iri-entry) + (back-button back-button) + (reload-button reload-button) + (up-button up-button) + (go-button go-button)) tool-bar + (let ((entry-autocomplete (gui-mw:autocomplete-entry-widget iri-entry))) + (gui:bind entry-autocomplete + #$$ + (lambda (e) + (declare (ignore e)) + (funcall (start-stream-iri-clsr main-window t))) + :append nil)) + (setf (gui:command go-button) (start-stream-iri-clsr main-window t))))) (defmethod initialize-instance :after ((object tool-bar) &key &allow-other-keys) (with-accessors ((iri-entry iri-entry) @@ -222,7 +314,6 @@ (gui:grid reload-button 0 4 :sticky :e) (gui:grid up-button 0 5 :sticky :e) (gui:grid-columnconfigure object 2 :weight 2) - (setup-main-window-events object) object)) (defclass toc-frame (gui:frame) @@ -273,7 +364,15 @@ (info-text :initform nil :initarg :info-text - :accessor info-text))) + :accessor info-text) + (ir-rendered-lines + :initform (misc:make-fresh-array 0) + :initarg :ir-rendered-lines + :accessor ir-rendered-lines) + (ir-lines + :initform (misc:make-fresh-array 0) + :initarg :ir-lines + :accessor ir-lines))) (defmethod initialize-instance :after ((object main-frame) &key &allow-other-keys) (with-accessors ((main-window main-window) @@ -296,6 +395,7 @@ (gui:grid info-frame 3 0 :sticky :news :columnspan 2) (gui:grid-columnconfigure object 1 :weight 1) (gui:grid-rowconfigure object 1 :weight 1) + (setup-main-window-events object) object)) (defun print-info-message (message &key (color (gui-goodies:parse-color "gray")) (bold nil))