cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-02-18 08:20:35 +01:00
Code Issues
tinmop/src/db.lisp

3471 lines
147 KiB
Common Lisp
Raw Blame History

;; 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)
(a:define-constant +make-id-autoincrement+ " id INTEGER PRIMARY KEY AUTOINCREMENT, "
:test #'string=)
(a:define-constant +make-id+ " id INTEGER PRIMARY KEY, "
:test #'string=)
(a:define-constant +make-string-id+ " id TEXT PRIMARY KEY, "
:test #'string=)
(a:define-constant +other-id+ :other-id
:test #'eq)
(a:define-constant +make-open+ " ( "
:test #'string=)
(a:define-constant +make-close+ " ) "
:test #'string=)
(a:define-constant +restrict+ " RESTRICT "
:test #'string=)
(a:define-constant +cascade+ " CASCADE "
:test #'string=)
(a:define-constant +col-sep+ " , "
:test #'string=)
(a:define-constant +db-true+ 1
:test #'eq)
(a:define-constant +db-false+ 0
:test #'eq)
(a:define-constant +table-cache+ :cache
:test #'eq)
(a:define-constant +table-status+ :status
:test #'eq)
(a:define-constant +table-crypto-data+ :crypto
:test #'eq)
(a:define-constant +table-account+ :account
:test #'eq)
(a:define-constant +table-poll-option+ :poll-option
:test #'eq)
(a:define-constant +table-poll+ :poll
:test #'eq)
(a:define-constant +table-attachment+ :attachment
:test #'eq)
(a:define-constant +table-input-history+ :input-history
:test #'eq)
(a:define-constant +table-ignored-status+ :ignored-status
:test #'eq)
(a:define-constant +table-skipped-status+ :skipped-status
:test #'eq)
(a:define-constant +table-pagination-status+ :pagination-status
:test #'eq)
(a:define-constant +table-followed-user+ :followed-user
:test #'eq)
(a:define-constant +table-subscribed-tag+ :subscribed-tag
:test #'eq)
(a:define-constant +table-tag-histogram+ :tag-histogram
:test #'eq)
(a:define-constant +table-conversation+ :conversation
:test #'eq)
(a:define-constant +table-chat+ :chat
:test #'eq)
(a:define-constant +table-chat-message+ :chat-message
:test #'eq)
(a:define-constant +table-gemini-tofu-cert+ :gemini-tofu-cert
:test #'eq)
(a:define-constant +table-gemini-subscription+ :gemini-subscription
:test #'eq)
(a:define-constant +table-gemlog-entries+ :gemlog-entries
:test #'eq)
(a:define-constant +table-bookmark+ :bookmark
:test #'eq)
(a:define-constant +table-gempub-metadata+ :gempub-metadata
:test #'eq)
(a:define-constant +table-titan-token+ :titan-token
:test #'eq)
(a:define-constant +view-search-fediverse-statuses+ :view-search-fediverse-statuses
:test #'eq)
(a:define-constant +bookmark-gemini-type-entry+ "gemini"
:test #'string=)
(a:define-constant +federated-timeline+ "federated"
:test #'string=)
(a:define-constant +local-timeline+ "local"
:test #'string=)
(a:define-constant +home-timeline+ "home"
:test #'string=)
(a:define-constant +direct-timeline+ "direct"
:test #'string=)
(a:define-constant +default-status-folder+ "default"
:test #'string=)
(a:define-constant +mentions-status-folder+ "mentions"
:test #'string=)
(a:define-constant +default-tag-timeline+ +federated-timeline+
:test #'string=)
(a:define-constant +default-converation-timeline+ +federated-timeline+
:test #'string=)
(a:define-constant +hidden-recipient-prefix+ #\.
:test #'char=)
(a:define-constant +default-reblogged-timeline+ ".reblogged"
:test #'string=)
(a:define-constant +default-reblogged-folder+ +default-status-folder+
:test #'string=)
(a:define-constant +message-index-start+ 1
:test #'=)
(a: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+
(a: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 view-search-fediverse-statuses ()
(select (:status-id
:account-id
(:as :status.url :url)
(:as :status.uri :uri)
:content
:rendered-text
:visibility
:sensitive
:spoiler-text
:reblogs-count
:favourites-count
:replies-count
:language
:favourited
:reblogged
:muted
:tags
:application
:redp
:timeline
:folder
(:as :account.username :username)
(:as :account.acct :account))
(from :status)
(inner-join :account :on (:= :account.id :status.account-id))))
(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 ()
(create-view +view-search-fediverse-statuses+ (view-search-fediverse-statuses)))
(defun delete-all-views ()
(delete-view +view-search-fediverse-statuses+))
(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)
(build-views)
(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 executing `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 executing `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 set 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)
(a: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"
(a: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"
(a: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"
(a: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 ((threshold (threshold-time (swconf:config-purge-history-days-offset))))
(query (make-delete +table-input-history+
(:< :date-added (prepare-for-db threshold))))))
(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'"
(a: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'"
(a: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 information
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 information
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; please note
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 joined with table `account` for some extra
information (see the function `gen-message-select').
- 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 connected 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))
(a: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))
(a: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"
(a: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 (a: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 (a: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)."
(a: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
(a: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 remove-status-row (timeline-type folder status-id)
"delete status row"
(let ((query-delete (delete-from :status
(where (:and (:= :timeline timeline-type)
(:= :folder folder)
(:= :status-id status-id))))))
(query query-delete)))
(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
(a: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'"
(a: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 won't 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 belong 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)
(a: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 subscribed 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"
(a: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)
(a: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 ()
(a: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 already belong to an existing
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 ""))
(a: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)
(a: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 ()
(a: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 ()
(a: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)
(a: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)))
(a: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 ((threshold (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 threshold)))))))
(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 gempub-metadata-id->row (id)
(fetch-from-id +table-gempub-metadata+ id))
(defun gempub-metadata-id->path (id)
(a:when-let ((row (gempub-metadata-id->row id)))
(getf row :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)))
(a: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))))))
View Git Blame Copy Permalink