mirror of https://codeberg.org/cage/tinmop/
364 lines
17 KiB
Common Lisp
364 lines
17 KiB
Common Lisp
;; tinmop: a multiprotocol client
|
|
;; Copyright © cage
|
|
|
|
;; This program is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
(in-package :message-rendering-utils)
|
|
|
|
(define-constant +temp-mention-prefix+ "/at/" :test #'string=)
|
|
|
|
(defun mention-p (maybe-mention)
|
|
(scan (strcat "^" +mention-prefix+)
|
|
maybe-mention))
|
|
|
|
(defun add-mention-prefix (username)
|
|
(if (mention-p username)
|
|
username
|
|
(strcat +mention-prefix+ username)))
|
|
|
|
(defun strip-mention-prefix (maybe-mention)
|
|
(if (not (mention-p maybe-mention))
|
|
maybe-mention
|
|
(subseq maybe-mention (length +mention-prefix+))))
|
|
|
|
(defun find-first-mention-in-message (message-body)
|
|
(when message-body
|
|
(with-input-from-string (body-stream message-body)
|
|
(when-let* ((first-line (read-line body-stream nil ""))
|
|
(mentions (split-words first-line))
|
|
(first-mention (first mentions)))
|
|
(when (mention-p first-mention)
|
|
first-mention)))))
|
|
|
|
(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)))
|
|
|
|
(defun crypto-message-destination-user (message-data)
|
|
(with-accessors ((body sending-message:body)
|
|
(subject sending-message:subject)
|
|
(reply-to sending-message:reply-to)
|
|
(visibility sending-message:visibility)) message-data
|
|
(when (string= visibility
|
|
+status-direct-visibility+)
|
|
(if reply-to
|
|
(let ((reply-username (status-id->username reply-to)))
|
|
(db:username->id reply-username))
|
|
(when-let* ((mention (find-first-mention-in-message body))
|
|
(user (db:user-exists-p (msg-utils:strip-mention-prefix mention)))
|
|
(username (db:row-user-username user)))
|
|
(db:username->id username))))))
|
|
|
|
(defun maybe-crypt-message (send-message-window &key (notify-cant-crypt nil))
|
|
(with-accessors ((message-data sending-message:message-data)) send-message-window
|
|
(with-accessors ((body sending-message:body)
|
|
(subject sending-message:subject)
|
|
(reply-to sending-message:reply-to)
|
|
(visibility sending-message:visibility)) message-data
|
|
(when (string= visibility
|
|
+status-direct-visibility+)
|
|
(let ((destination-user-id (crypto-message-destination-user message-data)))
|
|
(if (null destination-user-id)
|
|
(when notify-cant-crypt
|
|
(ui:notify (_ "This message will *not* be encrypted")))
|
|
(let* ((destination-username (db:user-id->username destination-user-id))
|
|
(destination-mention (msg-utils:add-mention-prefix destination-username))
|
|
(new-body (misc:make-fresh-array 0 #\Space 'character nil))
|
|
(crypto-key (db:crypto-user-key destination-username)))
|
|
(if (null crypto-key)
|
|
(when notify-cant-crypt
|
|
(ui:notify (format nil
|
|
(_ "No key to encrypt message for ~s found")
|
|
destination-username)))
|
|
(with-output-to-string (body-stream new-body)
|
|
;; add username on top
|
|
(format body-stream "~a~%" destination-mention)
|
|
(format body-stream
|
|
"~a~%"
|
|
(crypto-utils:encrypt-message body crypto-key))
|
|
(setf body new-body))))))))))
|
|
|
|
(defun find-crypto-data (text)
|
|
(with-input-from-string (stream text)
|
|
(loop for line = (read-line stream nil nil)
|
|
while line
|
|
do
|
|
(when (crypto-utils:crypto-text-p line)
|
|
(return-from find-crypto-data line))))
|
|
nil)
|
|
|
|
(defun maybe-decrypt-message (message-row message-text &key (notify-cant-decrypt nil))
|
|
(let* ((username (db:row-message-username message-row))
|
|
(html-stripped (html-utils:html->text (db:row-message-content message-row)
|
|
:add-link-footnotes nil
|
|
:quote-prefix (swconf:message-window-quote-prefix)
|
|
:list-item-prefix (swconf:message-window-bullet-prefix)))
|
|
(mention (find-first-mention-in-message html-stripped))
|
|
(reply-p (db:row-message-reply-to-id message-row))
|
|
(crypto-key (cond
|
|
(reply-p
|
|
(db:crypto-user-key username))
|
|
(mention
|
|
(db:crypto-user-key (msg-utils:strip-mention-prefix mention)))
|
|
(t
|
|
nil)))
|
|
(crypto-data (find-crypto-data message-text)))
|
|
(if crypto-data
|
|
(if (and (null crypto-key)
|
|
notify-cant-decrypt)
|
|
(ui:notify (format nil
|
|
(_ "Unable to find the crypto key for user ~s")
|
|
username)
|
|
:as-error t)
|
|
(crypto-utils:decrypt-message crypto-data crypto-key))
|
|
nil)))
|
|
|
|
(defun attachment-type->description (type)
|
|
(macrolet ((gen-cond (key types descriptions)
|
|
`(cond
|
|
,@(append
|
|
(loop
|
|
for type in types
|
|
for description in descriptions collect
|
|
`((string-equal ,type ,key) ,description))
|
|
`((t
|
|
(_ "invalid type")))))))
|
|
(gen-cond type
|
|
("unknown" "image" "gifv" "video" "audio")
|
|
((_ "unknown") (_ "image") (_ "gifv") (_ "video") (_ "audio")))))
|
|
|
|
(defun attachment-type->metadata (type row)
|
|
(let ((data (misc:make-fresh-array 0 #\a 'character nil)))
|
|
(with-output-to-string (stream data)
|
|
(format stream
|
|
(_ "description: ~a~%")
|
|
(db-utils:db-getf row :description))
|
|
(format stream
|
|
(_ "size: ~aX~a pixels~%")
|
|
(db-utils:db-getf row :width)
|
|
(db-utils:db-getf row :height))
|
|
(when (or (string-equal type "gifv")
|
|
(string-equal type "video")
|
|
(string-equal type "audio"))
|
|
(format stream
|
|
(_"duration: ~a~%")
|
|
(db-utils:db-getf row :duration))))
|
|
data))
|
|
|
|
(defun status-attachments->text (status-id)
|
|
(let ((text (misc:make-fresh-array 0 #\Space 'character nil)))
|
|
(when-let* ((all-attachments (db:all-attachments-to-status status-id)))
|
|
(with-output-to-string (stream text)
|
|
(multiple-value-bind (header-prefix header-postfix header-value)
|
|
(swconf:message-window-attachments-header)
|
|
(let ((actual-header-value (or header-value
|
|
(_ "Attachments"))))
|
|
(format stream (strcat header-prefix
|
|
actual-header-value
|
|
header-postfix))))
|
|
(loop for attachment in all-attachments do
|
|
(let ((type (db-utils:db-getf attachment
|
|
:type
|
|
:default (_ "unknown"))))
|
|
(format stream
|
|
(_"type: ~a~%metadata~%~a~%address: ~a~2%")
|
|
(attachment-type->description type)
|
|
(attachment-type->metadata type attachment)
|
|
(db-utils:db-getf attachment :url :default (_ "unknown")))))))
|
|
text))
|
|
|
|
(defgeneric message-original->text-body (object &key &allow-other-keys))
|
|
|
|
(defmethod message-original->text-body ((object string) &key &allow-other-keys)
|
|
(let* ((raw-body (html-utils:html->text object
|
|
:quote-prefix (swconf:message-window-quote-prefix)
|
|
:list-item-prefix (swconf:message-window-bullet-prefix))))
|
|
(emoji-shortcodes:emojify raw-body)))
|
|
|
|
(defun prepend-crypto-marker (decrypted-text)
|
|
(format nil "~a~2%~a" (swconf:crypted-mark-value) decrypted-text))
|
|
|
|
(defmethod message-original->text-body ((object null) &key &allow-other-keys)
|
|
(declare (ignore object))
|
|
"")
|
|
|
|
(defmethod message-original->text-body ((object list)
|
|
&key
|
|
(notify-cant-decrypt nil)
|
|
(try-decrypt nil)
|
|
&allow-other-keys)
|
|
(let ((as-text (message-original->text-body (db:row-message-content object))))
|
|
(if try-decrypt
|
|
(let ((decrypted (maybe-decrypt-message object
|
|
as-text
|
|
:notify-cant-decrypt notify-cant-decrypt)))
|
|
(if decrypted
|
|
(message-original->text-body (prepend-crypto-marker decrypted))
|
|
as-text))
|
|
as-text)))
|
|
|
|
(defun visibility->mark (visibility)
|
|
(let ((mapping (swconf:message-windows-visibility-marks)))
|
|
(db-getf mapping
|
|
(make-keyword (string-upcase visibility))
|
|
:default visibility
|
|
:only-empty-or-0-are-null t)))
|
|
|
|
(defun message-original->text-header (message-row)
|
|
(let* ((date-format (swconf:date-fmt swconf:+key-message-window+))
|
|
(reblogged-id (db:row-message-reblog-id message-row))
|
|
(username (db:row-message-username message-row))
|
|
(display-name (db:row-message-user-display-name message-row))
|
|
(creation-time (db:row-message-creation-time message-row))
|
|
(reblogged-row (when reblogged-id
|
|
(db:find-status-id reblogged-id)))
|
|
(subject (if reblogged-id
|
|
(db:row-message-subject reblogged-row)
|
|
(db:row-message-subject message-row)))
|
|
(visibility (visibility->mark (db:row-message-visibility message-row)))
|
|
(lockedp (db-utils:db-not-nil-p (db:row-lockedp message-row)))
|
|
(locked-mark (swconf:message-window-account-locking-status-mark lockedp))
|
|
(encoded-date (db-utils:encode-datetime-string creation-time))
|
|
(language (db:row-language message-row))
|
|
(parent-author-id (db:row-message-reply-to-account-id message-row))
|
|
(parent-author (when parent-author-id
|
|
(db:user-id->username parent-author-id)))
|
|
(in-reply-to-label (_ "In reply of: "))
|
|
(from-label (_ "From: "))
|
|
(boosted-label (_ "Boosted: "))
|
|
(visibility-label (_ "Visibility: "))
|
|
(language-label (_ "Language: "))
|
|
(subject-label (_ "Subject: "))
|
|
(boosted-username (when reblogged-id
|
|
(db:status-id->username reblogged-id)))
|
|
(date-label (_ "Date: "))
|
|
(padding-length (max (length from-label)
|
|
(length date-label)
|
|
(length boosted-label)
|
|
(length visibility-label)
|
|
(length in-reply-to-label)
|
|
(length subject-label)
|
|
(length language-label)))
|
|
(text (misc:make-fresh-array 0 #\Space 'character nil)))
|
|
(with-output-to-string (stream text)
|
|
(format stream
|
|
"~a(~a) ~a~a~%"
|
|
(right-padding from-label padding-length)
|
|
display-name username locked-mark)
|
|
(format stream
|
|
"~a~a~%"
|
|
(right-padding date-label padding-length)
|
|
(format-time encoded-date date-format))
|
|
(format stream
|
|
"~a~a~%"
|
|
(right-padding visibility-label padding-length)
|
|
visibility)
|
|
(when parent-author
|
|
(format stream
|
|
"~a~a~%"
|
|
(right-padding in-reply-to-label padding-length)
|
|
parent-author))
|
|
(when language
|
|
(format stream "~a~a~%"
|
|
(right-padding language-label padding-length)
|
|
language))
|
|
(when subject
|
|
(format stream "~a~a~%"
|
|
(right-padding subject-label padding-length)
|
|
subject))
|
|
(format stream "~%")
|
|
(when reblogged-id
|
|
(format stream "~a~a~%"
|
|
(right-padding boosted-label padding-length)
|
|
boosted-username)))
|
|
text))
|
|
|
|
(defun poll->text (poll-id width)
|
|
(when poll-id
|
|
(when-let* ((poll (db:find-poll poll-id))
|
|
(options (db:all-poll-options poll-id))
|
|
(all-titles (loop for option in options collect
|
|
(db:row-title option)))
|
|
(all-rendered-indices (loop for idx from 0 below (length all-titles) collect
|
|
(format nil "[~a] " idx)))
|
|
(vote-sum (reduce #'+
|
|
(mapcar #'db:row-votes-count options)))
|
|
(max-title-w (find-max-line-length all-titles))
|
|
(max-index-w (find-max-line-length all-rendered-indices))
|
|
(max-bar-width (- width
|
|
max-title-w
|
|
max-index-w
|
|
6))
|
|
(bar-char (swconf:vote-vertical-bar)))
|
|
(let ((expiredp (db:row-poll-expired-p poll))
|
|
(multiple-vote-allowed (db:row-poll-multiple-vote-p poll)))
|
|
(with-output-to-string (stream)
|
|
(format stream "~3%")
|
|
(loop
|
|
for title in all-titles
|
|
for index in all-rendered-indices
|
|
for option in options
|
|
do
|
|
(let* ((padded-title (left-padding title max-title-w))
|
|
(padded-index (left-padding index max-index-w))
|
|
(rate (handler-case
|
|
(/ (db:row-votes-count option)
|
|
vote-sum)
|
|
(error () 0)))
|
|
(vote (left-padding (format nil "~,2f%" (* 100 rate)) 4))
|
|
(bar-w (truncate (* rate max-bar-width))))
|
|
(format stream
|
|
"~a~a~a "
|
|
(swconf:message-window-bullet-prefix)
|
|
padded-index
|
|
padded-title)
|
|
(if expiredp
|
|
(progn
|
|
(loop for i from 0 below bar-w do
|
|
(princ bar-char stream))
|
|
(format stream
|
|
" ~a~%"
|
|
(left-padding vote (+ 4 ; size of vote percent: ' nnn%'
|
|
(- max-bar-width bar-w)))))
|
|
(format stream "~%"))))
|
|
(if multiple-vote-allowed
|
|
(format stream "~%~a~%" (_ "Multiple choices allowed"))
|
|
(format stream "~%~a~%" (_ "A single choice allowed")))
|
|
(if expiredp
|
|
(format stream "~%~a~%" (_ "The poll has expired"))
|
|
(format stream "~%~a~%" (_ "NB: results not shown as the poll has not expired"))))))))
|
|
|
|
|
|
(defun signature ()
|
|
(when-let ((signature-file (swconf:signature-file-path)))
|
|
(format nil "~%-- ~%~a" (fs:slurp-file signature-file))))
|