- [fediverse] fixed test to identify if a post is a poll.

src/gemini-viewer.lisp

@@ -372,6 +372,33 @@
         (text-utils:percent-decode    fragment)
         fragment)))
 
+(defun array->string (array remove-bom)
+  (let ((res (text-utils:to-s array :errorp nil)))
+    (if (and (string-not-empty-p res)
+             remove-bom
+             (char= (first-elt res)
+                    #\ZERO_WIDTH_NO-BREAK_SPACE))
+        (subseq res 1)
+        res)))
+
+(defun write-out-stream (file-stream wrapper-object line)
+  (let ((parsed-line (gemini-parser:parse-gemini-file line)))
+    (write-sequence line file-stream)
+    (increment-bytes-count wrapper-object line :convert-to-octets t)
+    (append-parsed-line wrapper-object parsed-line)))
+
+(defun maybe-write-out-preformat-wrapper (file-stream wrapper-object gemini-format)
+  (when (and (os-utils:open-resource-with-tinmop-p (download-iri wrapper-object))
+             (not gemini-format))
+    (write-out-stream file-stream
+                      wrapper-object
+                      (format nil "~a~%" gemini-parser:+preformatted-prefix+))))
+
+(defun append-parsed-line (wrapper-object parsed-line)
+  (setf (parsed-lines wrapper-object)
+        (append (parsed-lines wrapper-object)
+                parsed-line)))
+
 (defun request-stream-gemini-document-thread (wrapper-object scheme host
                                               port path query fragment favicon
                                               gemini-format-p
@@ -417,14 +444,6 @@
                                                                                 t)))
                        (maybe-render-line preformat-wrapper-event)
                        (write-sequence preformat-line file-stream)))))
-             (array->string (array remove-bom)
-               (let ((res (text-utils:to-s array :errorp nil)))
-                 (if (and (string-not-empty-p res)
-                          remove-bom
-                          (char= (first-elt res)
-                                 #\ZERO_WIDTH_NO-BREAK_SPACE))
-                     (subseq res 1)
-                     res)))
              (maybe-notify (message)
                (when notify
                  (ui:notify message))))
@@ -455,10 +474,7 @@
                    (new-title-event         (make-instance 'program-events:change-window-title-event
                                                            :payload url-header
                                                            :window *message-window*)))
-              (write-sequence url-header file-stream)
-              (increment-bytes-count wrapper-object url-header :convert-to-octets t)
-              (setf (parsed-lines wrapper-object)
-                    (gemini-parser:parse-gemini-file url-header))
+              (write-out-stream file-stream wrapper-object url-header)
               (maybe-change-title new-title-event)
               (maybe-render-line url-event)
               (maybe-render-preformat-wrapper file-stream wrapper-object)
@@ -477,11 +493,7 @@
                              (parsed-line (gemini-parser:parse-gemini-file line)))
                         (gemini-client:debug-gemini "[stream] gemini file stream got data line : ~a"
                                                     line)
-                        (write-sequence line file-stream)
-                        (increment-bytes-count wrapper-object line :convert-to-octets t)
-                        (setf (parsed-lines wrapper-object)
-                              (append (parsed-lines wrapper-object)
-                                      parsed-line))
+                        (write-out-stream file-stream wrapper-object line)
                         (let ((event (make-gemini-download-event line
                                                                  parsed-line
                                                                  wrapper-object

src/gemini/gemini-parser.lisp

@@ -753,6 +753,12 @@
         (with-initialized-parser (build-rows))
         (build-rows))))
 
+(defun make-error-parsing-line (message)
+  `(:error ,message))
+
+(defun error-parsing-line-extract-message (message)
+  (second message))
+
 (defun parse-gemini-file (data &key (initialize-parser nil) (add-metadata t))
   (flet ((parse-data (data)
            (let* ((lines  (if (string= (format nil "~%") data)

src/gemini/package.lisp

@@ -63,6 +63,8 @@
    :gemini-response
    :status-code
    :meta
+   :make-error-parsing-line
+   :error-parsing-line-extract-message
    :parse-gemini-file
    :absolutize-link
    :make-gemini-iri

src/gui/client/main-window.lisp

@@ -845,7 +845,7 @@ local file paths."
       (labels ((key->font (key)
                  (or (cdr (assoc :key font-cache))
                      (let ((font (ecase key
-                                   ((:vertical-space :text :li)
+                                   ((:vertical-space :text :li :error)
                                     (gui-conf:gemini-text-font-configuration))
                                    (:h1
                                     (gui-conf:gemini-h1-font-configuration))
@@ -864,7 +864,7 @@ local file paths."
                        font)))
                (key->colors (key)
                  (ecase key
-                   ((:vertical-space :text :li)
+                   ((:vertical-space :text :li :error)
                     (gui-conf:gemini-window-colors))
                    (:h1
                     (gui-conf:gemini-h1-colors))
@@ -878,7 +878,7 @@ local file paths."
                     (gui-conf:gemini-preformatted-text-colors))))
                (key->justification (key)
                  (ecase key
-                   ((:vertical-space :text :li :a)
+                   ((:vertical-space :text :li :a :error)
                     :left)
                    (:h1
                     (gui-conf:gemini-h1-justification))
@@ -1010,7 +1010,9 @@ local file paths."
                       (render-line :pre-end rendered-line render-line-count))
                      (:a
                       (incf render-line-count)
-                      (render-link ir-line rendered-line render-line-count)))))))))
+                      (render-link ir-line rendered-line render-line-count))
+                     (:error
+                      (print-error-message (ir-line ir-line))))))))))
 
 (defun collect-ir-lines (request-iri main-window lines)
   (with-accessors ((ir-lines             ir-lines)
@@ -1029,7 +1031,7 @@ local file paths."
           (vector-push-extend line ir-lines)
           (let ((type (ir-type line)))
             (ecase (format-keyword type)
-              (:vertical-space
+              ((:vertical-space :error)
                (vector-push-extend (format nil "") ir-rendered-lines))
               (:as-is
                (vector-push-extend (ir-line line) ir-rendered-lines))

src/gui/server/public-api-gemini-stream.lisp

@@ -25,6 +25,8 @@
 
 (a:define-constant +certificate-expired-status-code+                  -3 :test #'=)
 
+(a:define-constant +stream-error+                                     -4 :test #'=)
+
 (defun debug-gemini-gui (&rest data)
   (apply #'gemini-client:debug-gemini
          (strcat "[gui] " (first data))
@@ -86,11 +88,57 @@
                        (force-output file-stream)
                        (if (download-completed-p buffer read-so-far)
                            (progn
-                             (setf (gemini-viewer:stream-status wrapper-object) :completed)
+                             (setf (gw:stream-status wrapper-object) :completed)
                              (gemini-client:close-ssl-socket socket))
                            (%fill-buffer))))))
             (%fill-buffer))))))
 
+(defun request-stream-gemini-document-thread (wrapper-object scheme host
+                                              port path query fragment favicon
+                                              gemini-format-p)
+  (with-accessors ((download-socket gw:download-socket)
+                   (download-stream gw:download-stream)
+                   (octet-count     gw:octet-count)
+                   (support-file    gw:support-file)) wrapper-object
+    (lambda ()
+      (gemini-parser:with-initialized-parser
+        (a:when-let ((extension (fs:get-extension path)))
+          (setf support-file (fs:temporary-file :extension extension)))
+        (gw::with-open-support-file (file-stream support-file character)
+          (let* ((url                    (gemini-parser:make-gemini-iri host
+                                                                        path
+                                                                        :scheme   scheme
+                                                                        :query    query
+                                                                        :port     port
+                                                                        :fragment fragment))
+                 (url-header             (format nil "~a ~a~2%" favicon url)))
+            (gw::write-out-stream file-stream wrapper-object url-header)
+            (gw::maybe-write-out-preformat-wrapper file-stream wrapper-object gemini-format-p)
+            (handler-case
+                (loop
+                  named download-loop
+                  for ct from 0
+                  for line-as-array = (read-line-into-array download-stream)
+                  while line-as-array do
+                    (gemini-client:debug-gemini "[stream] gemini file stream raw data line : ~a"
+                                                line-as-array)
+                    (if (gw:downloading-allowed-p wrapper-object)
+                        (let* ((line (if (= ct 0)
+                                         (gw::array->string line-as-array t)
+                                         (gw::array->string line-as-array nil))))
+                          (gemini-client:debug-gemini "[stream] gemini file stream got data line : ~a"
+                                                      line)
+                          (gw::write-out-stream file-stream wrapper-object line))
+                        (return-from download-loop nil)))
+              (error (e)
+                (let ((message (gemini-parser:make-error-parsing-line (format nil
+                                                                              (_ "Gemini stream error: ~a")
+                                                                              e))))
+                  (gw::append-parsed-line wrapper-object (list message)))))
+            (setf (gw:stream-status wrapper-object) :completed)
+            (gw::maybe-write-out-preformat-wrapper file-stream wrapper-object gemini-format-p)
+            (gemini-client:close-ssl-socket download-socket)))))))
+
 (defun request-success-dispatched-fn (status code-description meta response socket iri parsed-iri)
   (declare (ignore iri))
   (multiple-value-bind (actual-iri host path query port fragment scheme)
@@ -113,17 +161,15 @@
                                                       :download-stream response
                                                       :download-socket socket))
                       (favicon         (gemini-viewer::fetch-favicon parsed-iri))
-                      (thread-fn       (gemini-viewer::request-stream-gemini-document-thread gemini-stream
-                                                                                             scheme
-                                                                                  host
-                                                                                  port
-                                                                                  path
-                                                                                  query
-                                                                                  fragment
-                                                                                  favicon
-                                                                                  gemini-format-p
-                                                                                  :notify nil
-                                                                                  :open-with-external-program nil)))
+                      (thread-fn (request-stream-gemini-document-thread gemini-stream
+                                                                        scheme
+                                                                        host
+                                                                        port
+                                                                        path
+                                                                        query
+                                                                        fragment
+                                                                        favicon
+                                                                        gemini-format-p)))
                  (gemini-viewer:push-db-stream gemini-stream)
                  (gemini-viewer::downloading-start-thread gemini-stream
                                                           thread-fn

src/message-rendering-utils.lisp

@@ -81,15 +81,14 @@ followed by different acct e.g.:
   is found as key in the alist `usernames-table' note that `usernames-table' is not a map see: `usernames->usernames-table'."
   (let ((results text-line))
     (loop for (local-mention . actual-mention) in usernames-table do
-      (let ((local-mention-re (strcat "(\\s|^)"
+      (let* ((local-mention-re (strcat "(\\s|^)"
                                       local-mention
-                                      "(\\s|$)")))
-        (multiple-value-bind (replaced matched)
-            (funcall replace-function
-                     local-mention-re
-                     results
-                     (wrap-with actual-mention " "))
-          (setf results replaced))))
+                                      "(\\s|$)"))
+             (replaced         (funcall replace-function
+                                        local-mention-re
+                                        results
+                                        (wrap-with actual-mention " "))))
+          (setf results replaced)))
     ;; NOTE: as `usernames-table' is not a map some mention can not be
     ;; replaced properly e.g.
     ;;

src/ui-goodies.lisp

@@ -2304,11 +2304,11 @@ there."
                       choices)))
            (find-poll-id ()
              (when-let* ((fields              (line-oriented-window:selected-row-fields *thread-window*))
-                         (status-id           (db:row-message-status-id fields))
-                         (reblogged-status-id (db:row-message-reblog-id fields))
-                         (poll                (or (db:find-poll-bound-to-status status-id)
-                                                  (db:find-poll-bound-to-status reblogged-status-id))))
-               (db:row-id poll)))
+                         (status-id           (db:row-message-status-id fields)))
+                        (let* ((reblogged-status-id (db:row-message-reblog-id fields))
+                               (poll                (or (db:find-poll-bound-to-status status-id)
+                                                        (db:find-poll-bound-to-status reblogged-status-id))))
+                          (db:row-id poll))))
            (on-input-complete (choices)
              (let ((choices-list (split-words choices)))
                (if (or (null choices-list)