cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- [fediverse] ensured the posts do not contains non printable characters.

This commit is contained in:
cage 2024-09-27 14:18:52 +02:00
parent 3cc7da8184
commit 69b10a1b5d
2 changed files with 85 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

168
src/db.lisp
View File

@ -1215,6 +1215,9 @@ than (swconf:config-purge-history-days-offset) days in the past"
(query ,update-query)
(query ,insert-query)))))
(defun clean-chars (text)
(clean-unprintable-chars (remove-corrupting-utf8-chars text)))
(defmethod update-db ((object tooter:account) &key &allow-other-keys)
(with-accessors ((id tooter:id)
(username tooter:username)
@ -1234,55 +1237,53 @@ than (swconf:config-purge-history-days-offset) days in the past"
(statuses-count tooter:statuses-count)
(moved tooter:moved)
(bot tooter:bot)) object
(flet ((clean-chars (string)
(remove-corrupting-utf8-chars string)))
(let ((actual-created-at (decode-datetime-string created-at))
(actual-botp (prepare-for-db bot :to-integer t))
(actual-username (clean-chars username))
(actual-display-name (clean-chars display-name))
(actual-discoverable (prepare-for-db discoverable :to-integer t))
(actual-locked (prepare-for-db locked :to-integer t))
(actual-moved-id (if moved
(prepare-for-db (tooter:id moved))
(prepare-for-db nil))))
(complete:initialize-complete-username-cache)
(insert-or-update +table-account+
(:id
:username
:acct
:url
:display-name
:note
:avatar
:avatar-static
:header
:header-static
:locked
:discoverable
:created-at
:followers-count
:following-count
:statuses-count
:moved-id
:botp)
(id
actual-username
account-name
url
actual-display-name
note
avatar
avatar-static
header
header-static
actual-locked
actual-discoverable
actual-created-at
followers-count
following-count
statuses-count
actual-moved-id
actual-botp))))))
(let ((actual-created-at (decode-datetime-string created-at))
(actual-botp (prepare-for-db bot :to-integer t))
(actual-username (clean-chars username))
(actual-display-name (clean-chars display-name))
(actual-discoverable (prepare-for-db discoverable :to-integer t))
(actual-locked (prepare-for-db locked :to-integer t))
(actual-moved-id (if moved
(prepare-for-db (tooter:id moved))
(prepare-for-db nil))))
(complete:initialize-complete-username-cache)
(insert-or-update +table-account+
(:id
:username
:acct
:url
:display-name
:note
:avatar
:avatar-static
:header
:header-static
:locked
:discoverable
:created-at
:followers-count
:following-count
:statuses-count
:moved-id
:botp)
(id
actual-username
account-name
url
actual-display-name
note
avatar
avatar-static
header
header-static
actual-locked
actual-discoverable
actual-created-at
followers-count
following-count
statuses-count
actual-moved-id
actual-botp)))))
(defmethod update-db ((object tooter:tag-history) &key (tag nil) &allow-other-keys)
(assert (stringp tag))
@ -1322,19 +1323,17 @@ than (swconf:config-purge-history-days-offset) days in the past"
(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))))))
(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
@ -1368,28 +1367,29 @@ than (swconf:config-purge-history-days-offset) days in the past"
(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))
(tag-names (if tags
(mapcar #'client:tag-name tags)
'()))
(actual-tags (concat-tags object))
(actual-language (prepare-for-db language))
(let* ((account-id (tooter:id account))
(actual-created-at (decode-datetime-string created-at))
(actual-application (prepare-for-db application))
(tag-names (if tags
(mapcar #'client:tag-name tags)
'()))
(actual-tags (concat-tags object))
(actual-language (prepare-for-db language))
;; use string-downcase as a workaround because tooter return an upcased keyword
(actual-visibility (string-downcase (prepare-for-db visibility)))
(actual-sensitive (prepare-for-db sensitive :to-integer t))
(actual-favourited (prepare-for-db favourited :to-integer t))
(actual-pinned (prepare-for-db pinned :to-integer t))
(actual-reblogged (prepare-for-db reblogged :to-integer t))
(actual-muted (prepare-for-db muted :to-integer t))
(rendered-text (msg-utils:message-original->text-body content
:try-decrypt nil))
(reblog-id (if parent
(prepare-for-db (tooter:id parent))
(prepare-for-db nil)))
(account-ignored-p (user-ignored-p account-id))
(status-ignored-p (status-ignored-p id folder timeline)))
(actual-visibility (string-downcase (prepare-for-db visibility)))
(actual-sensitive (prepare-for-db sensitive :to-integer t))
(actual-favourited (prepare-for-db favourited :to-integer t))
(actual-pinned (prepare-for-db pinned :to-integer t))
(actual-reblogged (prepare-for-db reblogged :to-integer t))
(actual-muted (prepare-for-db muted :to-integer t))
(actual-spoiler-text (clean-chars spoiler-text))
(rendered-text (msg-utils:message-original->text-body content
:try-decrypt nil))
(reblog-id (if parent
(prepare-for-db (tooter:id parent))
(prepare-for-db nil)))
(account-ignored-p (user-ignored-p account-id))
(status-ignored-p (status-ignored-p id folder timeline)))
(when (not (and skip-ignored-p
(or status-ignored-p
account-ignored-p)))
@ -1426,7 +1426,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
rendered-text
actual-visibility
actual-sensitive
spoiler-text
actual-spoiler-text
reblogs-count
favourites-count
url

2
src/text-utils.lisp
View File

@ -100,7 +100,7 @@
(babel:string-to-octets s :errorp suppress-errors-p))
(defun clean-unprintable-chars (string)
(cl-ppcre:scan-to-strings "[\\p{Letter}\\p{Number}\\p{Punctuation}]+" string))
(cl-ppcre:regex-replace-all "\\p{C}" string ""))
(defun strcat (&rest chunks)
(declare (optimize (debug 0) (safety 0) (speed 3)))