mirror of https://codeberg.org/cage/tinmop/
3421 lines
145 KiB
Common Lisp
3421 lines
145 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/][http://www.gnu.org/licenses/]].
|
|
|
|
;; derived from
|
|
|
|
;; niccolo': a chemicals inventory
|
|
;; Copyright (C) 2016 Universita' degli Studi di Palermo
|
|
|
|
;; 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, 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 :db)
|
|
|
|
(define-constant +make-id-autoincrement+ " id INTEGER PRIMARY KEY AUTOINCREMENT, "
|
|
:test #'string=)
|
|
|
|
(define-constant +make-id+ " id INTEGER PRIMARY KEY, "
|
|
:test #'string=)
|
|
|
|
(define-constant +make-string-id+ " id TEXT PRIMARY KEY, "
|
|
:test #'string=)
|
|
|
|
(define-constant +other-id+ :other-id
|
|
:test #'eq)
|
|
|
|
(define-constant +make-open+ " ( "
|
|
:test #'string=)
|
|
|
|
(define-constant +make-close+ " ) "
|
|
:test #'string=)
|
|
|
|
(define-constant +restrict+ " RESTRICT "
|
|
:test #'string=)
|
|
|
|
(define-constant +cascade+ " CASCADE "
|
|
:test #'string=)
|
|
|
|
(define-constant +col-sep+ " , "
|
|
:test #'string=)
|
|
|
|
(define-constant +db-true+ 1
|
|
:test #'eq)
|
|
|
|
(define-constant +db-false+ 0
|
|
:test #'eq)
|
|
|
|
(define-constant +table-cache+ :cache
|
|
:test #'eq)
|
|
|
|
(define-constant +table-status+ :status
|
|
:test #'eq)
|
|
|
|
(define-constant +table-crypto-data+ :crypto
|
|
:test #'eq)
|
|
|
|
(define-constant +table-account+ :account
|
|
:test #'eq)
|
|
|
|
(define-constant +table-poll-option+ :poll-option
|
|
:test #'eq)
|
|
|
|
(define-constant +table-poll+ :poll
|
|
:test #'eq)
|
|
|
|
(define-constant +table-attachment+ :attachment
|
|
:test #'eq)
|
|
|
|
(define-constant +table-input-history+ :input-history
|
|
:test #'eq)
|
|
|
|
(define-constant +table-ignored-status+ :ignored-status
|
|
:test #'eq)
|
|
|
|
(define-constant +table-skipped-status+ :skipped-status
|
|
:test #'eq)
|
|
|
|
(define-constant +table-pagination-status+ :pagination-status
|
|
:test #'eq)
|
|
|
|
(define-constant +table-followed-user+ :followed-user
|
|
:test #'eq)
|
|
|
|
(define-constant +table-subscribed-tag+ :subscribed-tag
|
|
:test #'eq)
|
|
|
|
(define-constant +table-tag-histogram+ :tag-histogram
|
|
:test #'eq)
|
|
|
|
(define-constant +table-conversation+ :conversation
|
|
:test #'eq)
|
|
|
|
(define-constant +table-chat+ :chat
|
|
:test #'eq)
|
|
|
|
(define-constant +table-chat-message+ :chat-message
|
|
:test #'eq)
|
|
|
|
(define-constant +table-gemini-tofu-cert+ :gemini-tofu-cert
|
|
:test #'eq)
|
|
|
|
(define-constant +table-gemini-subscription+ :gemini-subscription
|
|
:test #'eq)
|
|
|
|
(define-constant +table-gemlog-entries+ :gemlog-entries
|
|
:test #'eq)
|
|
|
|
(define-constant +table-bookmark+ :bookmark
|
|
:test #'eq)
|
|
|
|
(define-constant +table-gempub-metadata+ :gempub-metadata
|
|
:test #'eq)
|
|
|
|
(define-constant +table-titan-token+ :titan-token
|
|
:test #'eq)
|
|
|
|
(define-constant +bookmark-gemini-type-entry+ "gemini"
|
|
:test #'string=)
|
|
|
|
(define-constant +federated-timeline+ "federated"
|
|
:test #'string=)
|
|
|
|
(define-constant +local-timeline+ "local"
|
|
:test #'string=)
|
|
|
|
(define-constant +home-timeline+ "home"
|
|
:test #'string=)
|
|
|
|
(define-constant +direct-timeline+ "direct"
|
|
:test #'string=)
|
|
|
|
(define-constant +default-status-folder+ "default"
|
|
:test #'string=)
|
|
|
|
(define-constant +mentions-status-folder+ "mentions"
|
|
:test #'string=)
|
|
|
|
(define-constant +default-tag-timeline+ +federated-timeline+
|
|
:test #'string=)
|
|
|
|
(define-constant +default-converation-timeline+ +federated-timeline+
|
|
:test #'string=)
|
|
|
|
(define-constant +hidden-recipient-prefix+ #\.
|
|
:test #'char=)
|
|
|
|
(define-constant +default-reblogged-timeline+ ".reblogged"
|
|
:test #'string=)
|
|
|
|
(define-constant +default-reblogged-folder+ +default-status-folder+
|
|
:test #'string=)
|
|
|
|
|
|
(define-constant +message-index-start+ 1
|
|
:test #'=)
|
|
|
|
(define-constant +tag-separator+ ","
|
|
:test #'string=)
|
|
|
|
(defun default-timelines ()
|
|
(list +home-timeline+
|
|
+local-timeline+
|
|
+federated-timeline+))
|
|
|
|
(defgeneric hidden-recipient-p (object))
|
|
|
|
(defmethod hidden-recipient-p ((object string))
|
|
(char= +hidden-recipient-prefix+
|
|
(first-elt object)))
|
|
|
|
(defun message-index->sequence-index (message-index)
|
|
(- message-index +message-index-start+))
|
|
|
|
(defmacro gen-timeline-const->description (timeline-const-sym description)
|
|
(let* ((const-name (symbol-name timeline-const-sym))
|
|
(fn-prefix (subseq const-name 1 (1- (length const-name))))
|
|
(fn-name (misc:format-fn-symbol t "~a->description" fn-prefix)))
|
|
`(defun ,fn-name ()
|
|
,description)))
|
|
|
|
(gen-timeline-const->description +federated-timeline+ (_ "federated"))
|
|
|
|
(gen-timeline-const->description +local-timeline+ (_ "local"))
|
|
|
|
(gen-timeline-const->description +direct-timeline+ (_ "direct"))
|
|
|
|
(gen-timeline-const->description +home-timeline+ (_ "home"))
|
|
|
|
(defun timeline-type->description (key)
|
|
(cond
|
|
((string= key +federated-timeline+)
|
|
(federated-timeline->description))
|
|
((string= key +local-timeline+)
|
|
(local-timeline->description))
|
|
((string= key +direct-timeline+)
|
|
(direct-timeline->description))
|
|
((string= key +home-timeline+)
|
|
(home-timeline->description))
|
|
(t
|
|
key)))
|
|
|
|
(defun create-table-index (table-name &optional (columns '(:id)))
|
|
(labels ((%replace (s chars)
|
|
(if (null chars)
|
|
s
|
|
(%replace (regex-replace-all (string (first chars)) s "_")
|
|
(rest chars)))))
|
|
(let ((actual-table-name (if (symbolp table-name)
|
|
(symbol-name table-name)
|
|
(string-downcase table-name))))
|
|
(query-low-level (format nil
|
|
"CREATE UNIQUE INDEX IF NOT EXISTS index_~a on ~a (~{~a~^, ~})"
|
|
(%replace actual-table-name +characters-trouble-name+)
|
|
(quote-symbol table-name)
|
|
(mapcar #'quote-symbol columns))))))
|
|
|
|
(defun delete-table (table-name)
|
|
(query-low-level (format nil "DROP TABLE IF EXISTS ~a" (quote-symbol table-name))))
|
|
|
|
(defun delete-view (view-name)
|
|
(query-low-level (format nil "DROP VIEW ~a" (quote-symbol view-name))))
|
|
|
|
(defun prepare-table (name &key
|
|
(autogenerated-id-p t)
|
|
(integer-id-p nil)
|
|
(autoincrementp nil))
|
|
(let ((id-section (when autogenerated-id-p
|
|
(if (or autoincrementp
|
|
integer-id-p)
|
|
(if autoincrementp
|
|
+make-id-autoincrement+
|
|
+make-id+)
|
|
+make-string-id+))))
|
|
(strcat "create table "
|
|
(quote-symbol name)
|
|
+make-open+
|
|
id-section)))
|
|
|
|
(defun make-foreign (table column on-delete on-update &optional (add-comma nil))
|
|
(format nil
|
|
" REFERENCES ~a (~a) ON DELETE ~a ON UPDATE ~a ~:[ ~;,~]"
|
|
(quote-symbol table) (quote-symbol column) on-delete on-update add-comma))
|
|
|
|
(defun make-bookmark ()
|
|
(query-low-level (strcat (prepare-table +table-bookmark+
|
|
:autogenerated-id-p t
|
|
:autoincrementp t)
|
|
"type TEXT NOT NULL,"
|
|
"value TEXT NOT NULL,"
|
|
"section TEXT,"
|
|
"description TEXT,"
|
|
;; timestamp
|
|
" \"created-at\" TEXT NOT NULL"
|
|
+make-close+)))
|
|
|
|
(defun make-cache ()
|
|
(query-low-level (strcat (prepare-table +table-cache+
|
|
:autogenerated-id-p t
|
|
:autoincrementp t)
|
|
"key TEXT NOT NULL,"
|
|
"type TEXT NOT NULL,"
|
|
;; timestamp
|
|
" \"created-at\" TEXT NOT NULL,"
|
|
;; timestamp
|
|
" \"accessed-at\" TEXT NOT NULL,"
|
|
" UNIQUE(key) ON CONFLICT FAIL"
|
|
+make-close+)))
|
|
|
|
(defun make-attachment ()
|
|
(query-low-level (strcat (prepare-table +table-attachment+ :autogenerated-id-p nil)
|
|
" id TEXT NOT NULL,"
|
|
;; one of swconf:*allowed-attachment-type*
|
|
" type TEXT NOT NULL,"
|
|
" url TEXT NOT NULL,"
|
|
" \"preview-url\" TEXT,"
|
|
" \"remote-url\" TEXT,"
|
|
;; url shortened
|
|
" \"text-url\" TEXT,"
|
|
;; metadata only for original attachment
|
|
" width TEXT,"
|
|
" height TEXT,"
|
|
" \"frame-rate\" TEXT,"
|
|
" duration TEXT,"
|
|
" bitrate TEXT,"
|
|
" description TEXT,"
|
|
" blurhash TEXT,"
|
|
" \"attached-to-id\" TEXT"
|
|
+make-close+)))
|
|
|
|
(defun make-chat ()
|
|
(query-low-level (strcat (prepare-table +table-chat+ :autogenerated-id-p nil)
|
|
"id TEXT NOT NULL,"
|
|
;; timestamp
|
|
" \"updated-at\" TEXT NOT NULL,"
|
|
;; timestamp
|
|
" \"created-at\" TEXT NOT NULL,"
|
|
" \"unread-count\" INTEGER DEFAULT 0,"
|
|
" label TEXT DEFAULT \"-\" ,"
|
|
;; boolean
|
|
" ignoredp INTEGER DEFAULT 0,"
|
|
|
|
" \"account-id\" TEXT NOT NULL"
|
|
(make-foreign +table-account+ "id" +cascade+ +cascade+)
|
|
+make-close+)))
|
|
|
|
(defun make-chat-message ()
|
|
(query-low-level (strcat (prepare-table +table-chat-message+ :autogenerated-id-p nil)
|
|
"id TEXT NOT NULL,"
|
|
;; boolean
|
|
" unreadp INTEGER DEFAULT 1,"
|
|
" content TEXT,"
|
|
" \"chat-id\" TEXT, "
|
|
;; timestamp
|
|
" \"updated-at\" TEXT,"
|
|
;; timestamp
|
|
" \"created-at\" TEXT NOT NULL,"
|
|
" \"attachment-id\" TEXT,"
|
|
" \"account-id\" TEXT NOT NULL"
|
|
(make-foreign +table-account+ "id" +cascade+ +cascade+)
|
|
+make-close+)))
|
|
|
|
(defun make-conversation ()
|
|
(query-low-level (strcat (prepare-table +table-conversation+)
|
|
" folder TEXT, "
|
|
" \"root-status-id\" TEXT, "
|
|
;; boolean
|
|
" ignoredp INTEGER DEFAULT 0,"
|
|
;; timestamp
|
|
" \"created-at\" TEXT NOT NULL,"
|
|
" UNIQUE(folder) ON CONFLICT FAIL"
|
|
+make-close+)))
|
|
|
|
(defun make-input-history ()
|
|
(query-low-level (strcat (prepare-table +table-input-history+ :autoincrementp t)
|
|
" prompt TEXT NOT NULL" +col-sep+
|
|
" input TEXT NOT NULL" +col-sep+
|
|
" \"date-added\" TEXT NOT NULL"
|
|
+make-close+)))
|
|
|
|
(defun make-crypto-data ()
|
|
"The data all base64 encoded"
|
|
(query-low-level (strcat (prepare-table +table-crypto-data+ :autoincrementp t)
|
|
;; the key
|
|
" key TEXT NOT NULL"
|
|
+make-close+)))
|
|
|
|
(defun make-account ()
|
|
(query-low-level (strcat (prepare-table +table-account+)
|
|
" username TEXT NOT NULL,"
|
|
;; this is the actual user identification
|
|
" acct TEXT NOT NULL,"
|
|
;; profile homepage
|
|
" url TEXT NOT NULL,"
|
|
" \"display-name\" TEXT NOT NULL,"
|
|
;; bio
|
|
" note TEXT NOT NULL,"
|
|
;; url
|
|
" avatar TEXT NOT NULL,"
|
|
;; the same as avatar if avatar is *not* an animated gif
|
|
" \"avatar-static\" TEXT NOT NULL,"
|
|
;; url of banner profile
|
|
" header TEXT NOT NULL,"
|
|
;; the same as header if header is *not* an animated gif
|
|
" \"header-static\" TEXT NOT NULL,"
|
|
;; boolean
|
|
" discoverable integer default 0,"
|
|
;; boolean
|
|
" locked integer default 0,"
|
|
;; timestamp
|
|
" \"created-at\" TEXT NOT NULL,"
|
|
" \"statuses-count\" INTEGER NOT NULL,"
|
|
" \"followers-count\" INTEGER NOT NULL,"
|
|
" \"following-count\" INTEGER NOT NULL,"
|
|
" \"moved-id\" TEXT ,"
|
|
;; boolean
|
|
" botp integer default 0,"
|
|
;; local value
|
|
" \"encryption-key-id\" INTEGER "
|
|
(make-foreign +table-crypto-data+ "id" +cascade+ +cascade+) +col-sep+
|
|
;; boolean
|
|
" ignoredp INTEGER default 0, "
|
|
" 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 "
|
|
(make-foreign +table-account+ "id" +cascade+ +cascade+) +col-sep+
|
|
;; timestamp
|
|
" \"created-at\" TEXT NOT NULL"
|
|
+make-close+)))
|
|
|
|
(defun make-poll-option ()
|
|
(query-low-level (strcat (prepare-table +table-poll-option+
|
|
:autogenerated-id-p t
|
|
:autoincrementp t)
|
|
" \"poll-id\" TEXT NOT NULL "
|
|
(make-foreign +table-poll+ "id" +cascade+ +cascade+) +col-sep+
|
|
" title TEXT, "
|
|
" \"votes-count\" INTEGER DEFAULT 0"
|
|
+make-close+)))
|
|
|
|
(defun make-poll ()
|
|
(query-low-level (strcat (prepare-table +table-poll+ :autogenerated-id-p t)
|
|
" \"status-id\" TEXT NOT NULL "
|
|
;(make-foreign +table-status+ "status-id" +cascade+ +cascade+)
|
|
+col-sep+
|
|
;; date
|
|
" \"expire-date\" TEXT NOT NULL,"
|
|
;; boolean
|
|
" expired INTEGER DEFAULT 0 ,"
|
|
;; boolean
|
|
" multiple INTEGER DEFAULT 0 ,"
|
|
" \"voters-count\" INTEGER DEFAULT 0 ,"
|
|
" \"votes-count\" INTEGER DEFAULT 0 ,"
|
|
;; boolean
|
|
" \"voted\" INTEGER DEFAULT 0 ,"
|
|
;; comma separated values
|
|
" \"own-votes\" TEXT "
|
|
+make-close+)))
|
|
|
|
(defun make-status ()
|
|
(query-low-level (strcat (prepare-table +table-status+ :autogenerated-id-p nil)
|
|
" \"status-id\" TEXT NOT NULL, "
|
|
" \"account-id\" TEXT NOT NULL "
|
|
(make-foreign +table-account+ "id" +cascade+ +cascade+) +col-sep+
|
|
" uri TEXT NOT NULL,"
|
|
;; timestamp
|
|
" \"created-at\" TEXT NOT NULL,"
|
|
;; actual message (In HTML)
|
|
" content TEXT NOT NULL,"
|
|
;; output message to display when redraft,
|
|
;; probably useless to us
|
|
" text TEXT ,"
|
|
;; actual message to display in tinmop, used also for searching
|
|
" \"rendered-text\" TEXT ,"
|
|
;; one of swconf:*allowed-status-visibility*
|
|
" \"visibility\" TEXT NOT NULL,"
|
|
;; boolean,
|
|
" sensitive integer default 0 ,"
|
|
;; can value "" (empty string) but if not can be used as message subject?
|
|
" \"spoiler-text\" TEXT ,"
|
|
" \"reblogs-count\" INTEGER default 0,"
|
|
" \"favourites-count\" INTEGER default 0,"
|
|
" \"replies-count\" INTEGER default 0,"
|
|
;; nullables
|
|
" url TEXT,"
|
|
" \"in-reply-to-id\" TEXT,"
|
|
" \"in-reply-to-account-id\" TEXT,"
|
|
;; boosted
|
|
" \"reblog-id\" TEXT, "
|
|
;; two letter iso code (it, en etc.)
|
|
" language TEXT,"
|
|
;; user action on this status
|
|
;; boolean
|
|
" favourited integer default 0,"
|
|
;; boosted, boolean
|
|
" reblogged integer default 0,"
|
|
;; boolean
|
|
" muted integer default 0,"
|
|
;; boolean
|
|
" bookmarked integer default 0,"
|
|
;; boolean
|
|
" pinned TEXT,"
|
|
;; comma separated values
|
|
" tags TEXT, "
|
|
" application TEXT, "
|
|
;; local value
|
|
;; has been red? boolean
|
|
" redp INTEGER DEFAULT 0, "
|
|
;; has the user marked this status for deletion? boolean
|
|
" deletedp INTEGER DEFAULT 0, "
|
|
;; with timeline this status belong to
|
|
;; must be one of:
|
|
;; +federated-timeline+
|
|
;; +local-timeline+
|
|
;; +direct-timeline+
|
|
" timeline TEXT NOT NULL, "
|
|
" folder TEXT NOT NULL DEFAULT \"" +default-status-folder+ "\"" +col-sep+
|
|
;; used in thread window to address the message in a
|
|
;; comfortable way for humans :)
|
|
" \"message-index\" INTEGER DEFAULT 1, "
|
|
" UNIQUE (folder, timeline, \"status-id\") ON CONFLICT FAIL"
|
|
+make-close+)))
|
|
|
|
(defun make-subscribed-tag ()
|
|
(query-low-level (strcat (prepare-table +table-subscribed-tag+)
|
|
" \"last-status-id-fetched\" TEXT, "
|
|
;; boolean
|
|
" \"got-new-message-p\" INTEGER DEFAULT 0, "
|
|
;; timestamp
|
|
" \"created-at\" TEXT NOT NULL"
|
|
+make-close+)))
|
|
|
|
(defun make-tag-histogram ()
|
|
(query-low-level (strcat (prepare-table +table-tag-histogram+
|
|
:integer-id-p t
|
|
:autoincrementp t)
|
|
" \"tag\" TEXT NOT NULL, "
|
|
" \"count\" INTEGER DEFAULT 0, "
|
|
;; date
|
|
" \"day\" TEXT NOT NULL"
|
|
+make-close+)))
|
|
|
|
(defun make-ignored-status ()
|
|
(query-low-level (strcat (prepare-table +table-ignored-status+ :autoincrementp t)
|
|
" \"status-id\" TEXT NOT NULL, "
|
|
" timeline TEXT NOT NULL, "
|
|
" folder TEXT NOT NULL, "
|
|
;; timestamp
|
|
" \"created-at\" TEXT NOT NULL"
|
|
+make-close+)))
|
|
|
|
(defun make-skipped-status ()
|
|
(query-low-level (strcat (prepare-table +table-skipped-status+ :autoincrementp t)
|
|
" \"status-id\" TEXT NOT NULL, "
|
|
" timeline TEXT NOT NULL, "
|
|
" folder TEXT NOT NULL, "
|
|
;; timestamp
|
|
" \"created-at\" TEXT NOT NULL"
|
|
+make-close+)))
|
|
|
|
(defun make-pagination-status ()
|
|
(query-low-level (strcat (prepare-table +table-pagination-status+ :autoincrementp t)
|
|
" \"status-id\" TEXT NOT NULL, "
|
|
" timeline TEXT NOT NULL, "
|
|
" folder TEXT NOT NULL "
|
|
+make-close+)))
|
|
|
|
(defun make-tofu-certs ()
|
|
(query-low-level (strcat (prepare-table +table-gemini-tofu-cert+ :autoincrementp t)
|
|
" host TEXT NOT NULL, "
|
|
" hash TEXT NOT NULL, "
|
|
;; timestamp
|
|
" \"seen-at\" TEXT NOT NULL,"
|
|
" UNIQUE(host) ON CONFLICT FAIL"
|
|
+make-close+)))
|
|
|
|
(defun make-gemini-subscription ()
|
|
(query-low-level (strcat (prepare-table +table-gemini-subscription+
|
|
:autoincrementp nil
|
|
:autogenerated-id-p nil)
|
|
" url TEXT PRIMARY KEY, "
|
|
" title TEXT, "
|
|
" subtitle TEXT "
|
|
+make-close+)))
|
|
|
|
(defun make-gemlog-entries ()
|
|
(query-low-level (strcat (prepare-table +table-gemlog-entries+
|
|
:autoincrementp nil
|
|
:autogenerated-id-p nil)
|
|
" url TEXT PRIMARY KEY, "
|
|
" \"gemlog-id\" TEXT NON NULL "
|
|
(make-foreign +table-gemini-subscription+
|
|
:url
|
|
+cascade+
|
|
+cascade+
|
|
t)
|
|
;; timestamp
|
|
" date TEXT NOT NULL, "
|
|
" title TEXT, "
|
|
" snippet TEXT, "
|
|
;; boolean
|
|
" seenp INTEGER DEFAULT 0, "
|
|
" deletedp INTEGER DEFAULT 0, "
|
|
" UNIQUE(url) ON CONFLICT FAIL"
|
|
+make-close+)))
|
|
|
|
(defun make-gempub-metadata ()
|
|
(query-low-level (strcat (prepare-table +table-gempub-metadata+ :autoincrementp t)
|
|
" \"local-uri\" TEXT, "
|
|
" \"original-uri\" TEXT, "
|
|
" title TEXT, "
|
|
" \"gpub-version\" TEXT, "
|
|
" \"index-file\" TEXT, "
|
|
" author TEXT, "
|
|
" language TEXT, "
|
|
" charset TEXT, "
|
|
" description TEXT, "
|
|
" published TEXT, "
|
|
" \"publish-date\" TEXT, "
|
|
" \"revision-date\" TEXT, "
|
|
" copyright TEXT, "
|
|
" license TEXT, "
|
|
" version TEXT, "
|
|
" cover TEXT, "
|
|
;; timestamp
|
|
" \"created-at\" TEXT NOT NULL"
|
|
+make-close+)))
|
|
|
|
(defun make-titan-token ()
|
|
(query-low-level (strcat (prepare-table +table-titan-token+
|
|
:autogenerated-id-p t
|
|
:autoincrementp t)
|
|
"url TEXT NOT NULL,"
|
|
"token TEXT NOT NULL,"
|
|
"UNIQUE(url) ON CONFLICT FAIL"
|
|
+make-close+)))
|
|
|
|
(defun build-all-indices ()
|
|
(create-table-index +table-status+ '(:folder :timeline :status-id))
|
|
(create-table-index +table-account+ '(:id :acct))
|
|
(create-table-index +table-followed-user+ '(:user-id))
|
|
(create-table-index +table-subscribed-tag+ '(:id))
|
|
(create-table-index +table-ignored-status+ '(:folder :timeline :status-id))
|
|
(create-table-index +table-skipped-status+ '(:folder :timeline :status-id))
|
|
(create-table-index +table-pagination-status+ '(:folder :timeline :status-id))
|
|
(create-table-index +table-conversation+ '(:id))
|
|
(create-table-index +table-cache+ '(:id :key))
|
|
(create-table-index +table-gemini-tofu-cert+ '(:host))
|
|
(create-table-index +table-gemini-subscription+ '(:url))
|
|
(create-table-index +table-gemlog-entries+ '(:url))
|
|
(create-table-index +table-bookmark+ '(:type :section :value))
|
|
(create-table-index +table-gempub-metadata+ '(:local-uri))
|
|
(create-table-index +table-titan-token+ '(:url)))
|
|
|
|
(defmacro gen-delete (suffix &rest names)
|
|
`(progn
|
|
,@(loop for name in names collect
|
|
`(,(misc:format-fn-symbol t "delete-~a" suffix) ,name))))
|
|
|
|
(defun delete-all-tables ()
|
|
(gen-delete table
|
|
+table-cache+
|
|
+table-input-history+
|
|
+table-status+
|
|
+table-account+
|
|
+table-followed-user+
|
|
+table-subscribed-tag+
|
|
+table-tag-histogram+
|
|
+table-attachment+
|
|
+table-conversation+
|
|
+table-pagination-status+
|
|
+table-ignored-status+
|
|
+table-skipped-status+
|
|
+table-poll-option+
|
|
+table-poll+
|
|
+table-chat-message+
|
|
+table-chat+
|
|
+table-gemini-tofu-cert+
|
|
+table-gemini-subscription+
|
|
+table-gemlog-entries+
|
|
+table-bookmark+
|
|
+table-gempub-metadata+
|
|
+table-titan-token+))
|
|
|
|
(defun build-views ())
|
|
|
|
(defun delete-all-views ())
|
|
|
|
(defun delete-database ()
|
|
(with-disabled-foreign
|
|
(delete-all-views)
|
|
(delete-all-tables)))
|
|
|
|
(defun maybe-build-all-tables ()
|
|
(when (= (fs:file-size (db-path))
|
|
0)
|
|
(make-cache)
|
|
(make-input-history)
|
|
(make-crypto-data)
|
|
(make-account)
|
|
(make-followed-user)
|
|
(make-status)
|
|
(make-ignored-status)
|
|
(make-skipped-status)
|
|
(make-attachment)
|
|
(make-subscribed-tag)
|
|
(make-tag-histogram)
|
|
(make-conversation)
|
|
(make-pagination-status)
|
|
(make-poll-option)
|
|
(make-poll)
|
|
(make-chat-message)
|
|
(make-chat)
|
|
(make-tofu-certs)
|
|
(make-gemini-subscription)
|
|
(make-gemlog-entries)
|
|
(make-bookmark)
|
|
(make-gempub-metadata)
|
|
(make-titan-token)
|
|
(build-all-indices)
|
|
(fs:set-file-permissions (db-path) (logior fs:+s-irusr+ fs:+s-iwusr+))))
|
|
|
|
;; specific utils
|
|
|
|
(defun table->alist (table col)
|
|
(let ((all (fetch-all (query (select (:id col)
|
|
(from table)
|
|
(order-by col))))))
|
|
(loop for i in all collect
|
|
(cons (getf i :id)
|
|
(getf i col)))))
|
|
|
|
(defgeneric fetch-single (query)
|
|
(:documentation "Fetch the first row from the results of exectuting `query'"))
|
|
|
|
(defmethod fetch-single (query)
|
|
(fetch (query query)))
|
|
|
|
(defmethod fetch-single ((query string))
|
|
(fetch (query-low-level query nil)))
|
|
|
|
(defgeneric fetch-all-rows (query)
|
|
(:documentation "Fetch all rows from the results of exectuting `sql'"))
|
|
|
|
(defmethod fetch-all-rows (sql)
|
|
(fetch-all (query sql)))
|
|
|
|
(defmethod fetch-all-rows ((sql string))
|
|
(fetch-all (query-low-level sql nil)))
|
|
|
|
(defun fetch-from-id (table id)
|
|
"Select a row from a `table' by column named `:id' with value `id'"
|
|
(fetch-single (select :*
|
|
(from table)
|
|
(where (:= :id id)))))
|
|
|
|
(defun create-view (name select-query)
|
|
(query-low-level (format nil "create view ~a as ~a"
|
|
(quote-symbol name)
|
|
(query->sql select-query))))
|
|
|
|
(defun delete-by-id (table id)
|
|
"Delete a row from a `table' by column named `:id' with value `id'"
|
|
(query (delete-from table (where (:= :id id)))))
|
|
|
|
(defun account-ignored-p (account-id)
|
|
"Returns non nil if this account has been setted as ignored by the user"
|
|
(let* ((db-account-row (fetch-from-id :account account-id))
|
|
(account-known-p db-account-row))
|
|
(and account-known-p
|
|
(db-getf db-account-row
|
|
:ignoredp
|
|
:default nil))))
|
|
|
|
(defun user-ignored-p (account-id)
|
|
"Returns non nil if this account must be ignored"
|
|
(or (db:account-ignored-p account-id)
|
|
(when-let ((ignore-regexps (swconf:ignore-users-regexps))
|
|
(username (db:user-id->username account-id)))
|
|
(loop for ignore-re in ignore-regexps do
|
|
(when (cl-ppcre:scan ignore-re username)
|
|
(return-from user-ignored-p t)))
|
|
nil)))
|
|
|
|
(defun boost-ignored-p (account-id)
|
|
"Returns non nil if this boost must be ignored"
|
|
(when-let ((ignore-regexps (swconf:ignore-users-boost-regexps))
|
|
(username (db:user-id->username account-id)))
|
|
(loop for ignore-re in ignore-regexps do
|
|
(when (cl-ppcre:scan ignore-re username)
|
|
(return-from boost-ignored-p t)))
|
|
nil))
|
|
|
|
(defun tags-ignored-p (tags)
|
|
"Returns non nil if theh tags of a status must be filtered out"
|
|
(when-let ((ignore-regexps (swconf:ignore-tag-regexps)))
|
|
(loop for ignore-re in ignore-regexps do
|
|
(when (cl-ppcre:scan ignore-re tags)
|
|
(return-from tags-ignored-p t)))
|
|
nil))
|
|
|
|
(defun acct->user (acct)
|
|
"Convert `acct' (acct is synonyym for username in mastodon account)
|
|
to the corresponding row in table +table-account+"
|
|
(fetch-single (select :*
|
|
(from :account)
|
|
(where (:= :acct acct)))))
|
|
|
|
(defun acct->id (acct)
|
|
"Convert `acct' (acct is synonyym for username in mastodon account)
|
|
to the corresponding id in table +table-account+"
|
|
(db-getf (acct->user acct) :id))
|
|
|
|
(defun username->id (unique-username)
|
|
(acct->id unique-username))
|
|
|
|
(defun user-exists-p (username)
|
|
(acct->user username))
|
|
|
|
(defun user-id->user (id)
|
|
(fetch-from-id :account id))
|
|
|
|
(defun user-id->username (user-id)
|
|
"username or acct are synonyms"
|
|
(when-let ((user (user-id->user user-id)))
|
|
(db-getf user :acct)))
|
|
|
|
(defun last-in-history (prompt)
|
|
(let* ((query (select (:*
|
|
(:as (fields (:max :id)) :max))
|
|
(from :input-history)
|
|
(where (:= :prompt prompt)))))
|
|
(fetch-single query)))
|
|
|
|
(defun insert-in-history (prompt input)
|
|
"insert an history entry with `prompt` and `input'"
|
|
(when (string-not-empty-p input)
|
|
(let* ((last-inserted (last-in-history prompt)))
|
|
(when (or (null last-inserted)
|
|
(not (string= input (getf last-inserted :input))))
|
|
(let* ((now (prepare-for-db (local-time-obj-now)))
|
|
(insert-query (make-insert :input-history
|
|
(:prompt :input :date-added)
|
|
(prompt input now))))
|
|
(query insert-query))))))
|
|
|
|
(defun next-in-history (min-id prompt)
|
|
"Return the history entry with prompt `prompt` and id that is greater
|
|
than `min-id'"
|
|
(let* ((query (select (:id
|
|
(:as (fields (:min :id)) :min)
|
|
:prompt
|
|
:input)
|
|
(from :input-history)
|
|
(where (:and (:> :id min-id)
|
|
(:= :prompt prompt)))))
|
|
(row (fetch-single query)))
|
|
(and (second row)
|
|
(values (getf row :min)
|
|
(getf row :input)))))
|
|
|
|
(defun previous-in-history (max-id prompt)
|
|
"Return the history entry with prompt `prompt` and id that is smaller
|
|
than `max-id'"
|
|
(let* ((query (select (:id
|
|
(:as (fields (:max :id)) :max)
|
|
:prompt
|
|
:input)
|
|
(from :input-history)
|
|
(where (:and (:< :id max-id)
|
|
(:= :prompt prompt)))))
|
|
(row (fetch-single query)))
|
|
(and (second row)
|
|
(values (getf row :max)
|
|
(getf row :input)))))
|
|
|
|
(defun most-recent-history-id (prompt)
|
|
"The most recent history entry with prompt `prompt'"
|
|
(let* ((query (select (fields (:max :id))
|
|
(from :input-history)
|
|
(where (:= :prompt prompt))))
|
|
(row (fetch-single query)))
|
|
(or (second row)
|
|
0)))
|
|
|
|
(defun threshold-time (days-in-the-past)
|
|
"Returns a time object `days-in-the-past' days in the past"
|
|
(local-time:adjust-timestamp (local-time-obj-now)
|
|
(offset :day (- (abs days-in-the-past)))))
|
|
|
|
(defun purge-history ()
|
|
"Remove expired entry in history.
|
|
|
|
An entry is expired if older
|
|
than (swconf:config-purge-history-days-offset) days in the past"
|
|
(let ((treshold (threshold-time (swconf:config-purge-history-days-offset))))
|
|
(query (make-delete +table-input-history+
|
|
(:< :date-added (prepare-for-db treshold))))))
|
|
|
|
(defun history-prompt->values (prompt)
|
|
(mapcar #'second
|
|
(query (select :input
|
|
(from +table-input-history+)
|
|
(where (:= :prompt prompt))
|
|
(order-by (:desc :id))))))
|
|
|
|
(defmethod prepare-for-db ((object tooter:application) &key &allow-other-keys)
|
|
(tooter:name object))
|
|
|
|
(defgeneric update-db (object &key &allow-other-keys)
|
|
(:documentation "Save object in database"))
|
|
|
|
(defmethod update-db ((object sequence) &key &allow-other-keys)
|
|
(map 'list #'update-db object))
|
|
|
|
(defmacro with-no-row-id ((table id) &body body)
|
|
"Execute `body' only if in table `table' an object with ID `id' does not exists"
|
|
`(when (null (fetch-from-id ,table ,id))
|
|
,@body))
|
|
|
|
(defmacro gen-insert-and-update-query ((insert-query-name
|
|
update-query-name
|
|
table
|
|
keys
|
|
values
|
|
&key (where nil))
|
|
&body body)
|
|
`(let ((,insert-query-name (make-insert ,table ,keys ,values))
|
|
(,update-query-name (make-update ,table ,keys ,values ,where)))
|
|
,@body))
|
|
|
|
(defgeneric metadata-width (object)
|
|
(:documentation "attachment metadata width"))
|
|
|
|
(defgeneric metadata-height (object)
|
|
(:documentation "attachment metadata height"))
|
|
|
|
(defgeneric metadata-frame-rate (object)
|
|
(:documentation "attachment metadata frame rate"))
|
|
|
|
(defgeneric metadata-duration (object)
|
|
(:documentation "attachment metadata duration"))
|
|
|
|
(defgeneric metadata-bitrate (object)
|
|
(:documentation "attachment metadata bitrate"))
|
|
|
|
(defgeneric metadata-original (object)
|
|
(:documentation "attachment metadata original metadata"))
|
|
|
|
(defmethod metadata-width ((object tooter:image-metadata))
|
|
(and object
|
|
(tooter:width object)))
|
|
|
|
(defmethod metadata-height ((object tooter:image-metadata))
|
|
(and object
|
|
(tooter:height object)))
|
|
|
|
(defmethod metadata-width ((object tooter:video-metadata))
|
|
(and object
|
|
(tooter:width object)))
|
|
|
|
(defmethod metadata-height ((object tooter:video-metadata))
|
|
(and object
|
|
(tooter:height object)))
|
|
|
|
(defmethod metadata-frame-rate (object)
|
|
(declare (ignore object))
|
|
nil)
|
|
|
|
(defmethod metadata-duration (object)
|
|
(declare (ignore object))
|
|
nil)
|
|
|
|
(defmethod metadata-bitrate (object)
|
|
(declare (ignore object))
|
|
nil)
|
|
|
|
(defmethod metadata-width (object)
|
|
(declare (ignore object))
|
|
nil)
|
|
|
|
(defmethod metadata-height (object)
|
|
(declare (ignore object))
|
|
nil)
|
|
|
|
(defmethod metadata-frame-rate ((object tooter:video-metadata))
|
|
(and object
|
|
(tooter:frame-rate object)))
|
|
|
|
(defmethod metadata-duration ((object tooter:video-metadata))
|
|
(and object
|
|
(tooter:duration object)))
|
|
|
|
(defmethod metadata-duration ((object tooter:audio-metadata))
|
|
(and object
|
|
(tooter:duration object)))
|
|
|
|
(defmethod metadata-bitrate ((object tooter:video-metadata))
|
|
(and object
|
|
(tooter:bitrate object)))
|
|
|
|
(defmethod metadata-bitrate ((object tooter:audio-metadata))
|
|
(and object
|
|
(tooter:audio-bitrate object)))
|
|
|
|
(defmethod metadata-original (object)
|
|
(and object
|
|
(tooter:original object)))
|
|
|
|
(defun find-poll-option (poll-id title)
|
|
(fetch-single (select :*
|
|
(from +table-poll-option+)
|
|
(where (:and (:= :title title)
|
|
(:= :poll-id poll-id))))))
|
|
|
|
(defun poll-option-exists-p (poll-id title)
|
|
(find-poll-option poll-id title))
|
|
|
|
(defun all-poll-options (poll-id)
|
|
(fetch-all-rows (select :*
|
|
(from +table-poll-option+)
|
|
(where (:= :poll-id poll-id)))))
|
|
|
|
(defun find-poll (poll-id)
|
|
(fetch-from-id +table-poll+ poll-id))
|
|
|
|
(defun find-poll-bound-to-status (status-id)
|
|
(fetch-single (select :*
|
|
(from +table-poll+)
|
|
(where (:= :status-id status-id)))))
|
|
|
|
(defun poll-bound-to-status-exists-p (status-id)
|
|
(find-poll-bound-to-status status-id))
|
|
|
|
(defmethod update-db ((object tooter:poll-option) &key (poll-id nil) &allow-other-keys)
|
|
(assert poll-id)
|
|
(with-accessors ((title tooter:title)
|
|
(votes-count tooter:votes-count)) object
|
|
(let ((insert-query (make-insert +table-poll-option+
|
|
(:title :votes-count :poll-id)
|
|
(title votes-count poll-id)))
|
|
(update-query (make-update +table-poll-option+
|
|
(:votes-count)
|
|
(votes-count)
|
|
(:and (:= :title title)
|
|
(:= :poll-id poll-id)))))
|
|
(if (poll-option-exists-p poll-id title)
|
|
(query update-query)
|
|
(query insert-query)))))
|
|
|
|
(defmethod update-db ((object tooter:poll) &key (status-id nil) &allow-other-keys)
|
|
(assert status-id)
|
|
(with-accessors ((id tooter:id)
|
|
(expires-at tooter:expires-at)
|
|
(expired tooter:expired)
|
|
(multiple tooter:multiple)
|
|
(voters-count tooter:voters-count)
|
|
(votes-count tooter:votes-count)
|
|
(voted tooter:voted)
|
|
(own-votes tooter:own-votes)
|
|
(options tooter:options)) object
|
|
(let* ((expire-date (decode-datetime-string expires-at))
|
|
(actual-expired (prepare-for-db expired :to-integer t))
|
|
(actual-multiple (prepare-for-db multiple :to-integer t))
|
|
(actual-voted (prepare-for-db voted :to-integer t))
|
|
(actual-own-votes (join-with-strings (if own-votes
|
|
(mapcar #'to-s own-votes)
|
|
"")
|
|
+tag-separator+))
|
|
(insert-query (make-insert +table-poll+
|
|
(:id
|
|
:status-id
|
|
:expire-date
|
|
:expired
|
|
:multiple
|
|
:voters-count
|
|
:votes-count
|
|
:voted
|
|
:own-votes)
|
|
(id
|
|
status-id
|
|
expire-date
|
|
actual-expired
|
|
actual-multiple
|
|
voters-count
|
|
votes-count
|
|
actual-voted
|
|
actual-own-votes)))
|
|
(update-query (make-update +table-poll+
|
|
(:id
|
|
:status-id
|
|
:expire-date
|
|
:expired
|
|
:multiple
|
|
:voters-count
|
|
:votes-count
|
|
:voted
|
|
:own-votes)
|
|
(id
|
|
status-id
|
|
expire-date
|
|
actual-expired
|
|
actual-multiple
|
|
voters-count
|
|
votes-count
|
|
actual-voted
|
|
actual-own-votes)
|
|
(:= :id id))))
|
|
(if (poll-bound-to-status-exists-p status-id)
|
|
(query update-query)
|
|
(query insert-query))
|
|
(loop for option in options do
|
|
(update-db option :poll-id id)))))
|
|
|
|
(defmethod update-db ((object tooter:attachment) &key (attached-to-id nil) &allow-other-keys)
|
|
(with-accessors ((id tooter:id)
|
|
(kind tooter:kind)
|
|
(url tooter:url)
|
|
(preview-url tooter:preview-url)
|
|
(remote-url tooter:remote-url)
|
|
(text-url tooter:text-url)
|
|
(metadata tooter:metadata)
|
|
(description tooter:description)
|
|
(blurhash tooter:blurhash)) object
|
|
(assert attached-to-id)
|
|
(let* ((actual-attachment-type (prepare-for-db kind))
|
|
(original-file-metadata (metadata-original metadata))
|
|
(width (prepare-for-db (metadata-width original-file-metadata)))
|
|
(height (prepare-for-db (metadata-height original-file-metadata)))
|
|
(frame-rate (prepare-for-db (metadata-frame-rate original-file-metadata)))
|
|
(duration (prepare-for-db (metadata-duration original-file-metadata)))
|
|
(bitrate (prepare-for-db (metadata-bitrate original-file-metadata)))
|
|
(insert-query (make-insert +table-attachment+
|
|
(:id
|
|
:type
|
|
:url
|
|
:preview-url
|
|
:remote-url
|
|
:text-url
|
|
:width
|
|
:height
|
|
:frame-rate
|
|
:duration
|
|
:bitrate
|
|
:description
|
|
:blurhash
|
|
:attached-to-id)
|
|
(id
|
|
actual-attachment-type
|
|
url
|
|
preview-url
|
|
remote-url
|
|
text-url
|
|
width
|
|
height
|
|
frame-rate
|
|
duration
|
|
bitrate
|
|
description
|
|
blurhash
|
|
attached-to-id)))
|
|
(attachment-exists-p (fetch-single (select :*
|
|
(from +table-attachment+)
|
|
(where (:and (:= :attached-to-id
|
|
attached-to-id)
|
|
(:= :id
|
|
id)))))))
|
|
(when (not attachment-exists-p)
|
|
(query insert-query)))))
|
|
|
|
(defmacro insert-or-update (table keys values)
|
|
"Anaphoric `id'"
|
|
(with-gensyms (insert-query update-query)
|
|
`(gen-insert-and-update-query (,insert-query
|
|
,update-query
|
|
,table
|
|
,keys
|
|
,values
|
|
:where (:= :id id))
|
|
(if (fetch-from-id ,table id)
|
|
(query ,update-query)
|
|
(query ,insert-query)))))
|
|
|
|
(defmethod update-db ((object tooter:account) &key &allow-other-keys)
|
|
(with-accessors ((id tooter:id)
|
|
(username tooter:username)
|
|
(account-name tooter:account-name)
|
|
(url tooter:url)
|
|
(display-name tooter:display-name)
|
|
(note tooter:note)
|
|
(avatar tooter:avatar)
|
|
(avatar-static tooter:avatar-static)
|
|
(header tooter:header)
|
|
(header-static tooter:header-static)
|
|
(locked tooter:locked)
|
|
(discoverable tooter:discoverable)
|
|
(created-at tooter:created-at)
|
|
(followers-count tooter:followers-count)
|
|
(following-count tooter:following-count)
|
|
(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))))))
|
|
|
|
(defmethod update-db ((object tooter:tag-history) &key (tag nil) &allow-other-keys)
|
|
(assert (stringp tag))
|
|
(with-accessors ((day tooter:day)
|
|
(use-count tooter:use-count)) object
|
|
(let* ((actual-day (decode-date-string day))
|
|
(entry-exists-p (query (select :*
|
|
(from +table-tag-histogram+)
|
|
(where (:and (:= :day actual-day)
|
|
(:= :tag tag))))))
|
|
(updatable-p (query (select :*
|
|
(from +table-tag-histogram+)
|
|
(where (:and (:= :day actual-day)
|
|
(:= :tag tag)
|
|
(:< :count use-count)))))))
|
|
(cond
|
|
((not entry-exists-p)
|
|
(query (make-insert +table-tag-histogram+
|
|
(:tag :day :count)
|
|
(tag actual-day use-count))))
|
|
(updatable-p
|
|
(query (make-update +table-tag-histogram+
|
|
(:count)
|
|
(use-count)
|
|
(:and (:= :day actual-day)
|
|
(:= :tag tag)))))))))
|
|
|
|
(defun concat-tags (status)
|
|
(with-accessors ((tags tooter:tags)) status
|
|
(if tags
|
|
(join-with-strings (mapcar #'client:tag-name tags)
|
|
+tag-separator+)
|
|
"")))
|
|
|
|
(defmethod update-db ((object tooter:status)
|
|
&key
|
|
(timeline +local-timeline+)
|
|
(folder +default-status-folder+)
|
|
(skip-ignored-p nil)
|
|
&allow-other-keys)
|
|
(with-accessors ((id tooter:id)
|
|
(uri tooter:uri)
|
|
(created-at tooter:created-at)
|
|
(content tooter:content)
|
|
(visibility tooter:visibility)
|
|
(sensitive tooter:sensitive)
|
|
(spoiler-text tooter:spoiler-text)
|
|
(reblogs-count tooter:reblogs-count)
|
|
(favourites-count tooter:favourites-count)
|
|
(url tooter:url)
|
|
(in-reply-to-id tooter:in-reply-to-id)
|
|
(in-reply-to-account-id tooter:in-reply-to-account-id)
|
|
(language tooter:language)
|
|
(favourited tooter:favourited)
|
|
(reblogged tooter:reblogged)
|
|
(parent tooter:parent)
|
|
(muted tooter:muted)
|
|
(pinned tooter:pinned)
|
|
(account tooter:account)
|
|
(tags tooter:tags)
|
|
(application tooter:application)
|
|
(media-attachments tooter:media-attachments)
|
|
(poll tooter:poll)) object
|
|
(update-db account)
|
|
(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)))
|
|
(when (not (and skip-ignored-p
|
|
(or status-ignored-p
|
|
account-ignored-p)))
|
|
(let ((insert-query (make-insert +table-status+
|
|
(:status-id
|
|
:account-id
|
|
:uri
|
|
:created-at
|
|
:content
|
|
:rendered-text
|
|
:visibility
|
|
:sensitive
|
|
:spoiler-text
|
|
:reblogs-count
|
|
:favourites-count
|
|
:url
|
|
:in-reply-to-id
|
|
:in-reply-to-account-id
|
|
:reblog-id
|
|
:language
|
|
:favourited
|
|
:reblogged
|
|
:muted
|
|
:pinned
|
|
:timeline
|
|
:tags
|
|
:application
|
|
:folder)
|
|
(id
|
|
account-id
|
|
uri
|
|
actual-created-at
|
|
content
|
|
rendered-text
|
|
actual-visibility
|
|
actual-sensitive
|
|
spoiler-text
|
|
reblogs-count
|
|
favourites-count
|
|
url
|
|
in-reply-to-id
|
|
in-reply-to-account-id
|
|
reblog-id
|
|
actual-language
|
|
actual-favourited
|
|
actual-reblogged
|
|
actual-muted
|
|
actual-pinned
|
|
timeline
|
|
actual-tags
|
|
actual-application
|
|
folder))))
|
|
(when (not (single-status-exists-p id timeline folder))
|
|
(query insert-query)
|
|
;; attachments, tag history latest because of the
|
|
;; reference from this table to table status
|
|
(map nil
|
|
(lambda (media-attachment)
|
|
(update-db media-attachment :attached-to-id id))
|
|
media-attachments)
|
|
(loop
|
|
for tag in tags
|
|
for tag-name in tag-names do
|
|
(let ((tag-history (api-client:make-placeholder-tag-histogram)))
|
|
(update-db tag-history :tag tag-name)))
|
|
(update-db parent
|
|
:skip-ignored-p skip-ignored-p
|
|
:timeline +default-reblogged-timeline+
|
|
:folder +default-reblogged-folder+)
|
|
;; now try to decrypt message if possible/needed
|
|
(maybe-decrypt-update-status-text id timeline folder)
|
|
(let ((db-status (find-status-id-folder-timeline id folder timeline)))
|
|
(hooks:run-hook-compose 'hooks:*after-saving-message* db-status)))
|
|
;; add poll or update poll's votes
|
|
(when poll
|
|
(update-db poll :status-id id)))))))
|
|
|
|
(defun find-chat (chat-id)
|
|
(fetch-single (select :*
|
|
(from +table-chat+)
|
|
(where (:= :id chat-id)))))
|
|
|
|
(defun chat-message-exists-p (chat-id message-id)
|
|
(query (select :*
|
|
(from +table-chat-message+)
|
|
(where (:and (:= :chat-id chat-id)
|
|
(:= :message-id message-id))))))
|
|
|
|
(defun mark-all-chat-messages-read (chat-id)
|
|
(query (make-update +table-chat-message+
|
|
(:unreadp)
|
|
(+db-false+)
|
|
(:= :chat-id chat-id))))
|
|
|
|
(defun count-unread-chat-messages (chat-id)
|
|
(second (fetch-single (select (fields (:count :id))
|
|
(from +table-chat-message+)
|
|
(where (:and (:= :chat-id chat-id)
|
|
(:= :unreadp +db-true+)))))))
|
|
|
|
(defmethod update-db ((object api-pleroma:chat-message) &key &allow-other-keys)
|
|
(with-accessors ((message-id api-pleroma:message-id)
|
|
(emojis api-pleroma:emojis)
|
|
(updated-at api-pleroma:updated-at)
|
|
(created-at api-pleroma:created-at)
|
|
(content api-pleroma:content)
|
|
(chat-id api-pleroma:chat-id)
|
|
(attachment api-pleroma:attachment)
|
|
(account-id api-pleroma:account-id)) object
|
|
(when (and (user-id->user account-id)
|
|
(not (chat-message-exists-p chat-id message-id)))
|
|
(update-db attachment :attached-to-id message-id)
|
|
(let ((attachment-id (and attachment
|
|
(tooter:id attachment)))
|
|
(actual-updated-at (decode-datetime-string updated-at))
|
|
(actual-created-at (decode-datetime-string created-at)))
|
|
(query (make-insert +table-chat-message+
|
|
(:id
|
|
:content
|
|
:chat-id
|
|
:attachment-id
|
|
:account-id
|
|
:updated-at
|
|
:created-at)
|
|
(message-id
|
|
content
|
|
chat-id
|
|
attachment-id
|
|
account-id
|
|
actual-updated-at
|
|
actual-created-at)))))))
|
|
|
|
(defun chat-change-label (chat-id label)
|
|
(assert (stringp chat-id))
|
|
(assert (stringp label))
|
|
(assert (chat-exists-p chat-id))
|
|
(query (make-update +table-chat+
|
|
(:label)
|
|
(label)
|
|
(:= :id chat-id))))
|
|
|
|
(defun chat-exists-p (chat-id)
|
|
(query (select :*
|
|
(from +table-chat+)
|
|
(where (:= :id chat-id)))))
|
|
|
|
(defun all-chats ()
|
|
"Return all chats ordered by most recent updated to last recent updated"
|
|
(query (select :*
|
|
(from +table-chat+)
|
|
(order-by (:desc :updated-at)))))
|
|
|
|
(defun all-chat-messages (chat-id)
|
|
"Return all messages belonging to `chat-id' ordered by `id'
|
|
in ascending order"
|
|
(query (select :*
|
|
(from +table-chat-message+)
|
|
(where (:= :chat-id chat-id))
|
|
(order-by (:asc :id)))))
|
|
|
|
(defun all-chat-links (chat-id)
|
|
"Return all links belonging to `chat-id' ordered by message `id'
|
|
in ascending order"
|
|
(let ((all (query (select ((:as :attachment.text-url :url))
|
|
(from :attachment)
|
|
(join :chat-message :on (:and (:= :chat-message.attachment-id
|
|
:attachment.id)
|
|
(:not-null :chat-message.attachment-id)))
|
|
(where (:= :chat-message.chat-id chat-id))
|
|
(order-by (:asc :chat-message.id))))))
|
|
(remove-duplicates (mapcar #'second all) :test #'string=)))
|
|
|
|
(defun last-chat-message-id (chat-id)
|
|
(second (fetch-single (select ((:as (fields (:max :id)) :max-id))
|
|
(from +table-chat-message+)
|
|
(where (:= :chat-id chat-id))))))
|
|
|
|
(defmethod update-db ((object api-pleroma:chat) &key &allow-other-keys)
|
|
(with-accessors ((chat-id api-pleroma:chat-id)
|
|
(updated-at api-pleroma:updated-at)
|
|
(created-at api-pleroma:created-at)
|
|
(account api-pleroma:account)) object
|
|
(when (not (chat-exists-p chat-id))
|
|
(let ((actual-updated-at (decode-datetime-string updated-at))
|
|
(actual-created-at (decode-datetime-string created-at)))
|
|
(update-db account)
|
|
(query (make-insert +table-chat+
|
|
(:id
|
|
:account-id
|
|
:updated-at
|
|
:created-at)
|
|
(chat-id
|
|
(tooter:id account)
|
|
actual-updated-at
|
|
actual-created-at)))))))
|
|
|
|
(defun maybe-decrypt-update-status-text (status-id timeline folder)
|
|
"Decrypt, if possible, status identified by `status-id', `timeline' and `folder'.
|
|
|
|
Update database with the decrypted text in column `rendered-text'"
|
|
(when-let* ((status (fetch-single (make-filtered-message-select nil
|
|
timeline
|
|
folder
|
|
nil
|
|
`(:= :status-id ,status-id))))
|
|
(raw-text (row-message-rendered-text status))
|
|
(decrypted (msg-utils:message-original->text-body status
|
|
:notify-cant-decrypt t
|
|
:try-decrypt t)))
|
|
(query (make-update +table-status+
|
|
(:rendered-text)
|
|
(decrypted)
|
|
(:and (:= :status-id status-id)
|
|
(:= :folder folder)
|
|
(:= :timeline timeline))))))
|
|
|
|
(defun message-root (timeline folder status-id)
|
|
"Return the root of the status identified by 'status-id'.
|
|
If 'status-id' does not belong to a reply return the status
|
|
identitfied by 'status-id'. If parent of status so identified is
|
|
not in the database return (values status :partial)"
|
|
(labels ((get-status (id)
|
|
(and id
|
|
(message-from-timeline-folder-id timeline folder id)))
|
|
(climb-tree (parent child reply-id)
|
|
(if (null parent)
|
|
(if reply-id
|
|
(values child :partial)
|
|
(values child nil))
|
|
(let* ((reply-id (getf parent :in-reply-to-id))
|
|
(grand-parent (get-status reply-id)))
|
|
(climb-tree grand-parent parent reply-id)))))
|
|
(climb-tree (get-status status-id) nil nil)))
|
|
|
|
(defun all-root-statuses (timeline-type &key (folder +default-status-folder+))
|
|
(assert folder)
|
|
(assert timeline-type)
|
|
(let* ((query-no-reply (select :*
|
|
(from :status)
|
|
(where (:and (:= :timeline timeline-type)
|
|
(:= :folder folder)
|
|
(:is-null :in-reply-to-id)))))
|
|
(query-with-reply (select :*
|
|
(from :status)
|
|
(where (:and (:= :timeline timeline-type)
|
|
(:= :folder folder)
|
|
(:not-null :in-reply-to-id)))))
|
|
(complete-tree (fetch-all-rows query-no-reply))
|
|
(orphan (remove-if (lambda (row)
|
|
(let ((id-reply (row-message-reply-to-id row))
|
|
(folder (row-message-folder row))
|
|
(timeline (row-message-timeline row)))
|
|
(message-from-timeline-folder-id timeline
|
|
folder
|
|
id-reply)))
|
|
(fetch-all-rows query-with-reply))))
|
|
(values (append complete-tree orphan)
|
|
complete-tree
|
|
orphan)))
|
|
|
|
(defun all-root-status-id (timeline-type
|
|
&key
|
|
(sort-fn nil)
|
|
(folder +default-status-folder+))
|
|
(let ((ids (mapcar #'second (all-root-statuses timeline-type :folder folder))))
|
|
(if sort-fn
|
|
(sort ids sort-fn)
|
|
ids)))
|
|
|
|
(defun message-from-timeline-folder-id (timeline folder status-id)
|
|
"Returns a message identified by `status-id', `timeline'
|
|
and`folder'. A `message' is a plist that contains all the informations
|
|
of a row of table +table-status+ and at least the columns :acct,
|
|
:display-name and :locked from +table-account+"
|
|
(fetch-single (make-filtered-message-select nil
|
|
nil
|
|
folder
|
|
nil
|
|
`(:and := :status.timeline ,timeline)
|
|
`(:and := :status.status-id ,status-id))))
|
|
|
|
(defun message-from-timeline-folder-message-index (timeline folder message-index)
|
|
"Returns a message identified by `status-id', `timeline'
|
|
and `message-index'. A `message' is a plist that contains all the informations
|
|
of a row of table +table-status+ and at least the columns :acct,
|
|
:display-name and :locked from +table-account+.
|
|
|
|
Message index is an unique number that identify the message after the
|
|
messages are sorted as below:
|
|
|
|
1. start with global message-index = 1
|
|
|
|
1. sort all the trees in a folder from the one with the older root to the newest
|
|
|
|
2. for each tree explore the messages starting from root
|
|
|
|
a. visit each node in the tree with a classic Depth First Search
|
|
and set the value index for that node as the value of message-index
|
|
|
|
b. increment message-index by 1
|
|
"
|
|
(let ((query (make-filtered-message-select nil
|
|
timeline
|
|
folder
|
|
nil
|
|
`(:= :status.message-index ,message-index))))
|
|
(fetch-single query)))
|
|
|
|
(defun message-index->tree (timeline folder message-index)
|
|
"Returns a tree of messages identified by `status-id', `timeline'
|
|
and `message-index'.
|
|
|
|
Message index is an unique number that identify the message."
|
|
(let ((message (message-from-timeline-folder-message-index timeline folder message-index)))
|
|
(assert message)
|
|
(let ((message-status-id (row-message-status-id message)))
|
|
(message-root->tree timeline
|
|
folder
|
|
(row-message-status-id (message-root timeline
|
|
folder
|
|
message-status-id))))))
|
|
|
|
(defun find-status-id (status-id)
|
|
"Find a status by id, notes that status id is not a unique
|
|
identifier despite the name."
|
|
(fetch-single (select :*
|
|
(from :status)
|
|
(where (:= :status-id status-id)))))
|
|
|
|
(defun find-message-id (status-id)
|
|
"Find a message (status with other columns like acct) by id, notes
|
|
that status id is not a unique identifier despite the name."
|
|
(fetch-single (make-filtered-message-select nil
|
|
nil
|
|
nil
|
|
nil
|
|
`(:= :status-id ,status-id))))
|
|
|
|
(defun find-status-id-folder-timeline (status-id folder timeline)
|
|
"Fetch a single message identified by `status-id', `folder' and `timeline'.
|
|
|
|
Note that the tuple (`status-id', `folder' and `timeline') is the only key
|
|
that identify a single message in table :status"
|
|
(fetch-single (select :* (from +table-status+)
|
|
(where (:and (:= :status-id status-id)
|
|
(:= :timeline timeline)
|
|
(:= :folder folder))))))
|
|
|
|
(defmacro gen-message-select ()
|
|
"Convenience macro for `make-filtered-message-select'"
|
|
(let ((select `(select (:status.*
|
|
(:as :account.acct :username)
|
|
(:as :account.display-name :display-name)
|
|
(:as :account.locked :locked))
|
|
(from :status)
|
|
(join :account :on (:= :account.id
|
|
:status.account-id)))))
|
|
select))
|
|
|
|
(defun make-filtered-message-select (other-columns
|
|
timeline
|
|
folder
|
|
account-id
|
|
&rest
|
|
where-clauses)
|
|
"Query the table status
|
|
|
|
- other-column fetch other column from table :status or :account (the
|
|
default columns are all the ones of table status and the columns
|
|
:acct, :display-name and :locked from +table-account+, use `nil' if
|
|
you are OK with the defaults
|
|
|
|
- timeline
|
|
folder
|
|
account-id
|
|
|
|
use nil if you do not want to filter with this additional criteria
|
|
|
|
- where-clause a number of sxql where clause for even more filtering. E.g:
|
|
|
|
`(:= :status.timeline ,timeline)
|
|
`(:= :in-reply-to-id ,status-id)
|
|
|
|
the two claususes will be connectd by :AND by default
|
|
|
|
`(:or :like :spoiler-text
|
|
,actual-text-looking-for)
|
|
`(:or :like :tags
|
|
,actual-text-looking-for)
|
|
`(:or :like :username
|
|
,actual-text-looking-for)
|
|
`(:and :> :status.message-index
|
|
,start-status-message-index)
|
|
|
|
note that the order matters in fact the following clauses
|
|
|
|
`(:and :> :status.message-index
|
|
,start-status-message-index)
|
|
`(:or :like :spoiler-text
|
|
,actual-text-looking-for)
|
|
`(:or :like :tags
|
|
,actual-text-looking-for)
|
|
`(:or :like :username
|
|
,actual-text-looking-for)
|
|
|
|
is not equivalent to the one below, the latter means
|
|
|
|
(:status.message-index > start-status-message-index) OR ...
|
|
|
|
and does not means:
|
|
|
|
(:status.message-index > start-status-message-index) AND ...
|
|
|
|
as was likely intended."
|
|
(let ((query (gen-message-select)))
|
|
(loop for other-column in other-columns do
|
|
(fields+ query other-column))
|
|
(loop for where-clause in where-clauses do
|
|
(cond
|
|
((eq (first where-clause)
|
|
:and)
|
|
(and-where query (rest where-clause)))
|
|
((eq (first where-clause)
|
|
:or)
|
|
(or-where query (rest where-clause)))
|
|
(t
|
|
(and-where query where-clause))))
|
|
(when folder
|
|
(and-where query `(:= :folder ,folder)))
|
|
(when timeline
|
|
(and-where query `(:= :timeline ,timeline)))
|
|
(when account-id
|
|
(and-where query `(:= :account-id ,account-id)))
|
|
query))
|
|
|
|
(defun single-status-exists-p (status-id timeline folder)
|
|
"Id timeline and folder is the tuple that is primary key for table
|
|
:status"
|
|
(find-status-id-folder-timeline status-id folder timeline))
|
|
|
|
(defun message-children (timeline folder status-id)
|
|
"Return the direct children of this status, nil if there are none"
|
|
(assert (stringp status-id))
|
|
(when-let* ((parent-status (message-from-timeline-folder-id timeline folder status-id))
|
|
(query (make-filtered-message-select nil
|
|
nil
|
|
folder
|
|
nil
|
|
`(:= :status.timeline ,timeline)
|
|
`(:= :in-reply-to-id ,status-id))))
|
|
(fetch-all-rows query)))
|
|
|
|
(defun all-messages-timeline-folder (timeline folder)
|
|
(fetch-all-rows (make-filtered-message-select nil
|
|
timeline
|
|
folder
|
|
nil)))
|
|
|
|
(defun message-id->tree (timeline folder status-id)
|
|
"Return an instance of `mtree-utils:m-tree' filled with status that
|
|
forms a messages thread identified by the arguments."
|
|
(message-root->tree timeline
|
|
folder
|
|
(row-message-status-id (message-root timeline folder status-id))))
|
|
|
|
(defun message-root->tree (timeline folder root-status-id)
|
|
"Return an instance of `mtree-utils:m-tree' filled with status that
|
|
forms a messages thread"
|
|
(assert folder)
|
|
(assert (stringp root-status-id))
|
|
(when-let* ((root-status (message-from-timeline-folder-id timeline folder root-status-id))
|
|
(results (mtree:make-node root-status)))
|
|
(labels ((add-children (node)
|
|
(let ((children (message-children timeline folder
|
|
(row-message-status-id (mtree:data node)))))
|
|
(loop for child in children do
|
|
(mtree:add-child node
|
|
(mtree:make-node child)))
|
|
(mtree:do-children (child node)
|
|
(add-children child))
|
|
node)))
|
|
(add-children results))))
|
|
|
|
(defun message->thread-users (timeline folder status-id
|
|
&key
|
|
(local-name-prefix "")
|
|
(acct-prefix ""))
|
|
"Given a tuple that identify a message (`timeline' `folder' `status-id'),
|
|
returns an alist of (local-username . acct) of all the ancestors of
|
|
the message identified by the tuple."
|
|
(let ((all-messages (mtree:collect-nodes-data (message-id->tree timeline folder status-id)))
|
|
(results ()))
|
|
(loop for message in all-messages do
|
|
(let* ((user-id (db-getf message :account-id))
|
|
(account (user-id->user user-id))
|
|
(local-name (db-getf account :username))
|
|
(username (user-id->username user-id))
|
|
(pair (cons (strcat local-name-prefix local-name)
|
|
(strcat acct-prefix username))))
|
|
(pushnew pair results :test (lambda (a b) (and (string= (car a)
|
|
(car b))
|
|
(string= (cdr a)
|
|
(cdr b)))))))
|
|
results))
|
|
|
|
(defun mention-local->global-alist ()
|
|
"Returns an alist of all known accounts as ('@'local-username . '@'acct)."
|
|
(let* ((query (select (:username :acct) (from +table-account+)))
|
|
(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))))))
|
|
|
|
(defmacro gen-access-message-row (name column
|
|
&key
|
|
(default nil)
|
|
(only-empty-or-0-are-null nil))
|
|
"Convenience macro to generate function to access a value of a table
|
|
row."
|
|
`(defun ,(misc:format-fn-symbol t "row-~a" name) (row)
|
|
(and row
|
|
(db-getf row
|
|
,column
|
|
:default ,default
|
|
:only-empty-or-0-are-null ,only-empty-or-0-are-null))))
|
|
|
|
(gen-access-message-row id :id)
|
|
|
|
(gen-access-message-row message-visibility :visibility)
|
|
|
|
(gen-access-message-row message-status-id :status-id)
|
|
|
|
(gen-access-message-row message-index :message-index)
|
|
|
|
(gen-access-message-row message-folder :folder)
|
|
|
|
(gen-access-message-row message-timeline :timeline)
|
|
|
|
(gen-access-message-row message-username :username)
|
|
|
|
(gen-access-message-row message-user-display-name :display-name)
|
|
|
|
(gen-access-message-row message-content :content)
|
|
|
|
(gen-access-message-row message-rendered-text :rendered-text)
|
|
|
|
(gen-access-message-row message-creation-time :created-at)
|
|
|
|
(gen-access-message-row language :language)
|
|
|
|
(gen-access-message-row message-reply-to-account-id :in-reply-to-account-id)
|
|
|
|
(gen-access-message-row message-subject :spoiler-text)
|
|
|
|
(gen-access-message-row message-tags :tags)
|
|
|
|
(gen-access-message-row message-reblog-id :reblog-id)
|
|
|
|
(gen-access-message-row lockedp :locked)
|
|
|
|
(gen-access-message-row message-redp :redp)
|
|
|
|
(gen-access-message-row user-username :acct)
|
|
|
|
(gen-access-message-row avatar :avatar)
|
|
|
|
(gen-access-message-row tag-got-new-message :got-new-message-p)
|
|
|
|
(gen-access-message-row conversation-folder :folder)
|
|
|
|
(gen-access-message-row conversation-ignored-p :ignoredp)
|
|
|
|
(gen-access-message-row conversation-root-status-id :root-status-id)
|
|
|
|
(gen-access-message-row poll-expired-p :expired)
|
|
|
|
(gen-access-message-row poll-multiple-vote-p :multiple)
|
|
|
|
(gen-access-message-row title :title :only-empty-or-0-are-null t)
|
|
|
|
(gen-access-message-row subtitle :subtitle :only-empty-or-0-are-null t)
|
|
|
|
(gen-access-message-row url :url)
|
|
|
|
(gen-access-message-row token :token)
|
|
|
|
(gen-access-message-row expire-date :expire-date)
|
|
|
|
(gen-access-message-row chat-id :chat-id)
|
|
|
|
(gen-access-message-row account-id :account-id)
|
|
|
|
(gen-access-message-row updated-at :updated-at)
|
|
|
|
(gen-access-message-row created-at :created-at)
|
|
|
|
(gen-access-message-row text-url :text-url)
|
|
|
|
(gen-access-message-row type :type)
|
|
|
|
(gen-access-message-row label :label)
|
|
|
|
(gen-access-message-row cache-key :key)
|
|
|
|
(gen-access-message-row cache-type :type)
|
|
|
|
(gen-access-message-row cache-accessed-at :accessed-at)
|
|
|
|
(gen-access-message-row cache-created-at :created-at)
|
|
|
|
(gen-access-message-row seenp :seenp)
|
|
|
|
(gen-access-message-row description :description)
|
|
|
|
(gen-access-message-row value :value)
|
|
|
|
(gen-access-message-row section :section)
|
|
|
|
(gen-access-message-row local-uri :local-uri)
|
|
|
|
(gen-access-message-row original-uri :original-uri)
|
|
|
|
(gen-access-message-row gpub-version :gpub-version)
|
|
|
|
(gen-access-message-row index-file :index-file)
|
|
|
|
(gen-access-message-row author :author)
|
|
|
|
(gen-access-message-row charset :charset)
|
|
|
|
(gen-access-message-row published :published)
|
|
|
|
(gen-access-message-row publish-date :publish-date)
|
|
|
|
(gen-access-message-row revision-date :revision-date)
|
|
|
|
(gen-access-message-row copyright :copyright)
|
|
|
|
(gen-access-message-row license :license)
|
|
|
|
(gen-access-message-row version :version)
|
|
|
|
(gen-access-message-row cover :cover)
|
|
|
|
(gen-access-message-row input :input)
|
|
|
|
(defun row-votes-count (row)
|
|
(and row (db-getf row :votes-count :default 0)))
|
|
|
|
(defun row-message-reply-to-id (row)
|
|
(and row
|
|
(db-getf row :in-reply-to-id)))
|
|
|
|
(defun tree-data-id (tree-node)
|
|
"Return the `data' slot of node `tree-node'. the argument is an
|
|
instance of `mtree-utils:m-tree'"
|
|
(row-message-status-id (mtree:data tree-node)))
|
|
|
|
(defun neighbor-tree (tree timeline-type &key (folder +default-status-folder+))
|
|
"Unused"
|
|
(when-let* ((all-roots-id (all-root-status-id timeline-type
|
|
:sort-fn #'string<
|
|
:folder folder))
|
|
(needle-root (mtree:root-node tree))
|
|
(needle-id (tree-data-id needle-root))
|
|
(needle-pos (position needle-id all-roots-id :test #'string=)))
|
|
(flet ((neighbor-ids ()
|
|
(cond
|
|
((= needle-pos 0)
|
|
(values nil (elt all-roots-id (1+ needle-pos))))
|
|
((= needle-pos (1- (length all-roots-id)))
|
|
(values (elt all-roots-id (1- needle-pos))
|
|
nil))
|
|
(t
|
|
(values (elt all-roots-id (1- needle-pos))
|
|
(elt all-roots-id (1+ needle-pos)))))))
|
|
(multiple-value-bind (previous-id next-id)
|
|
(neighbor-ids)
|
|
(values (and previous-id
|
|
(message-id->tree timeline-type folder previous-id))
|
|
(and next-id
|
|
(message-id->tree timeline-type folder next-id)))))))
|
|
|
|
(defun next-status-tree (tree timeline-type &key (folder +default-status-folder+))
|
|
"Unused"
|
|
(multiple-value-bind (x next)
|
|
(neighbor-tree tree timeline-type :folder folder)
|
|
(declare (ignore x))
|
|
next))
|
|
|
|
(defun previous-status-tree (tree timeline-type &key (folder +default-status-folder+))
|
|
"Unused"
|
|
(multiple-value-bind (previous x)
|
|
(neighbor-tree tree timeline-type :folder folder)
|
|
(declare (ignore x))
|
|
previous))
|
|
|
|
(defun message-tree-root-equal (a b)
|
|
(string= (tree-data-id (mtree:root-node a))
|
|
(tree-data-id (mtree:root-node b))))
|
|
|
|
(defun all-status-trees (timeline folder)
|
|
"Returns all the trees (instances of `mtree-utils:m-tree') belonging
|
|
to `timeline' and `folder'"
|
|
(labels ((tree= (a b)
|
|
(message-tree-root-equal a b)))
|
|
(let ((res ())
|
|
(status-ids (mapcar #'second
|
|
(fetch-all-rows (select :status-id
|
|
(from :status)
|
|
(where (:folder folder))
|
|
(order-by (:asc :status-id)))))))
|
|
(loop for status-id in status-ids do
|
|
(let* ((status-id-root (row-message-status-id (message-root timeline
|
|
folder
|
|
status-id)))
|
|
(tree (message-id->tree timeline folder status-id-root)))
|
|
(pushnew tree res :test #'tree=)))
|
|
(sort res
|
|
(lambda (a b)
|
|
(let* ((root-a (mtree:root-node a))
|
|
(root-b (mtree:root-node b))
|
|
(status-id-a (row-message-status-id (mtree:data root-a)))
|
|
(status-id-b (row-message-status-id (mtree:data root-b))))
|
|
(string< status-id-a status-id-b)))))))
|
|
|
|
(defun fetch-status-trees (timeline folder &key (account-id nil))
|
|
"Returns all the trees (instances of `mtree-utils:m-tree') belonging
|
|
to `timeline', `folder' and `account-id'"
|
|
(labels ((tree= (a b)
|
|
(string= (tree-data-id (mtree:root-node a))
|
|
(tree-data-id (mtree:root-node b)))))
|
|
(let* ((res ())
|
|
(query (select :status-id
|
|
(from :status)
|
|
(where (:and (:= :folder folder)
|
|
(:= :timeline timeline)))
|
|
(order-by (:asc :status-id)))))
|
|
(when account-id
|
|
(and-where query `(:= :account-id ,account-id)))
|
|
(let* ((rows (fetch-all-rows query))
|
|
(status-ids (mapcar #'second rows)))
|
|
(loop for status-id in status-ids do
|
|
(let* ((status-id-root (row-message-status-id (message-root timeline
|
|
folder
|
|
status-id)))
|
|
(tree (message-id->tree timeline folder status-id-root)))
|
|
(pushnew tree res :test #'tree=)))
|
|
(sort res
|
|
(lambda (a b)
|
|
(let* ((root-a (mtree:root-node a))
|
|
(root-b (mtree:root-node b))
|
|
(status-id-a (row-message-status-id (mtree:data root-a)))
|
|
(status-id-b (row-message-status-id (mtree:data root-b))))
|
|
(string< status-id-a status-id-b))))))))
|
|
|
|
(defun annotated-tree-line->data-plist (line)
|
|
"See `mtree-utils:tree->annotated-lines"
|
|
(rest (last-elt line)))
|
|
|
|
(defun renumber-timeline-message-index (timeline-type folder &key (account-id nil))
|
|
"Add a unique numeric index to each message, that is, an unique ID
|
|
inside `timeline' and `folder'.
|
|
|
|
`account-id' additional restrict the message to be processed to the
|
|
ones of a single author
|
|
|
|
Message index is an unique number that identify the message after the
|
|
messages are sorted as below:
|
|
|
|
1. start with global message-index = 1
|
|
|
|
1. sort all the trees in a folder from the one with the older root to the newest
|
|
|
|
2. for each tree explore the messages starting from root
|
|
|
|
a. visit each node in the tree with a classic Depth First Search
|
|
and set the value index for that node as the value of message-index
|
|
|
|
b. increment message-index by 1"
|
|
(let ((all-trees (remove-if-not (lambda (tree)
|
|
(string= (db-getf (mtree:data tree) :timeline)
|
|
timeline-type))
|
|
(fetch-status-trees timeline-type
|
|
folder
|
|
:account-id account-id)))
|
|
(new-index +message-index-start+))
|
|
(loop for tree in all-trees do
|
|
(let ((tree-lines (mtree:tree->annotated-lines tree
|
|
:print-data t
|
|
:print-data-fn #'identity)))
|
|
(loop for line in tree-lines do
|
|
(let* ((status-id (row-message-status-id (annotated-tree-line->data-plist line)))
|
|
(query-update (update :status
|
|
(set= :message-index new-index)
|
|
(where (:and (:= :status-id status-id)
|
|
(:= :folder folder)
|
|
(:= :timeline timeline-type))))))
|
|
(query query-update)
|
|
(incf new-index)))))))
|
|
|
|
(defun all-folders ()
|
|
(let ((query (select (fields (:distinct :folder))
|
|
(from :status))))
|
|
(mapcar #'second
|
|
(fetch-all-rows query))))
|
|
|
|
(defun all-status-timelines ()
|
|
(mapcar #'second
|
|
(fetch-all-rows (select (fields (:distinct :timeline)) (from :status)))))
|
|
|
|
(defun renumber-all-timelines (timelines/folders-with-forgotten)
|
|
(let ((all-folders (all-folders))
|
|
(all-timelines (all-status-timelines)))
|
|
(loop for folder in all-folders do
|
|
(loop for timeline in all-timelines
|
|
when (or (statuses-marked-to-delete timeline folder)
|
|
(duplicated-message-index-p timeline folder)
|
|
(find (cons timeline folder)
|
|
timelines/folders-with-forgotten
|
|
:test #'equalp))
|
|
do
|
|
(renumber-timeline-message-index timeline folder :account-id nil)))))
|
|
|
|
(defun duplicated-message-index-p (timeline folder)
|
|
(let ((all-indices (mapcar #'second
|
|
(fetch-all-rows (select :message-index
|
|
(from +table-status+)
|
|
(where (:and (:= :folder folder)
|
|
(:= :timeline timeline))))))))
|
|
(not (length= (remove-duplicates all-indices :test #'=)
|
|
all-indices))))
|
|
|
|
(defun all-attachments-to-status (status-id)
|
|
(fetch-all-rows (select :*
|
|
(from +table-attachment+)
|
|
(where (:= :attached-to-id status-id)))))
|
|
|
|
(defun attachment-to-chat-message (chat-message-id)
|
|
(fetch-single (select :*
|
|
(from +table-attachment+)
|
|
(where (:= :attached-to-id chat-message-id)))))
|
|
|
|
(defun status->reblogged-status (wrapper-status-id)
|
|
"Return the status that identified by `wrapper-status-id'
|
|
reblogged (if exists)."
|
|
(when-let* ((wrapper-status (find-status-id wrapper-status-id))
|
|
(reblogged-status-id (row-message-reblog-id wrapper-status)))
|
|
(find-status-id reblogged-status-id)))
|
|
|
|
(defun all-attachments-urls-to-status (status-id &key (add-reblogged-urls nil))
|
|
"Returns all the attachments to status identified by `status-id'
|
|
and (if `add-reblogged-urls' is non nil) reblogged status (if exists)"
|
|
(let* ((res (mapcar (lambda (a) (db-getf a :url))
|
|
(all-attachments-to-status status-id)))
|
|
(reblogged-status (status->reblogged-status status-id)))
|
|
(when (and reblogged-status
|
|
add-reblogged-urls)
|
|
(setf res
|
|
(append res
|
|
(all-attachments-urls-to-status (row-message-status-id reblogged-status)
|
|
:add-reblogged-urls add-reblogged-urls))))
|
|
(remove-duplicates res :test #'string=)))
|
|
|
|
(defun debug-print-all-tree (timeline-type)
|
|
(let ((all-trees (remove-if-not (lambda (tree)
|
|
(string= (db-getf (mtree:data tree) :timeline)
|
|
timeline-type))
|
|
(all-status-trees timeline-type +default-status-folder+))))
|
|
(loop for tree in all-trees do
|
|
(format t "tree:~%~{~a~%~}~%"
|
|
(mtree:tree->annotated-lines tree
|
|
:print-data t
|
|
:print-data-fn
|
|
(lambda (a)
|
|
(strcat
|
|
(db-getf a :status-id)
|
|
" "
|
|
(to-s (db-getf a :message-index)))))))))
|
|
|
|
(defun mark-status-boolean-value (timeline folder status-id column value)
|
|
"Convenience function to set a boolean value for a single column of table status"
|
|
(assert (numberp value))
|
|
(assert (or (= value +db-true+)
|
|
(= value +db-false+)))
|
|
(let ((query (update :status
|
|
(set= column value)
|
|
(where (:and (:= :timeline timeline)
|
|
(:= :folder folder)
|
|
(:= :status-id status-id))))))
|
|
(query query)))
|
|
|
|
(defun mark-status-read (timeline folder status-id)
|
|
(mark-status-boolean-value timeline folder status-id :redp +db-true+))
|
|
|
|
(defun mark-status-unread (timeline folder status-id)
|
|
(mark-status-boolean-value timeline folder status-id :redp +db-false+))
|
|
|
|
(defun mark-status-deleted (timeline folder status-id)
|
|
"Mark status as need to be deleted."
|
|
(mark-status-boolean-value timeline folder status-id :deletedp +db-true+))
|
|
|
|
(defun mark-status-prevent-deletion (timeline folder status-id)
|
|
"Remove mark of status as need to be deleted."
|
|
(mark-status-boolean-value timeline folder status-id :deletedp +db-false+))
|
|
|
|
(defun count-status-redp (timeline folder &key (account-id nil))
|
|
(let ((query (select (fields (:count :*))
|
|
(from :status)
|
|
(where (:and (:= :folder folder)
|
|
(:= :timeline timeline)
|
|
(:= :redp +db-true+))))))
|
|
(when account-id
|
|
(and-where query `(:= :account-id ,account-id)))
|
|
(second (fetch-single query))))
|
|
|
|
(defun count-status (timeline folder &key (account-id nil))
|
|
(let ((query (select (fields (:count :*))
|
|
(from :status)
|
|
(where (:and (:= :folder folder)
|
|
(:= :timeline timeline))))))
|
|
(when account-id
|
|
(and-where query `(:= :account-id ,account-id)))
|
|
(second (fetch-single query))))
|
|
|
|
(defun search-messages-text-body (timeline folder text-looking-for &key (account-id nil))
|
|
"Search for `text-looking-for' inside the body of messages belonging to
|
|
`timeline' , `folder' and possibly `account-id'"
|
|
(let* ((actual-text-looking-for (prepare-for-sql-like text-looking-for))
|
|
(query (make-filtered-message-select nil
|
|
timeline
|
|
folder
|
|
account-id
|
|
`(:and :like :rendered-text
|
|
,actual-text-looking-for))))
|
|
(order-by= query :message-index)
|
|
(fetch-all-rows query)))
|
|
|
|
(defun find-matching-search-message-body (text-looking-for messages)
|
|
(let ((scanner (cl-ppcre:create-scanner text-looking-for
|
|
:case-insensitive-mode t)))
|
|
(loop for message in messages when (row-message-reblog-id message) do
|
|
(let* ((reblogged-status (find-status-id (row-message-reblog-id message)))
|
|
(reblogged-text (row-message-rendered-text reblogged-status)))
|
|
(setf (getf message :rendered-text)
|
|
reblogged-text)))
|
|
(find-if (lambda (a) (cl-ppcre:scan scanner
|
|
(row-message-rendered-text a)))
|
|
messages)))
|
|
|
|
(defun search-next-message-body (timeline
|
|
folder
|
|
text-looking-for
|
|
start-status-message-index
|
|
&key (account-id nil))
|
|
"Search for `text-looking-for' inside the body of messages belonging
|
|
to `timeline' , `folder' and possibly `account-id', newer than
|
|
`start-status-message-index'"
|
|
(let* ((query (make-filtered-message-select nil
|
|
timeline
|
|
folder
|
|
account-id
|
|
`(:and :> :status.message-index
|
|
,start-status-message-index))))
|
|
(order-by= query :message-index)
|
|
(find-matching-search-message-body text-looking-for (fetch-all-rows query))))
|
|
|
|
(defun search-previous-message-body (timeline
|
|
folder
|
|
text-looking-for
|
|
start-status-message-index
|
|
&key (account-id nil))
|
|
"Search for `text-looking-for' inside the body of messages belonging
|
|
to `timeline' , `folder' and possibly `account-id', older than
|
|
`start-status-message-index'"
|
|
(let* ((query (make-filtered-message-select nil
|
|
timeline
|
|
folder
|
|
account-id
|
|
`(:and :< :status.message-index
|
|
,start-status-message-index))))
|
|
(order-by= query '(:desc :message-index))
|
|
(find-matching-search-message-body text-looking-for (fetch-all-rows query))))
|
|
|
|
(defun search-next-message-meta (timeline
|
|
folder
|
|
text-looking-for
|
|
start-status-message-index
|
|
&key (account-id nil))
|
|
"Search for `text-looking-for' inside the metadata of messages belonging
|
|
to `timeline' , `folder' and possibly `account-id', newer than
|
|
`start-status-message-index'
|
|
|
|
Metadata are:
|
|
|
|
- spoiler-text (subject of message)
|
|
- tags
|
|
- username"
|
|
(let* ((actual-text-looking-for (prepare-for-sql-like text-looking-for))
|
|
(query (make-filtered-message-select nil
|
|
timeline
|
|
folder
|
|
account-id
|
|
`(:or :like :spoiler-text
|
|
,actual-text-looking-for)
|
|
`(:or :like :tags
|
|
,actual-text-looking-for)
|
|
`(:or :like :username
|
|
,actual-text-looking-for)
|
|
`(:and :> :status.message-index
|
|
,start-status-message-index))))
|
|
(order-by= query :message-index)
|
|
(fetch-single query)))
|
|
|
|
(defun search-previous-message-meta (timeline
|
|
folder
|
|
text-looking-for
|
|
start-status-message-index
|
|
&key (account-id nil))
|
|
"Search for `text-looking-for' inside the metadata of messages belonging
|
|
to `timeline' , `folder' and possibly `account-id', older than
|
|
`start-status-message-index'
|
|
|
|
Metadata are:
|
|
|
|
- spoiler-text (subject of message)
|
|
- tags
|
|
- username"
|
|
(let* ((actual-text-looking-for (prepare-for-sql-like text-looking-for))
|
|
(query (make-filtered-message-select nil
|
|
timeline
|
|
folder
|
|
account-id
|
|
`(:or :like :username
|
|
,actual-text-looking-for)
|
|
`(:or :like :spoiler-text
|
|
,actual-text-looking-for)
|
|
`(:or :like :tags
|
|
,actual-text-looking-for)
|
|
`(:and :< :status.message-index
|
|
,start-status-message-index))))
|
|
(order-by= query '(:desc :message-index))
|
|
(fetch-single query)))
|
|
|
|
(defun search-next-unread-message (timeline
|
|
folder
|
|
start-status-message-index
|
|
&key (account-id nil))
|
|
"Search the next unread message belonging
|
|
to `timeline' , `folder' and possibly `account-id', older than
|
|
`start-status-message-index'"
|
|
(let* ((query (make-filtered-message-select nil
|
|
timeline
|
|
folder
|
|
account-id
|
|
`(:and :> :status.message-index
|
|
,start-status-message-index)
|
|
`(:and := :status.redp
|
|
,+db-false+))))
|
|
(order-by= query :message-index)
|
|
(fetch-single query)))
|
|
|
|
(defmacro with-add-account-id-to-query ((query query-body) account-id &body body)
|
|
`(let ((,query ,query-body))
|
|
(when ,account-id
|
|
(and-where ,query `(:= :account-id ,,account-id)))
|
|
,@body))
|
|
|
|
(defun add-where-timeline-folder (query timeline folder)
|
|
(and-where query `(:= :timeline ,timeline))
|
|
(and-where query `(:= :folder ,folder)))
|
|
|
|
(defun last-message-index-status (timeline-type folder &key (account-id nil))
|
|
(with-add-account-id-to-query
|
|
(query (select ((:as (fields (:max :message-index)) :max))
|
|
(from :status)
|
|
(where (:and (:= :timeline timeline-type)
|
|
(:= :folder folder)))))
|
|
account-id
|
|
(when-let ((row (fetch-single query)))
|
|
(second row))))
|
|
|
|
(defun last-status-id-timeline-folder-table (timeline folder table)
|
|
(let ((query (select ((:as (fields (:max :status-id)) :max))
|
|
(from table)
|
|
(where (:and (:= :timeline timeline)
|
|
(:= :folder folder))))))
|
|
(second (fetch-single query))))
|
|
|
|
(defun first-status-id-timeline-folder-table (timeline folder table)
|
|
(let ((query (select ((:as (fields (:min :status-id)) :min))
|
|
(from table)
|
|
(where (:and (:= :timeline timeline)
|
|
(:= :folder folder))))))
|
|
(second (fetch-single query))))
|
|
|
|
(defun last-status-id-timeline-folder (timeline folder)
|
|
(last-status-id-timeline-folder-table timeline folder :status))
|
|
|
|
(defun first-status-id-timeline-folder (timeline folder)
|
|
(first-status-id-timeline-folder-table timeline folder :status))
|
|
|
|
(defun last-ignored-status-id-timeline-folder (timeline folder)
|
|
(last-status-id-timeline-folder-table timeline folder :ignored-status))
|
|
|
|
(defun first-ignored-status-id-timeline-folder (timeline folder)
|
|
(first-status-id-timeline-folder-table timeline folder :ignored-status))
|
|
|
|
(defun last-pagination-status-id-timeline-folder (timeline folder)
|
|
(last-status-id-timeline-folder-table timeline folder :pagination-status))
|
|
|
|
(defun first-pagination-status-id-timeline-folder (timeline folder)
|
|
(first-status-id-timeline-folder-table timeline folder :pagination-status))
|
|
|
|
(defun find-pagination-status (status-id folder timeline)
|
|
(fetch-single (select :*
|
|
(from +table-pagination-status+)
|
|
(where (:and (:= :status-id status-id)
|
|
(:= :folder folder)
|
|
(:= :timeline timeline))))))
|
|
|
|
(defun add-to-pagination-status (status-id folder timeline &key (ensure-no-duplicates nil))
|
|
(let ((no-duplicate-p (if ensure-no-duplicates
|
|
(not (find-pagination-status status-id folder timeline))
|
|
t)))
|
|
(when no-duplicate-p
|
|
(query (make-insert +table-pagination-status+
|
|
(:status-id :folder :timeline)
|
|
(status-id folder timeline))))))
|
|
|
|
(defun remove-pagination-status (folder timeline)
|
|
"Removes all the pagination data (i.e. all columns from table
|
|
:pagination-data) matching `folder' and `timeline'"
|
|
(query (make-delete +table-pagination-status+
|
|
(:and (:= :folder folder)
|
|
(:= :timeline timeline)))))
|
|
|
|
(defun delete-status (timeline-type folder status-id)
|
|
"delete status and connect its children with their grandparent"
|
|
(let* ((status (find-status-id-folder-timeline status-id
|
|
folder
|
|
timeline-type))
|
|
(parent-status-id (db-getf status :in-reply-to-id))
|
|
(children (message-children timeline-type folder status-id))
|
|
(query-delete (delete-from :status
|
|
(where (:and (:= :timeline timeline-type)
|
|
(:= :folder folder)
|
|
(:= :status-id status-id))))))
|
|
(with-db-transaction
|
|
(query query-delete)
|
|
(loop for child in children do
|
|
(query (make-update :status
|
|
(:in-reply-to-id)
|
|
(parent-status-id)
|
|
(:and (:= :timeline timeline-type)
|
|
(:= :folder folder)
|
|
(:= :status-id (row-message-status-id child)))))))))
|
|
|
|
(defun count-status-marked-to-delete ()
|
|
(second (fetch-single (select (fields (:count :status-id))
|
|
(from :status)
|
|
(where (:= :deletedp +db-true+))))))
|
|
|
|
(defun statuses-marked-to-delete (timeline folder)
|
|
(query (select :*
|
|
(from :status)
|
|
(where (:and (:= :deletedp +db-true+)
|
|
(:= :timeline timeline)
|
|
(:= :folder folder))))))
|
|
|
|
(defun delete-all-statuses-marked-deleted ()
|
|
"Delete all messages marked for deletion and parent message (AKA
|
|
reblogged or retooted), if such parent message exists, from the timeline
|
|
specified by +default-reblogged-timeline+. The latter is the folder
|
|
where all parent messages are saved."
|
|
(let ((all-folders (all-folders))
|
|
(all-timelines (all-status-timelines)))
|
|
(loop for folder in all-folders do
|
|
(loop for timeline in all-timelines do
|
|
(let ((marked-to-delete (statuses-marked-to-delete timeline folder)))
|
|
(loop for status-to-delete in marked-to-delete do
|
|
(when-let ((reblogged-id (row-message-reblog-id status-to-delete)))
|
|
;; sometimes a status is reblogged by more than
|
|
;; one of the statuses that you downloaded and if
|
|
;; you delete at least two of the latter the first
|
|
;; deletion will remove also the reblogged status,
|
|
;; so the other statuses should skip deletion of
|
|
;; the reblogged one as it has been already
|
|
;; removed
|
|
(when (find-status-id-folder-timeline reblogged-id
|
|
+default-reblogged-folder+
|
|
+default-reblogged-timeline+)
|
|
(delete-status +default-reblogged-timeline+
|
|
+default-reblogged-folder+
|
|
reblogged-id)))
|
|
(delete-status timeline folder (row-message-status-id status-to-delete))))))))
|
|
|
|
(defun max-username-length (timeline-type folder)
|
|
(let ((query (select (fields (:max (:length :account.acct)))
|
|
(from :status)
|
|
(join :account :on (:= :account.id
|
|
:status.account-id))
|
|
(where (:and (:= :timeline timeline-type)
|
|
(:= :folder folder))))))
|
|
(second (fetch-single query))))
|
|
|
|
(defgeneric keyword->dbcolumn (object))
|
|
|
|
(defmethod keyword->dbcolumn ((object symbol))
|
|
(string-downcase (symbol-name object)))
|
|
|
|
(defmethod keyword->dbcolumn ((object string))
|
|
object)
|
|
|
|
(defun folder-exists-p (folder)
|
|
(fetch-all-rows (select :*
|
|
(from :status)
|
|
(where (:= :folder folder)))))
|
|
|
|
(defun timeline-exists-p (folder timeline)
|
|
(fetch-all-rows (select :*
|
|
(from :status)
|
|
(where (:and (:= :folder folder)
|
|
(:= :timeline timeline))))))
|
|
|
|
(defun move-message-to-folder (timeline folder status-id destination-folder)
|
|
(let ((message-exists-p (message-from-timeline-folder-id timeline folder status-id)))
|
|
(query (make-update :status
|
|
(:folder)
|
|
(destination-folder)
|
|
(:and (:= :status-id status-id)
|
|
(:= :timeline timeline)
|
|
(:= :folder folder))))
|
|
message-exists-p))
|
|
|
|
(defun move-tree-to-folder (timeline folder message-index destination-folder)
|
|
"Move the tree of messages (identified by `timeline', `folder' and `message-index' to
|
|
`destination-folder'"
|
|
(let ((tree (message-index->tree timeline folder message-index)))
|
|
(mtree:top-down-visit tree
|
|
(lambda (node)
|
|
(let ((id (row-message-status-id (mtree:data node))))
|
|
(move-message-to-folder timeline folder id destination-folder))))
|
|
(renumber-timeline-message-index timeline folder)
|
|
(renumber-timeline-message-index timeline destination-folder)))
|
|
|
|
(defun last-status-id-in-tree (tree)
|
|
"Returns the newest message in `tree' (an instance of
|
|
`mtree-utils:mtree')"
|
|
(let ((maximum ""))
|
|
(mtree:top-down-visit tree
|
|
(lambda (node)
|
|
(let ((id (row-message-status-id (mtree:data node))))
|
|
(when (string> id maximum)
|
|
(setf maximum id)))))
|
|
maximum))
|
|
|
|
(defun all-timelines-in-folder (folder &key (include-default-timelines nil))
|
|
(assert folder)
|
|
(let* ((query (select (fields (:distinct :timeline))
|
|
(from :status)
|
|
(where (:= :folder folder))))
|
|
(dynamic (mapcar #'second
|
|
(fetch-all-rows query))))
|
|
(if include-default-timelines
|
|
(union (default-timelines)
|
|
dynamic
|
|
:test #'string=)
|
|
dynamic)))
|
|
|
|
(defun set-ignore-status-author (status-id new-value)
|
|
"Ignore or unignore the future statuses authored by the user
|
|
identified by the account that wrote the status identified by
|
|
`status-id'"
|
|
(when-let* ((status (find-status-id status-id))
|
|
(account-id (db-getf status :account-id)))
|
|
(query (make-update :account
|
|
(:ignoredp)
|
|
((prepare-for-db new-value :to-integer t))
|
|
(:and (:= :id account-id))))))
|
|
|
|
(defun ignore-status-author (status-id)
|
|
"Ignore the future statuses authored by the user identified by the
|
|
account that wrote the status identified by `status-id'"
|
|
(set-ignore-status-author status-id t))
|
|
|
|
(defun unignore-author (id)
|
|
"Unignore the future statuses authored by the user identified by the
|
|
account that wrote the status identified by `status-id'"
|
|
(query (make-update :account
|
|
(:ignoredp)
|
|
(+db-false+)
|
|
(:or (:= :id id)
|
|
(:= :acct id)))))
|
|
|
|
(defun all-usernames ()
|
|
(mapcar #'second
|
|
(fetch-all-rows (select :acct (from :account) (order-by :acct)))))
|
|
|
|
(defun all-ignored-usernames ()
|
|
(mapcar #'second
|
|
(fetch-all-rows (select :acct
|
|
(from :account)
|
|
(where (:= :ignoredp +db-true+))
|
|
(order-by :acct)))))
|
|
|
|
(defun all-followed-usernames ()
|
|
(mapcar #'second
|
|
(fetch-all-rows (select :account.acct
|
|
(from :account)
|
|
(join :followed-user :on (:= :account.id
|
|
:followed-user.user-id))))))
|
|
|
|
(defun all-unfollowed-usernames (&key (remove-ignored nil))
|
|
(let ((all (all-usernames))
|
|
(followed (all-followed-usernames)))
|
|
(when remove-ignored
|
|
(setf all (set-difference all (all-ignored-usernames) :test #'string=)))
|
|
(set-difference all followed :test #'string=)))
|
|
|
|
(defun status-ignored-p (status-id folder timeline)
|
|
"Return non nil if this status should be ignored
|
|
(id timeline and folder is the tuple that is primary key for table
|
|
:status)"
|
|
(query (select :*
|
|
(from :ignored-status)
|
|
(where (:and (:= :status-id status-id)
|
|
(:= :folder folder)
|
|
(:= :timeline timeline))))))
|
|
|
|
(defun status-skipped-p (status-id folder timeline)
|
|
"Return non nil if this status should be skipped because belong to an ignored account
|
|
(id timeline and folder is the tuple that is primary key for table
|
|
:status)"
|
|
(query (select :*
|
|
(from +table-skipped-status+)
|
|
(where (:and (:= :status-id status-id)
|
|
(:= :folder folder)
|
|
(:= :timeline timeline))))))
|
|
|
|
(defmacro with-db-current-timestamp ((timestamp) &body body)
|
|
`(let ((,timestamp (prepare-for-db (local-time-obj-now))))
|
|
,@body))
|
|
|
|
(defun add-to-status-ignored (status-id folder timeline)
|
|
"Ignore this status (id timeline and folder is the tuple that is primary key for table
|
|
:status), Ignored status wont be downloaded again from the net."
|
|
(when (not (status-ignored-p status-id folder timeline))
|
|
(with-db-current-timestamp (now)
|
|
(query (make-insert +table-ignored-status+
|
|
(:status-id :folder :timeline :created-at)
|
|
(status-id folder timeline now))))))
|
|
|
|
(defun add-to-status-skipped (status-id folder timeline)
|
|
"Skips this status (id timeline and folder is the tuple that is
|
|
primary key for table :status), if in this table the
|
|
status has been downloaded from the net and ignored because belog to an ignored account."
|
|
(when (not (status-skipped-p status-id folder timeline))
|
|
(with-db-current-timestamp (now)
|
|
(query (make-insert +table-skipped-status+
|
|
(:status-id :folder :timeline :created-at)
|
|
(status-id folder timeline now))))))
|
|
|
|
(defun remove-from-status-skipped (status-id folder timeline)
|
|
(query (make-delete +table-skipped-status+
|
|
(:and (:= :status-id status-id)
|
|
(:= :folder folder)
|
|
(:= :timeline timeline)))))
|
|
|
|
(defun remove-from-status-ignored (status-id folder timeline)
|
|
(query (make-delete +table-ignored-status+
|
|
(:and (:= :status-id status-id)
|
|
(:= :folder folder)
|
|
(:= :timeline timeline)))))
|
|
|
|
(defun add-to-followers (user-id)
|
|
(with-db-current-timestamp (now)
|
|
(query (make-insert +table-followed-user+
|
|
(:user-id :created-at)
|
|
(user-id now)))))
|
|
|
|
(defun remove-from-followers (user-id)
|
|
(query (make-delete +table-followed-user+
|
|
(:= :user-id user-id))))
|
|
|
|
(defun forget-all-statuses-marked-deleted ()
|
|
"Ignore all statuses marked for deletion. Returns an alist
|
|
of (timeline, folder) pairs that has statuses marked for deletion."
|
|
(let ((all-folders (all-folders))
|
|
(all-timelines (all-status-timelines))
|
|
(results ()))
|
|
(loop for folder in all-folders do
|
|
(loop for timeline in all-timelines do
|
|
(let ((marked-to-delete (statuses-marked-to-delete timeline folder)))
|
|
(loop for status-to-delete in marked-to-delete do
|
|
(pushnew (cons timeline folder)
|
|
results
|
|
:test #'equalp)
|
|
(add-to-status-ignored (row-message-status-id status-to-delete)
|
|
folder
|
|
timeline)))))
|
|
results))
|
|
|
|
(defun status-id->username (status-id)
|
|
(when-let ((message (fetch-single (make-filtered-message-select nil nil nil nil
|
|
`(:= :status.status-id
|
|
,status-id)))))
|
|
(row-message-username message)))
|
|
|
|
(defun subscribe-to-tag (tag)
|
|
(assert (stringp tag))
|
|
(assert (string-not-empty-p tag))
|
|
(when (null (fetch-from-id +table-subscribed-tag+ tag))
|
|
(with-db-current-timestamp (now)
|
|
(query (make-insert +table-subscribed-tag+
|
|
(:id :created-at)
|
|
(tag now))))))
|
|
|
|
(defun unsubscribe-to-tag (tag)
|
|
(assert (stringp tag))
|
|
(assert (string-not-empty-p tag))
|
|
(query (make-delete +table-subscribed-tag+
|
|
(:= :id tag))))
|
|
|
|
(defun all-subscribed-tags (&key (sort-data nil))
|
|
(let ((query (select :*
|
|
(from +table-subscribed-tag+))))
|
|
(when sort-data
|
|
(order-by= query
|
|
'(:asc :id)))
|
|
(fetch-all-rows query)))
|
|
|
|
(defun all-subscribed-tags-name (&key (sort-data nil) (as-folder-name t))
|
|
(let ((names (mapcar #'row-id (all-subscribed-tags :sort-data sort-data))))
|
|
(if as-folder-name
|
|
names
|
|
(mapcar #'folder-name->tag names))))
|
|
|
|
(defun tag-folder-name-p (name)
|
|
"Returns non nil if name is a valid folder name for subsribed tags"
|
|
(scan (strcat "^" +folder-tag-prefix+) name))
|
|
|
|
(defun tag->folder-name (tag)
|
|
"Add the tag prefix (usually '#') from folder to get the tag name"
|
|
(if (tag-folder-name-p tag)
|
|
tag
|
|
(strcat +folder-tag-prefix+ tag)))
|
|
|
|
(defun tag->paginations-status (tag timeline)
|
|
(let ((folder (tag->folder-name tag)))
|
|
(values (first-pagination-status-id-timeline-folder timeline folder)
|
|
(last-pagination-status-id-timeline-folder timeline folder))))
|
|
|
|
(defun all-tag-paginations-status (tags &optional (timeline +default-tag-timeline+))
|
|
(loop for tag in tags collect
|
|
(multiple-value-bind (oldest newest)
|
|
(tag->paginations-status tag timeline)
|
|
(list oldest newest))))
|
|
|
|
(defun folder-name->tag (folder)
|
|
"Strip the tag prefix (usually '#') from tag name to get the folder
|
|
name"
|
|
(cl-ppcre:regex-replace +folder-tag-prefix+ folder ""))
|
|
|
|
(defun max-status-id-subscribed-tag (tag &key (include-ignored t))
|
|
(let* ((max-status-id-row (fetch-single (select (fields (:max :status-id))
|
|
(from +table-status+)
|
|
(where (:= :folder
|
|
(tag->folder-name tag))))))
|
|
(max-status-id (second max-status-id-row)))
|
|
(if (not include-ignored)
|
|
max-status-id
|
|
(let* ((max-ignored-status-id-row (fetch-single (select (fields (:max :status-id))
|
|
(from +table-ignored-status+)
|
|
(where (:= :folder
|
|
(tag->folder-name tag))))))
|
|
(max-ignored-status-id (second max-ignored-status-id-row)))
|
|
(or max-status-id
|
|
max-ignored-status-id)))))
|
|
|
|
(defun more-recent-tag-fetched-p (tag)
|
|
"Returns the most recent message fetched that contains tag `tag', or
|
|
nil if no such message exists"
|
|
(when-let* ((row (fetch-from-id +table-subscribed-tag+ tag)))
|
|
(let* ((last-status-id (db-getf row :last-status-id-fetched))
|
|
(max-status-id-fetched (max-status-id-subscribed-tag tag :include-ignored nil)))
|
|
(cond
|
|
((not (or last-status-id
|
|
max-status-id-fetched))
|
|
nil)
|
|
((null last-status-id)
|
|
t)
|
|
((and max-status-id-fetched
|
|
(string> max-status-id-fetched
|
|
last-status-id))
|
|
t)))))
|
|
|
|
(defun all-tags-with-new-message-fetched ()
|
|
"Returns a list all the tags names that contains new messages, or nil
|
|
if no such messages exist"
|
|
(remove-if-not #'more-recent-tag-fetched-p
|
|
(all-subscribed-tags-name)))
|
|
|
|
(defun update-last-seen-status-with-tag (tag)
|
|
(when-let* ((max-status-id (max-status-id-subscribed-tag tag :include-ignored nil)))
|
|
(query (make-update +table-subscribed-tag+
|
|
(:last-status-id-fetched)
|
|
(max-status-id)
|
|
(:= :id tag)))))
|
|
|
|
(defun update-last-seen-status-subscribed-tag ()
|
|
(loop for tag in (all-subscribed-tags-name) do
|
|
(update-last-seen-status-with-tag tag)))
|
|
|
|
(defun tag-histogram (tag)
|
|
(mapcar #'second
|
|
(fetch-all (query (select :count
|
|
(from +table-tag-histogram+)
|
|
(where (:= :tag tag)))))))
|
|
|
|
(defun set-got-new-message-tag (tag value)
|
|
(query (make-update +table-subscribed-tag+
|
|
(:got-new-message-p)
|
|
(value)
|
|
(:= :id tag))))
|
|
|
|
(defun mark-tag-got-new-messages (tag)
|
|
(set-got-new-message-tag tag +db-true+))
|
|
|
|
(defun unmark-tag-got-new-messages (tag)
|
|
(set-got-new-message-tag tag +db-false+))
|
|
|
|
(defun conversation-max-id ()
|
|
(when-let ((row (query (select ((:as (fields (:max :id)) :max))
|
|
(from +table-conversation+)))))
|
|
(second row)))
|
|
|
|
(defun all-conversations (&key (remove-ignored t))
|
|
(let ((query (select :*
|
|
(from +table-conversation+))))
|
|
(order-by= query :id)
|
|
(when remove-ignored
|
|
(and-where query `(:= :ignoredp ,+db-false+)))
|
|
(fetch-all-rows query)))
|
|
|
|
(defun all-conversations-id (&key (remove-ignored t))
|
|
(mapcar #'row-id (all-conversations :remove-ignored remove-ignored)))
|
|
|
|
(defun add-conversation (id root-message-status-id &key (folder id))
|
|
"Create a new conversation: the timeline for messges will be
|
|
+default-converation-timeline+ and default folder name will be weual
|
|
to id."
|
|
(assert (string-not-empty-p id))
|
|
(assert (string-not-empty-p root-message-status-id))
|
|
(assert (string-not-empty-p folder))
|
|
(when (null (fetch-from-id +table-conversation+ id))
|
|
(with-db-current-timestamp (now)
|
|
(query (make-insert +table-conversation+
|
|
(:id :folder :root-status-id :created-at)
|
|
(id folder root-message-status-id now))))))
|
|
|
|
(defun conversation-id->folder (id)
|
|
(assert (stringp id))
|
|
(assert (string-not-empty-p id))
|
|
(second (fetch-single (select :folder
|
|
(from +table-conversation+)
|
|
(where (:= :id id))))))
|
|
|
|
(defun all-conversation-folders (&key (remove-ignored t))
|
|
(let ((all (all-conversations :remove-ignored remove-ignored)))
|
|
(mapcar #'row-conversation-folder all)))
|
|
|
|
(defun conversation-folder-exists-p (folder)
|
|
(query (select :*
|
|
(from +table-conversation+)
|
|
(where (:= :folder folder)))))
|
|
|
|
(defun conversation-root-captured-p (root-status-id)
|
|
"non nil if this root status alerady bleong to an existsing
|
|
conversation"
|
|
(query (select :*
|
|
(from +table-conversation+)
|
|
(where (:= :root-status-id root-status-id)))))
|
|
|
|
(defun update-folder (table old-folder-name new-folder-name)
|
|
"Change folder name in `table'"
|
|
(query (make-update table
|
|
(:folder)
|
|
(new-folder-name)
|
|
(:= :folder old-folder-name))))
|
|
|
|
(defun update-conversation-folder (old-folder-name new-folder-name)
|
|
"Change conversation folder name"
|
|
(update-folder +table-conversation+ old-folder-name new-folder-name))
|
|
|
|
(defun update-conversation-folder-by-id (id new-folder-name)
|
|
"Unused"
|
|
(query (make-update +table-conversation+
|
|
(:folder)
|
|
(new-folder-name)
|
|
(:= :id id))))
|
|
|
|
(defun update-conversation-by-id (id new-folder-name root-message-id)
|
|
"Unused"
|
|
(query (make-update +table-conversation+
|
|
(:folder :root-status-id)
|
|
(new-folder-name root-message-id)
|
|
(:= :id id))))
|
|
|
|
(defun update-status-folder (old-folder-name new-folder-name)
|
|
"chane statuses folder name"
|
|
(update-folder +table-status+ old-folder-name new-folder-name))
|
|
|
|
(defun change-conversation-name (old-name new-name)
|
|
"This will update both column folder in table converstion and in table status"
|
|
(with-db-transaction
|
|
(update-status-folder old-name new-name)
|
|
(update-conversation-folder old-name new-name)))
|
|
|
|
(defun conversation-messages (name)
|
|
"returns all the message in a conversation in folder `name'"
|
|
(let ((statuses (query (select ((:as :conversation.id :conversation-id)
|
|
(:as :account.acct :username)
|
|
(:as :account.locked :locked)
|
|
:status.*)
|
|
(from :status)
|
|
(join :account :on (:= :account.id
|
|
:status.account-id))
|
|
(join :conversation :on (:= :conversation.folder
|
|
:status.folder))
|
|
(where (:= :conversation.folder name))))))
|
|
statuses))
|
|
|
|
(defclass conversation-stats ()
|
|
((conversation-id
|
|
:initform nil
|
|
:initarg :conversation-id
|
|
:accessor conversation-id)
|
|
(messages-red
|
|
:initform -1
|
|
:initarg :messages-red
|
|
:accessor messages-red)
|
|
(messages-to-read
|
|
:initform -1
|
|
:initarg :messages-to-read
|
|
:accessor messages-to-read)
|
|
(conversation-name
|
|
:initform (_ "unknown")
|
|
:initarg :conversation-name
|
|
:accessor conversation-name))
|
|
(:documentation "Statistics for conversation"))
|
|
|
|
(defun conversation-read/red (name)
|
|
(let* ((all-messages (conversation-messages name))
|
|
(red (remove-if-not #'row-message-redp all-messages))
|
|
(to-read (remove-if #'row-message-redp all-messages)))
|
|
(values to-read red)))
|
|
|
|
(defun all-conversation-stats (&key (remove-ignored t))
|
|
"All statistics for all converstions optionally with ignored
|
|
conversation removed (default: remove)"
|
|
(let ((all (all-conversations :remove-ignored remove-ignored)))
|
|
(loop for conversation in all collect
|
|
(let ((name (row-conversation-folder conversation))
|
|
(id (row-id conversation)))
|
|
(multiple-value-bind (to-read red)
|
|
(conversation-read/red name)
|
|
(make-instance 'conversation-stats
|
|
:conversation-id id
|
|
:messages-red (length red)
|
|
:messages-to-read (length to-read)
|
|
:conversation-name name))))))
|
|
|
|
(defun ignore-conversation (folder-name)
|
|
"Ignore a conversation, never got new messages"
|
|
(query (make-update +table-conversation+
|
|
(:ignoredp)
|
|
(+db-true+)
|
|
(:= :folder folder-name))))
|
|
|
|
(defun delete-conversation (folder-name)
|
|
"Delete a conversation from database"
|
|
(query (make-delete +table-conversation+
|
|
(:= :folder folder-name))))
|
|
|
|
(defun import-crypto-data (user-id key)
|
|
(assert user-id)
|
|
(assert key)
|
|
(with-db-transaction
|
|
(when (fetch-from-id +table-account+ user-id)
|
|
(query (make-insert +table-crypto-data+
|
|
(:key)
|
|
(key)))
|
|
(let ((last-crypto-data (second (fetch-single (select (fields (:max :id))
|
|
(from +table-crypto-data+))))))
|
|
(query (make-update +table-account+
|
|
(:encryption-key-id)
|
|
(last-crypto-data)
|
|
(:= :id user-id)))))))
|
|
|
|
(defun crypto-user-key (username)
|
|
(assert username)
|
|
(assert (stringp username))
|
|
(let ((data (fetch-single (select ((:as :crypto.key :key))
|
|
(from :crypto)
|
|
(join :account :on (:= :account.encryption-key-id :crypto.id))
|
|
(where (:= :account.acct username))))))
|
|
(second data)))
|
|
|
|
(defun cache-touch (key)
|
|
"Update the column \"accessed-at\" of an existingcache row to current time."
|
|
(with-db-current-timestamp (now)
|
|
(query (make-update +table-cache+
|
|
(:accessed-at)
|
|
(now)
|
|
(:= :key key)))))
|
|
|
|
(defun cache-put (key &optional (type "generic"))
|
|
"Insert a new cahe row with key `key'"
|
|
(if (cache-get key)
|
|
(with-db-transaction
|
|
(cache-touch key)
|
|
(cache-get-value key))
|
|
(with-db-transaction
|
|
(with-db-current-timestamp (now)
|
|
(query (make-insert +table-cache+
|
|
(:key :type :created-at :accessed-at)
|
|
(key type now now)))
|
|
(last-inserted-rowid)))))
|
|
|
|
(defun cache-get (key)
|
|
"Get cache row identified by `key'"
|
|
(fetch-single (select :*
|
|
(from :cache)
|
|
(where (:= :key key)))))
|
|
|
|
(defun cache-get-key-type (key type)
|
|
"Get cache row identified by `key'"
|
|
(fetch-single (select :*
|
|
(from :cache)
|
|
(where (:and (:= :key key)
|
|
(:= :type type))))))
|
|
|
|
(defun cache-get-value (key)
|
|
"Get cache value identified by `key'"
|
|
(row-id (cache-get key)))
|
|
|
|
(defun cache-invalidate (key)
|
|
"delete cache row identified by `key'"
|
|
(assert key)
|
|
(query (make-delete +table-cache+
|
|
(:= :key key))))
|
|
|
|
(defun cache-expired-p (key &key (days-in-the-past (swconf:config-purge-cage-days-offset)))
|
|
"Return non nil if the last time the cache was accessed was older
|
|
than `days-in-the-past' days (default: `(swconf:config-purge-cache-days-offset)'"
|
|
(let ((row (cache-get key)))
|
|
(if (null row)
|
|
t
|
|
(let ((access-time (encode-datetime-string (db-getf row :accessed-at)))
|
|
(offset (threshold-time days-in-the-past)))
|
|
(local-time:timestamp< access-time
|
|
offset)))))
|
|
|
|
(defun cache-delete-all ()
|
|
(query (make-delete +table-cache+)))
|
|
|
|
(defun saved-titan-token (url)
|
|
(row-token (fetch-single (select :*
|
|
(from :titan-token)
|
|
(where (:= :url url))))))
|
|
|
|
(defun save-titan-token (url token)
|
|
(query (delete-from +table-titan-token+ (where (:= :url url))))
|
|
(query (make-insert +table-titan-token+
|
|
(:url :token)
|
|
(url token))))
|
|
|
|
(defun tofu-passes-p (host hash)
|
|
(let ((known-host (fetch-single (select :*
|
|
(from +table-gemini-tofu-cert+)
|
|
(where (:= :host host))))))
|
|
(cond
|
|
(known-host
|
|
(string= (db-getf known-host :hash) hash))
|
|
(t
|
|
(with-db-current-timestamp (now)
|
|
(query (make-insert +table-gemini-tofu-cert+
|
|
(:host :hash :seen-at)
|
|
(host hash now)))
|
|
t)))))
|
|
|
|
(defun tofu-delete (host)
|
|
(query (delete-from +table-gemini-tofu-cert+ (where (:= :host host)))))
|
|
|
|
(defun find-tls-certificates-rows (&optional (url-like ""))
|
|
(when-let* ((text-looking-for (prepare-for-sql-like url-like))
|
|
(query (select :*
|
|
(from +table-cache+)
|
|
(where (:and (:like :key text-looking-for)
|
|
(:= :type +cache-tls-certificate-type+)))
|
|
(order-by (:desc :updated-at)))))
|
|
(fetch-all-rows query)))
|
|
|
|
(defun gemini-subscribe-url (url title subtitle)
|
|
(query (make-insert +table-gemini-subscription+
|
|
(:url :title :subtitle)
|
|
(url title subtitle))))
|
|
|
|
(defun gemini-find-subscription (url)
|
|
(when-let* ((query (select :*
|
|
(from +table-gemini-subscription+)
|
|
(where (:= :url url))))
|
|
(row (fetch-single query)))
|
|
row))
|
|
|
|
(defun row-unseen-count (row)
|
|
(and row
|
|
(db-getf row :unseen-count :default 0)))
|
|
|
|
(defun row-seen-count (row)
|
|
(and row
|
|
(db-getf row :seen-count :default 0)))
|
|
|
|
(defun gemini-all-subscriptions ()
|
|
(when-let* ((query (select (:gemini-subscription.*
|
|
(:as (select (fields (:count :url))
|
|
(from :gemlog-entries)
|
|
(where (:and (:= :gemlog-entries.seenp
|
|
(prepare-for-db nil :to-integer t))
|
|
(:= :gemlog-entries.deletedp
|
|
(prepare-for-db nil :to-integer t))
|
|
(:= :gemlog-entries.gemlog-id
|
|
:gemini-subscription.url))))
|
|
:unseen-count)
|
|
(:as (select (fields (:count :url))
|
|
(from :gemlog-entries)
|
|
(where (:and (:= :gemlog-entries.seenp
|
|
(prepare-for-db t :to-integer t))
|
|
(:= :gemlog-entries.deletedp
|
|
(prepare-for-db nil :to-integer t))
|
|
(:= :gemlog-entries.gemlog-id
|
|
:gemini-subscription.url))))
|
|
:seen-count))
|
|
(from +table-gemini-subscription+)
|
|
(order-by (:desc :unseen-count) :title :subtitle :url)))
|
|
(rows (fetch-all-rows query)))
|
|
rows))
|
|
|
|
(defun gemini-all-unread-posts ()
|
|
(when-let* ((query (select (:title :url)
|
|
(from +table-gemlog-entries+)
|
|
(where (:= :seenp (prepare-for-db nil :to-integer t)))))
|
|
(rows (fetch-all-rows query)))
|
|
rows))
|
|
|
|
(defun gemini-cancel-subscription (gemlog-url)
|
|
(query (delete-from +table-gemini-subscription+ (where (:= :url gemlog-url)))))
|
|
|
|
(defun gemini-gemlog-subscribed-p (gemlog-url)
|
|
(query (select :* (from +table-gemini-subscription+) (where (:= :url gemlog-url)))))
|
|
|
|
(defun find-gemlog-entry (post-url)
|
|
(when-let* ((query (select :*
|
|
(from +table-gemlog-entries+)
|
|
(where (:= :url post-url))))
|
|
(row (fetch-single query)))
|
|
row))
|
|
|
|
(defun add-gemlog-entries (gemlog-iri post-url post-title post-date seenp)
|
|
(query (make-insert +table-gemlog-entries+
|
|
(:url
|
|
:gemlog-id
|
|
:date
|
|
:title
|
|
:seenp)
|
|
(post-url
|
|
gemlog-iri
|
|
(decode-datetime-string post-date)
|
|
post-title
|
|
(prepare-for-db seenp :to-integer t)))))
|
|
|
|
(defun gemlog-mark-as-seen (post-url)
|
|
(let ((update-query (make-update +table-gemlog-entries+
|
|
(:seenp)
|
|
((prepare-for-db t :to-integer t))
|
|
(:= :url post-url))))
|
|
(query update-query)))
|
|
|
|
(gen-access-message-row gemlog-url :gemlog-url)
|
|
|
|
(gen-access-message-row gemlog-title :gemlog-title :only-empty-or-0-are-null t)
|
|
|
|
(gen-access-message-row gemlog-subtitle :gemlog-subtitle :only-empty-or-0-are-null t)
|
|
|
|
(gen-access-message-row post-date :post-date)
|
|
|
|
(gen-access-message-row post-title :post-title :only-empty-or-0-are-null t)
|
|
|
|
(gen-access-message-row post-link :post-link)
|
|
|
|
(gen-access-message-row post-seenp :seenp)
|
|
|
|
(defun gemlog-entries (gemlog-url &key (unseen-only nil) (seen-only nil))
|
|
(assert (not (and unseen-only
|
|
seen-only)))
|
|
(when-let* ((query (select ((:as :gemini-subscription.url :gemlog-url)
|
|
(:as :gemini-subscription.title :gemlog-title)
|
|
(:as :gemini-subscription.subtitle :gemlog-subtitle)
|
|
(:as :gemlog-entries.date :post-date)
|
|
(:as :gemlog-entries.title :post-title)
|
|
(:as :gemlog-entries.url :post-link)
|
|
(:as :gemlog-entries.seenp :seenp))
|
|
(from :gemlog-entries)
|
|
(join :gemini-subscription
|
|
:on (:= :gemlog-entries.gemlog-id
|
|
:gemini-subscription.url))
|
|
(where (:and (:= :gemini-subscription.url gemlog-url)
|
|
(:= :gemlog-entries.deletedp
|
|
(prepare-for-db nil :to-integer t))))))
|
|
(unordered-rows (fetch-all-rows query))
|
|
(actual-rows (cond
|
|
(unseen-only
|
|
(remove-if-not (lambda (row) (db-nil-p (row-seenp row)))
|
|
unordered-rows))
|
|
(seen-only
|
|
(remove-if (lambda (row) (db-nil-p (row-seenp row)))
|
|
unordered-rows))
|
|
(t
|
|
unordered-rows))))
|
|
(num:multisort actual-rows (list (num:gen-multisort-test (lambda (a b)
|
|
(if (and (db-nil-p a)
|
|
(db-nil-p b))
|
|
a
|
|
(db-nil-p a)))
|
|
(lambda (a b)
|
|
(if (and (db-nil-p a)
|
|
(db-nil-p b))
|
|
b
|
|
(db-nil-p b)))
|
|
(lambda (a)
|
|
(db-getf a :seenp)))
|
|
(num:gen-multisort-test string>
|
|
string<
|
|
(lambda (a)
|
|
(row-post-date a)))))))
|
|
|
|
(defun delete-gemlog-entry (gemlog-url)
|
|
(query (make-update +table-gemlog-entries+
|
|
(:deletedp)
|
|
((prepare-for-db t :to-integer 1))
|
|
(where (:= :url gemlog-url)))))
|
|
|
|
(defun purge-seen-gemlog-entries ()
|
|
"Remove expired gemlog and (seen) entries.
|
|
|
|
An entry is expired if older than (swconf:config-purge-history-days-offset)
|
|
days in the past"
|
|
(let ((treshold (threshold-time -255)))
|
|
(query (make-update +table-gemlog-entries+
|
|
(:deletedp)
|
|
((prepare-for-db t :to-integer 1))
|
|
(:and (:= :seenp (prepare-for-db t :to-integer 1))
|
|
(:< :date (prepare-for-db treshold)))))))
|
|
|
|
|
|
(defun bookmark-add (type value &key (section nil) (description (_ "no description")))
|
|
(with-db-current-timestamp (now)
|
|
(query (make-insert +table-bookmark+
|
|
(:type :value :section :description :created-at)
|
|
(type value section description now)))))
|
|
|
|
(defun bookmark-all-sections ()
|
|
(let ((rows (query (select :section (from +table-bookmark+) (group-by :section)))))
|
|
(mapcar #'second rows)))
|
|
|
|
(defun bookmark-complete->id (description)
|
|
(ignore-errors (parse-integer description :junk-allowed t)))
|
|
|
|
(defun bookmark-description-for-complete (type)
|
|
(let ((rows (query (select :* (from +table-bookmark+) (where (:= :type type))))))
|
|
(mapcar (lambda (a) (strcat (to-s (row-id a))
|
|
": -"
|
|
(row-section a)
|
|
" - "
|
|
(row-description a)
|
|
(row-value a)))
|
|
rows)))
|
|
|
|
(defun bookmark-all-by-section (section)
|
|
(if (null section)
|
|
(query (select :* (from +table-bookmark+) (where (:is-null :section))))
|
|
(query (select :* (from +table-bookmark+) (where (:= :section section))))))
|
|
|
|
(defun bookmark-all-bookmarked-url ()
|
|
(remove-if-not (lambda (a) (iri:iri-parse a :null-on-error t))
|
|
(mapcar #'second
|
|
(query (select :value (from +table-bookmark+))))))
|
|
|
|
(defun bookmark-all ()
|
|
(query (select :* (from +table-bookmark+))))
|
|
|
|
(defun bookmark-exists-p (iri)
|
|
(query (select :id (from +table-bookmark+)
|
|
(where (:like :value (prepare-for-sql-like iri))))))
|
|
|
|
(defun bookmark-all-grouped-by-section ()
|
|
(let ((sections (sort (bookmark-all-sections) #'string<)))
|
|
(loop for section in sections
|
|
collect
|
|
(cons section (bookmark-all-by-section section)))))
|
|
|
|
(defgeneric bookmark-delete (id))
|
|
|
|
(defmethod bookmark-delete ((id number))
|
|
(delete-by-id +table-bookmark+ id))
|
|
|
|
(defmethod bookmark-delete ((id string))
|
|
(query (delete-from +table-bookmark+ (where (:= :value id)))))
|
|
|
|
(defun gempub-metadata-add (local-uri
|
|
&optional
|
|
original-uri
|
|
title
|
|
gpub-version
|
|
index-file
|
|
author
|
|
language
|
|
charset
|
|
description
|
|
published
|
|
publish-date
|
|
revision-date
|
|
copyright
|
|
license
|
|
version
|
|
cover)
|
|
(assert (stringp local-uri))
|
|
(with-db-current-timestamp (now)
|
|
(query (make-insert +table-gempub-metadata+
|
|
(:local-uri
|
|
:original-uri
|
|
:title
|
|
:gpub-version
|
|
:index-file
|
|
:author
|
|
:language
|
|
:charset
|
|
:description
|
|
:published
|
|
:publish-date
|
|
:revision-date
|
|
:copyright
|
|
:license
|
|
:version
|
|
:cover
|
|
:created-at)
|
|
(local-uri
|
|
original-uri
|
|
title
|
|
gpub-version
|
|
index-file
|
|
author
|
|
language
|
|
charset
|
|
description
|
|
published
|
|
publish-date
|
|
revision-date
|
|
copyright
|
|
license
|
|
version
|
|
cover
|
|
now)))))
|
|
|
|
(defun all-gempub-metadata ()
|
|
(query (select :* (from +table-gempub-metadata+))))
|
|
|
|
(defun gempub-metadata-delete (local-uri)
|
|
(query (delete-from +table-gempub-metadata+ (where (:= :local-uri local-uri)))))
|
|
|
|
(defun gempub-metadata-find (local-uri)
|
|
(fetch-single (select :* (from +table-gempub-metadata+) (where (:= :local-uri local-uri)))))
|
|
|
|
(defun get-parent-status-row (status-id)
|
|
"Get the database row of representing the parent status of the status
|
|
identified by `status-id', if exists.
|
|
Note: `status-id' must identify at least a row in the database."
|
|
(flet ((get-cache (status-id)
|
|
(db:find-status-id status-id)))
|
|
(when-let* ((cached-child (get-cache status-id))
|
|
(parent-id (db:row-message-reply-to-id cached-child)))
|
|
(or (get-cache parent-id)
|
|
(progn
|
|
(db:update-db (api-client:get-remote-status parent-id))
|
|
(get-cache parent-id))))))
|