1
0
Fork 0

Compare commits

...

3 Commits

7 changed files with 104 additions and 44 deletions

View File

@ -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

View File

@ -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)))

View File

@ -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)

View File

@ -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*)

View File

@ -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)

View File

@ -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

View File

@ -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))))