- [fediverse] reworked mention in messages.

src/db.lisp

@@ -80,6 +80,9 @@
 (a:define-constant +table-account+                :account
   :test #'eq)
 
+(a:define-constant +table-mention+                :mention
+  :test #'eq)
+
 (a:define-constant +table-poll-option+            :poll-option
   :test #'eq)
 
@@ -408,6 +411,16 @@
                            " UNIQUE(id) ON CONFLICT FAIL"
                            +make-close+)))
 
+(defun make-mention ()
+  (query-low-level (strcat (prepare-table +table-mention+)
+                           " username              TEXT    NOT NULL,"
+                           ;; this is the actual user identification
+                           " acct                  TEXT    NOT NULL,"
+                           ;; profile homepage
+                           " url                   TEXT    NOT NULL,"
+                           " UNIQUE(id) ON CONFLICT FAIL"
+                           +make-close+)))
+
 (defun make-followed-user ()
   (query-low-level (strcat (prepare-table +table-followed-user+ :integer-id-p t :autoincrementp t)
                            " \"user-id\" TEXT "
@@ -679,6 +692,7 @@
               +table-input-history+
               +table-status+
               +table-account+
+              +table-mention+
               +table-followed-user+
               +table-subscribed-tag+
               +table-tag-histogram+
@@ -716,6 +730,7 @@
     (make-input-history)
     (make-crypto-data)
     (make-account)
+    (make-mention)
     (make-followed-user)
     (make-status)
     (make-ignored-status)
@@ -1302,6 +1317,25 @@ than (swconf:config-purge-history-days-offset) days in the past"
                            +tag-separator+)
         "")))
 
+(defmethod update-db ((object tooter:mention) &key &allow-other-keys)
+  (with-accessors ((id               tooter:id)
+                   (username         tooter:username)
+                   (account-name     tooter:account-name)
+                   (url              tooter:url)) object
+    (flet ((clean-chars (string)
+             (remove-corrupting-utf8-chars string)))
+      (let ((actual-username (clean-chars username))
+            (actual-acct     (clean-chars account-name)))
+        (insert-or-update +table-mention+
+                          (:id
+                           :username
+                           :acct
+                           :url)
+                          (id
+                           actual-username
+                           actual-acct
+                           url))))))
+
 (defmethod update-db ((object tooter:status)
                       &key
                         (timeline +local-timeline+)
@@ -1330,8 +1364,10 @@ than (swconf:config-purge-history-days-offset) days in the past"
                    (tags                   tooter:tags)
                    (application            tooter:application)
                    (media-attachments      tooter:media-attachments)
-                   (poll                   tooter:poll)) object
+                   (poll                   tooter:poll)
+                   (mentions               tooter:mentions)) object
     (update-db account)
+    (mapcar #'update-db mentions)
     (let* ((account-id         (tooter:id account))
            (actual-created-at  (decode-datetime-string created-at))
            (actual-application (prepare-for-db application))
@@ -1860,15 +1896,27 @@ the message identified by the tuple."
                                                                 (cdr b)))))))
     results))
 
-(defun mention-local->global-alist ()
+(defun all-mentioned-accounts ()
   "Returns an alist of all known accounts as ('@'local-username . '@'acct)."
-  (let* ((query (select (:username :acct) (from +table-account+)))
+  (let* ((query (select (:username :acct) (from +table-mention+)))
          (rows  (fetch-all-rows query)))
-    (loop for row in rows collect
-                          (let ((local-name (db-getf row :username))
-                                (username   (db-getf row :acct)))
-                            (cons (msg-utils:add-mention-prefix local-name)
-                                  (msg-utils:add-mention-prefix username))))))
+    (loop for row in rows
+          collect
+          (let ((local-name (db-getf row :username))
+                (username   (db-getf row :acct)))
+            (cons (msg-utils:add-mention-prefix local-name)
+                  (msg-utils:add-mention-prefix username))))))
+
+(defun mentioned-username->account (username &key (add-mention-prefix t))
+  "Returns an alist of all known accounts as ('@'local-username . '@'acct)."
+  (let* ((query (select :acct
+                  (from +table-mention+)
+                  (where (:= :username username))))
+         (rows  (mapcar #'second
+                        (fetch-all-rows query))))
+    (if add-mention-prefix
+        (mapcar #'msg-utils:add-mention-prefix rows)
+        rows)))
 
 (defmacro gen-access-message-row (name column
                                   &key

src/gempub.lisp

@@ -57,8 +57,12 @@
                         gempub-version
                         gempub-cover))
 
-(defrule gempub-entry (and gempub-key (? gempub-blanks) gempub-key-value-separator
-                           (? gempub-blanks) gempub-value #\NewLine)
+(defrule linebreak (or #\NewLine #\Return))
+
+(defrule gempub-entry (or (and gempub-key (? gempub-blanks) gempub-key-value-separator
+                               (? gempub-blanks) gempub-value (+ linebreak))
+                          (and gempub-key (? gempub-blanks) gempub-key-value-separator
+                               (? gempub-blanks) gempub-value))
   (:function (lambda (a)  (list (first a) (fifth a)))))
 
 (defrule gempub-metadata (* gempub-entry)
@@ -79,7 +83,10 @@
       (when (find +metadata-entry-name+ entries :test #'String=)
         (when-let ((metadata-raw (os-utils:unzip-single-file zip-file
                                                              +metadata-entry-name+)))
-          (parse 'gempub-metadata metadata-raw))))))
+          (handler-case
+              (parse 'gempub-metadata metadata-raw)
+            (error (e)
+              (error "Error parsing metadata from file ~s: ~a" zip-file e))))))))
 
 (defun save-metadata (zip-file)
   (when-let ((metadata (extract-metadata zip-file)))

src/gui/client/main-window.lisp

@@ -1177,6 +1177,8 @@ local file paths."
                                :status status)
              (client-stream-frame::refresh-all-streams
               (client-stream-frame::table stream-frame))))
+          ((iri:absolute-url-p iri)
+           (client-os-utils:open-resource-with-external-program main-window iri))
           ((or (fs:file-exists-p actual-iri)
                (fs:directory-exists-p actual-iri))
            (initialize-ir-lines main-window)

src/html-utils.lisp

@@ -121,7 +121,7 @@
                           (quote-prefix "> ") (list-item-prefix "* "))
   "Transform html to text, note that if `add-link-footnotes` is non nil footnotes that marks html link in the text are added aftere the body of the message
 
-This function uses a library that transform html5 text into s-expressions um the form
+This function uses a library that transform html5 text into s-expressions in the form
 
 '(name (attributes) children*)
 

src/message-rendering-utils.lisp

@@ -41,27 +41,36 @@
         (when (mention-p first-mention)
           first-mention)))))
 
+(defun line-find-all-usernames (message-line)
+  (let ((words (split-words message-line)))
+    (mapcar (lambda (a) (subseq a (length +mention-prefix+))) ; 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)."
+  (let ((usernames '()))
+    (loop for line in (split-lines message)
+          do
+             (let ((usernames-in-line (line-find-all-usernames line)))
+               (setf usernames
+                     (concatenate 'list
+                                  usernames
+                                  usernames-in-line))))
+    (mapcar (lambda (username)
+              (cons (add-mention-prefix username)
+                    (db:mentioned-username->account username)))
+            usernames)))
+
 (defun local-mention->acct (text-line usernames-table)
   "Substitute in  `text-line' '@user' with '@user@server',  if '@user'
   is found as key in the alist `usernames-table'"
-  (flet ((find-all-username (key)
-           (let ((found (mapcar #'cdr
-                                (remove-if-not (lambda (a) (string= (car a) key))
-                                               usernames-table))))
-             (join-with-strings found ", "))))
-    (let ((results text-line)
-          (local-mention-prefix      (strcat " " +mention-prefix+))
-          (local-mention-temp-prefix (strcat " " +temp-mention-prefix+)))
-      (setf results (regex-replace-all local-mention-prefix
-                                       results
-                                       local-mention-temp-prefix))
-      (loop for pair in usernames-table do
-           (when-let* ((local-mention             (car pair))
-                       (local-mention-re          (strcat " " local-mention))
-                       (actual-mention            (strcat " "
-                                                          (find-all-username local-mention))))
-             (setf results (regex-replace-all local-mention-re results actual-mention))))
-      results)))
+  (let ((results text-line))
+    (loop for (local-mention . actual-mention) in usernames-table do
+      (let ((local-mention-re (strcat " " local-mention)))
+        (setf results (regex-replace-all local-mention-re results actual-mention))))
+    results))
 
 (defun crypto-message-destination-user (message-data)
   (with-accessors ((body       sending-message:body)

src/package.lisp

@@ -986,6 +986,8 @@
    :message-children
    :message-root->tree
    :message->thread-users
+   :all-mentioned-accounts
+   :mentioned-username->account
    :message-id->tree
    :message-from-timeline-folder-message-index
    :message-index->tree
@@ -2425,6 +2427,7 @@
   (:export
    :+temp-mention-prefix+
    :add-mention-prefix
+   :usernames->usernames-table
    :strip-mention-prefix
    :local-mention->acct
    :crypto-message-destination-user

src/ui-goodies.lisp

@@ -1350,7 +1350,7 @@ It an existing file path is provided the command will refuse to run."
                              exceeding)
                          exceeding)))
 
-(defun compose-message (&key timeline folder reply-id subject (visibility +status-public-visibility+) (message-header-text nil))
+(defun compose-message (&key reply-id subject (visibility +status-public-visibility+) (message-header-text nil))
   "Compose a new message"
   (setf *message-to-send* (make-instance 'sending-message:message-ready-to-send
                                          :visibility visibility
@@ -1386,13 +1386,8 @@ It an existing file path is provided the command will refuse to run."
                            (quote-mark     (swconf:quote-char))
                            (quoted-lines   (mapcar (lambda (a) (strcat quote-mark a))
                                                    lines))
-                           (thread-users   (db:message->thread-users timeline
-                                                                     folder
-                                                                     reply-id
-                                                                     :local-name-prefix
-                                                                     message-rendering-utils:+temp-mention-prefix+
-                                                                     :acct-prefix
-                                                                     +mention-prefix+)))
+                           (mentioned-users-table
+                            (message-rendering-utils:usernames->usernames-table quoted-text)))
                  (with-open-file (stream file
                                          :if-exists    :append
                                          :direction    :output
@@ -1401,7 +1396,7 @@ It an existing file path is provided the command will refuse to run."
                    (loop for line in quoted-lines do
                         (let ((line-fixed-mentions
                                (message-rendering-utils:local-mention->acct line
-                                                                            thread-users)))
+                                                                            mentioned-users-table)))
                           (format stream "~a~%" line-fixed-mentions)))))))
            (add-signature (file)
              (when-let ((signature (message-rendering-utils:signature)))
@@ -1488,15 +1483,11 @@ It an existing file path is provided the command will refuse to run."
               (actual-message   (if (db:row-message-reblog-id selected-message)
                                     (db:find-message-id (db:row-message-reblog-id selected-message))
                                     selected-message))
-              (timeline         (db:row-message-timeline actual-message))
-              (folder           (thread-window:timeline-folder win))
               (username         (db:row-message-username   actual-message))
               (visibility       (db:row-message-visibility actual-message))
               (reply-id         (actual-author-message-id  actual-message)))
     (let* ((subject (db:row-message-subject actual-message)))
-      (compose-message :timeline   timeline
-                       :folder     folder
-                       :reply-id   reply-id
+      (compose-message :reply-id   reply-id
                        :subject    subject
                        :visibility visibility))))