diff --git a/src/db.lisp b/src/db.lisp index 2b38302..6331f0c 100644 --- a/src/db.lisp +++ b/src/db.lisp @@ -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 diff --git a/src/text-utils.lisp b/src/text-utils.lisp index 8970b22..681d4ac 100644 --- a/src/text-utils.lisp +++ b/src/text-utils.lisp @@ -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)))