- removed '*use-tk-for-decoding-png*'.

- [fediverse] fixed replacing of mentions.
- [fediverse] reworked mentions expansion's code to prevent missing mentions
2024-11-10 14:52:39 +01:00 · 2024-11-10 14:52:17 +01:00 · 2024-11-10 14:31:41 +01:00 · 2024-11-09 14:21:58 +01:00 · 2024-11-09 14:04:12 +01:00 · 2024-11-09 13:25:01 +01:00
7 changed files with 128 additions and 69 deletions
--- a/src/db.lisp
+++ b/src/db.lisp
@ -412,7 +412,7 @@
                           +make-close+)))

 (defun make-mention ()
-  (query-low-level (strcat (prepare-table +table-mention+)
+  (query-low-level (strcat (prepare-table +table-mention+ :integer-id-p t :autoincrementp t)
                           " username              TEXT    NOT NULL,"
                           ;; this is the actual user identification
                           " acct                  TEXT    NOT NULL,"
@ -420,7 +420,7 @@
                           " url                   TEXT    NOT NULL,"
                           ;; local value, timestamp
                           " \"date-added\"        TEXT NOT NULL,"
-                           " UNIQUE(id) ON CONFLICT FAIL"
+                           " \"status-id\"         TEXT NOT NULL"
                           +make-close+)))

 (defun make-followed-user ()
@ -1327,25 +1327,29 @@ than (swconf:config-purge-history-days-offset) days in the past"
                           +tag-separator+)
        "")))

-(defmethod update-db ((object tooter:mention) &key &allow-other-keys)
+(defmethod update-db ((object tooter:mention) &key (status-id nil) &allow-other-keys)
  (with-accessors ((id               tooter:id)
                   (username         tooter:username)
                   (account-name     tooter:account-name)
                   (url              tooter:url)) object
+    (assert status-id)
    (let ((actual-username (clean-chars username))
          (actual-acct     (clean-chars account-name))
          (now             (prepare-for-db (local-time-obj-now))))
-      (insert-or-update +table-mention+
-                        (:id
-                         :username
-                         :acct
-                         :url
-                         :date-added)
-                        (id
-                         actual-username
-                         actual-acct
-                         url
-                         now)))))
+      (when (not (mentioned-username->acct actual-username
+                                           status-id
+                                           :add-mention-prefix nil))
+        (query (make-insert +table-mention+
+                            (:username
+                             :acct
+                             :url
+                             :date-added
+                             :status-id)
+                            (actual-username
+                             actual-acct
+                             url
+                             now
+                             status-id)))))))

 (defmethod update-db ((object tooter:status)
                      &key
@ -1378,7 +1382,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
                   (poll                   tooter:poll)
                   (mentions               tooter:mentions)) object
    (update-db account)
-    (mapcar #'update-db mentions)
+    (mapcar (lambda (a) (update-db a :status-id id)) mentions)
    (let* ((account-id          (tooter:id account))
           (actual-created-at   (decode-datetime-string created-at))
           (actual-application  (prepare-for-db application))
@ -1924,11 +1928,21 @@ the message identified by the tuple."
            (cons (msg-utils:add-mention-prefix local-name)
                  (msg-utils:add-mention-prefix username))))))

-(defun mentioned-username->account (username &key (add-mention-prefix t))
+(defun mentioned-username->acct (username status-id
+                                          &key
+                                          (add-mention-prefix t)
+                                          (ignored-acct-list '()))
  "Returns an alist of all known accounts as ('@'local-username . '@'acct)."
-  (let* ((query (select :acct
-                  (from +table-mention+)
-                  (where (:= :username username))))
+  (let* ((query (if ignored-acct-list
+                    (select :acct
+                      (from +table-mention+)
+                      (where (:and (:= :username username)
+                                   (:= :status-id status-id)
+                                   (:not (:in :acct ignored-acct-list)))))
+                    (select :acct
+                      (from +table-mention+)
+                      (where (:and (:= :username username)
+                                   (:= :status-id status-id))))))
         (acct  (second (fetch-single query))))
    (if add-mention-prefix
        (msg-utils:add-mention-prefix acct)
--- a/src/gui/client/icons.lisp
+++ b/src/gui/client/icons.lisp
@ -123,30 +123,29 @@
                     (client-configuration:config-icons-scaling))))

 (defun load-icons ()
-  (let ((nodgui:*use-tk-for-decoding-png* t))
-    (setf *search*             (load-icon +search+))
-    (setf *back*               (load-icon +back+))
-    (setf *open-iri*           (load-icon +go+))
-    (setf *open-tour*          (load-icon +open-tour+))
-    (setf *refresh*            (load-icon +refresh+))
-    (setf *up*                 (load-icon +up+))
-    (setf *document-delete*    (load-icon +document-delete+))
-    (setf *document-add*       (load-icon +document-add+))
-    (setf *document-accept*    (load-icon +document-accept+))
-    (setf *document-edit*      (load-icon +document-edit+))
-    (setf *folder*             (load-icon +folder+))
-    (setf *star-yellow*        (load-icon +star-yellow+))
-    (setf *star-blue*          (load-icon +star-blue+))
-    (setf *arrow-up*           (load-icon +arrow-up+))
-    (setf *arrow-down*         (load-icon +arrow-down+))
-    (setf *cross*              (load-icon +cross+))
-    (setf *bus-go*             (load-icon +bus-go+))
-    (setf *dice*               (load-icon +dice+))
-    (setf *gemlog-subscribe*   (load-icon +gemlog-subscribe+))
-    (setf *gemlog-unsubscribe* (load-icon +gemlog-unsubscribe+))
-    (setf *inline-images*      (load-icon +inline-images+))
-    (setf *text*               (load-icon +text+))
-    (setf *profile*            (load-icon +profile+))
-    (setf *profile-disabled*   (disable-icon +profile+))
-    (setf *toc*                (load-icon +toc+))
-    (setf *toc-disabled*       (disable-icon +toc+))))
+  (setf *search*             (load-icon +search+))
+  (setf *back*               (load-icon +back+))
+  (setf *open-iri*           (load-icon +go+))
+  (setf *open-tour*          (load-icon +open-tour+))
+  (setf *refresh*            (load-icon +refresh+))
+  (setf *up*                 (load-icon +up+))
+  (setf *document-delete*    (load-icon +document-delete+))
+  (setf *document-add*       (load-icon +document-add+))
+  (setf *document-accept*    (load-icon +document-accept+))
+  (setf *document-edit*      (load-icon +document-edit+))
+  (setf *folder*             (load-icon +folder+))
+  (setf *star-yellow*        (load-icon +star-yellow+))
+  (setf *star-blue*          (load-icon +star-blue+))
+  (setf *arrow-up*           (load-icon +arrow-up+))
+  (setf *arrow-down*         (load-icon +arrow-down+))
+  (setf *cross*              (load-icon +cross+))
+  (setf *bus-go*             (load-icon +bus-go+))
+  (setf *dice*               (load-icon +dice+))
+  (setf *gemlog-subscribe*   (load-icon +gemlog-subscribe+))
+  (setf *gemlog-unsubscribe* (load-icon +gemlog-unsubscribe+))
+  (setf *inline-images*      (load-icon +inline-images+))
+  (setf *text*               (load-icon +text+))
+  (setf *profile*            (load-icon +profile+))
+  (setf *profile-disabled*   (disable-icon +profile+))
+  (setf *toc*                (load-icon +toc+))
+  (setf *toc-disabled*       (disable-icon +toc+)))
--- a/src/html-utils.lisp
+++ b/src/html-utils.lisp
@ -135,15 +135,19 @@

 (defun footnote-reference-re (&key (enforce-end-string t))
  (format nil
-          "~a[~a]+~@[$~]"
+          "(~a[~a]+)~@[$~]"
          #\ZERO_WIDTH_SPACE
          +digits-superscripts+
          enforce-end-string))

 (let ((scanner (cl-ppcre:create-scanner (footnote-reference-re))))
-  (defun strip-footnote-reference (word)
+  (defun strip-footnote-reference-word (word)
    (cl-ppcre:regex-replace scanner word "")))

+(let ((scanner (cl-ppcre:create-scanner (footnote-reference-re :enforce-end-string nil))))
+  (defun strip-all-footnote-reference (string)
+    (cl-ppcre:regex-replace-all scanner string "")))
+
 (defun block-tag-p (node)
  (and (consp node)
       (member node
--- a/src/message-rendering-utils.lisp
+++ b/src/message-rendering-utils.lisp
@ -40,13 +40,21 @@
  (let ((words                 (split-words message-line))
        (mention-prefix-length (length +mention-prefix+)))
    (mapcar (lambda (a)
-              (html-utils:strip-footnote-reference (subseq a mention-prefix-length))) ; remove the @
+              (html-utils:strip-footnote-reference-word (subseq a
+                                                                mention-prefix-length))) ; remove the #\@
            (remove-if-not (lambda (word)
                             (cl-ppcre:scan (strcat "^" +mention-prefix+) word))
                           words))))

-(defun usernames->usernames-table (message)
-  "Returns a list of pairs ('@'username . '@'acct)."
+(defun usernames->usernames-table (message status-id)
+  "Returns a list of pairs (\"'@'username\" . \"'@'acct\").
+
+Please note that this  table is not a map as the  same username can be
+followed by different acct e.g.:
+
+((\"@foo\" . \"@foo@bar\")
+ (\"@foo\" . \"@foo@baz\"))
+"
  (let ((usernames '()))
    (loop for line in (split-lines message)
          do
@ -55,26 +63,56 @@
                     (concatenate 'list
                                  usernames
                                  usernames-in-line))))
-    (mapcar (lambda (username)
-              (cons (add-mention-prefix username)
-                    (db:mentioned-username->account username)))
-            usernames)))
+    (let ((already-found-acct '()))
+      (mapcar (lambda (username)
+                (let ((acct (db:mentioned-username->acct username
+                                                         status-id
+                                                         :add-mention-prefix nil
+                                                         :ignored-acct-list already-found-acct)))
+                  (prog1
+                      (cons (add-mention-prefix username)
+                            (add-mention-prefix acct))
+                    (push acct already-found-acct))))
+              usernames))))

-(defun local-mention->acct (text-line usernames-table)
+(defun local-mention->acct (text-line usernames-table
+                            &optional (replace-function #'cl-ppcre:regex-replace))
  "Substitute in `text-line' '@user' with '@user@server', if '@user'
-  is found as key in the alist `usernames-table'"
+  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|^)"
                                      local-mention
-                                      (html-utils:footnote-reference-re :enforce-end-string nil))))
-        (setf results (regex-replace-all local-mention-re
-                                         results
-                                         (strcat " " actual-mention)))))
-    results))
+                                      "(\\s|$)")))
+        (multiple-value-bind (replaced matched)
+            (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.
+    ;;
+    ;; let 'usernames-table':
+    ;;
+    ;; ((\"@foo\" . \"@foo@bar\")
+    ;; (\"@foo\" . \"@foo@baz\"))
+    ;;
+    ;; and line 'line':
+    ;;
+    ;; "@foo @foo @foo @foo"
+    ;;
+    ;; the heuristic here  will replace the first  occurence of "@foo"
+    ;; with the cdr  of the first element of the  map, the second with
+    ;; the cdr  of the second and  so on; any other  occurence will be
+    ;; replaced with  the cdr  of the  first '@foo'  in the  map.  Not
+    ;; optimal but no mentions should be missed this way.
+    (if (eq replace-function #'cl-ppcre:regex-replace)
+        (local-mention->acct results usernames-table #'cl-ppcre:regex-replace-all)
+        results)))

-(defun expand-mention (text)
-  (let ((mentioned-users-table (usernames->usernames-table text)))
+(defun expand-mention (text status-id)
+  (let ((mentioned-users-table (usernames->usernames-table text status-id)))
    (with-output-to-string (stream)
      (loop for line in (text-utils:split-lines text) do
        (let ((line-fixed-mentions (local-mention->acct line mentioned-users-table)))
--- a/src/package.lisp
+++ b/src/package.lisp
@ -528,7 +528,8 @@
   :position-tag
   :node->link
   :append-footnote-reference
-   :strip-footnote-reference
+   :strip-footnote-reference-word
+   :strip-all-footnote-reference
   :footnote-reference-re
   :html->text))

@ -996,7 +997,7 @@
   :message-root->tree
   :message->thread-users
   :all-mentioned-accounts
-   :mentioned-username->account
+   :mentioned-username->acct
   :message-id->tree
   :message-from-timeline-folder-message-index
   :message-index->tree
--- a/src/program-events.lisp
+++ b/src/program-events.lisp
@ -2103,7 +2103,7 @@
                                :direction         :output
                                :if-exists         :supersede
                                :if-does-not-exist :create)
-          (let ((mentioned-users-text (msg-utils:expand-mention text)))
+          (let ((mentioned-users-text (msg-utils:expand-mention text status-id)))
            (write-sequence mentioned-users-text stream)))
        (croatoan:end-screen)
        (tui:with-notify-errors
--- a/src/ui-goodies.lisp
+++ b/src/ui-goodies.lisp
@ -1383,7 +1383,9 @@ It an existing file path is provided the command will refuse to run."
               ;; in db (folder, timeline).
               (when-let* ((message        (db:find-message-id reply-id))
                           (reply-username (db:row-message-username message))
-                           (rendered-text  (db:row-message-rendered-text message))
+                           (content        (db:row-message-content message))
+                           (rendered-text  (msg-utils:message-original->text-body content
+                                                                                  :add-link-footnotes nil))
                           (lines          (split-lines rendered-text))
                           (quote-mark     (swconf:quote-char))
                           (quoted-text    (strcat quote-mark
@ -1397,7 +1399,8 @@ It an existing file path is provided the command will refuse to run."
                                  :direction    :output
                                  :element-type 'character)
                   (format stream "~a~%" (msg-utils:add-mention-prefix reply-username))
-                   (let ((mentioned-users-text (msg-utils:expand-mention quoted-text)))
+                   (let ((mentioned-users-text (msg-utils:expand-mention quoted-text
+                                                                         reply-id)))
                     (write-sequence mentioned-users-text stream))))))
           (add-signature (file)
             (when-let ((signature (message-rendering-utils:signature)))
Author	SHA1	Message	Date
cage	407425b5bc	- removed 'use-tk-for-decoding-png'.	2024-11-10 14:52:39 +01:00
cage	e466dd7c6e	- [fediverse] fixed replacing of mentions.	2024-11-10 14:52:17 +01:00
cage	316ad365e2	- [fediverse] reworked mentions expansion's code to prevent missing mentions (see `c790da4407`); - changed function's name: 'mentioned-username->account' -> 'mentioned-username->acct'.	2024-11-10 14:31:41 +01:00
cage	e1fae66272	- [fediverse] fixed RE to match a mention.	2024-11-09 14:21:58 +01:00
cage	4604451dcd	- [fediverse] ensured using original content's post as quoted text in a reply.	2024-11-09 14:04:12 +01:00
cage	c790da4407	- [DB changes] added a reference to a a row of table 'status' to each row of table 'mention' This changes is needed to prevent mention lookup code to find the wrong acct, as matching is based only from the username (that is the string on the left of the '@'). Two different acct can share the same username, so the old code returned the first acct the db provided matching the username, not necessarily the correct one. E.g. table mention username \| acct ---------+---------- foo \| foo@bar foo \| foo@baz looking for the first row that match "foo" → "foo@bar", but the post mentioned the "foo@baz" now the table has changed to; username \| acct \| status-id ---------+------------+---------- foo \| foo@bar \| 1 foo \| foo@baz \| 2 search looks for the first row that match "foo" for the status-id = 1: the correct value is returned: 'foo@baz'. this changes is not a solution, for example in a table like this: username \| acct \| status-id ---------+------------+---------- foo \| foo@bar \| 1 ---------+------------+---------- foo \| foo@bar \| 2 ---------+------------+--------- foo \| foo@baz \| 2 the same query as the one above can return the wrong row, containing "foo@bar" - changed function name: 'html-utils:strip-footnote-reference' → 'html-utils:strip-footnote-reference-word'.	2024-11-09 13:25:01 +01:00
cage	bb57160811	- [fediverse] fixed RE to match a mention.	2024-11-05 20:35:34 +01:00