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

- [fediverse] added command for posts local search.

This commit is contained in:
cage 2024-06-15 13:57:50 +02:00
parent 3290f12226
commit 0b73087e4d
8 changed files with 259 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
etc/init.lisp
View File

@ -280,6 +280,8 @@
(define-key "/ q" #'search-fediverse *thread-keymap*)
(define-key "/ Q" #'search-fediverse-local *thread-keymap*)
(define-key "/ b" #'thread-search-next-message-body *thread-keymap*)
(define-key "/ m" #'thread-search-next-message-meta *thread-keymap*)

11
src/db-utils.lisp
View File

@ -328,6 +328,17 @@ nil (default T), start a new connection"
(defun encoded-datetime-year (decoded)
(misc:extract-year-from-timestamp (encode-datetime-string decoded)))
(defun insert-query (table columns-plist)
(let ((column-values (remove-if #'keywordp columns-plist))
(column-names (remove-if-not #'keywordp columns-plist)))
(assert (length= column-values column-names))
(values (format nil
"INSERT INTO ~a (~{~a~^,~}) VALUES (~{~a~^,~})"
(quote-symbol table)
(mapcar #'quote-symbol column-names)
(loop repeat (length column-names) collect #\?))
column-values)))
(defmacro make-insert (table-name names values)
"Generate an sxql insert statement

62
src/db.lisp
View File

@ -137,6 +137,9 @@
(define-constant +table-titan-token+ :titan-token
:test #'eq)
(define-constant +view-search-fediverse-statuses+ :view-search-fediverse-statuses
:test #'eq)
(define-constant +bookmark-gemini-type-entry+ "gemini"
:test #'string=)
@ -620,6 +623,34 @@
"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))
@ -667,9 +698,11 @@
+table-gempub-metadata+
+table-titan-token+))
(defun build-views ())
(defun build-views ()
(create-view +view-search-fediverse-statuses+ (view-search-fediverse-statuses)))
(defun delete-all-views ())
(defun delete-all-views ()
(delete-view +view-search-fediverse-statuses+))
(defun delete-database ()
(with-disabled-foreign
@ -703,6 +736,7 @@
(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
@ -1650,8 +1684,8 @@ identifier despite the name."
(where (:= :status-id status-id)))))
(defun find-message-id (status-id)
"Find a message (status with other columns like acct) by id, notes
that status id is not a unique identifier despite the name."
"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
@ -1736,17 +1770,17 @@ that identify a single message in table :status"
as was likely intended."
(let ((query (gen-message-select)))
(loop for other-column in other-columns do
(fields+ query other-column))
(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))))
(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

139
src/fediverse-post-local-search.lisp Normal file
View File

@ -0,0 +1,139 @@
;; tinmop: a multiprotocol client
;; Copyright © cage
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(in-package :fediverse-post-local-search)
(defrule fedisearch-blank (or #\space #\Newline #\Tab)
(:constant nil))
(defrule fedisearch-blanks (* fedisearch-blank)
(:constant nil))
(defrule fedisearch-value (+ (not #\Newline))
(:text t))
(defrule fedisearch-spaces (+ fedisearch-blank)
(:constant nil))
(defrule fedisearch-column (or
"\"status-id\""
"\"account-id\""
"username"
"account"
"uri"
"content"
"\"rendered-text\""
"visibility"
"sensitive"
"spoiler-text"
"reblogs-count"
"\"favourites-count\""
"\"replies-count\""
"url"
"language"
"favourited"
"reblogged"
"muted"
"tags"
"application"
"redp"
"timeline"
"folder")
(:text t))
(defrule fedisearch-column-value (and #\" (+ (not #\")) #\")
(:text t))
(defrule fedisearch-column-value (and #\" (+ (not #\")) #\")
(:text t))
(defrule fedisearch-parens-term (and "(" fedisearch-blanks fedisearch-term fedisearch-blanks ")")
(:function (lambda (a) (strcat "(" (third a) ")"))))
(defrule fedisearch-term (or fedisearch-parens-term
fedisearch-and-where
fedisearch-or-where
fedisearch-like
fedisearch-=-term
fedisearch-!=-term
fedisearch-<-term
fedisearch->-term
fedisearch-<=-term
fedisearch->=-term)
(:function (lambda (a) (join-with-strings a " "))))
(defrule fedisearch-like (and fedisearch-column fedisearch-spaces "like"
fedisearch-spaces fedisearch-column-value)
(:function (lambda (a) (format nil
"~a like \"%~a%\""
(first a)
(string-trim '(#\") (fifth a))))))
(defrule fedisearch-=-term (and fedisearch-column fedisearch-spaces "="
fedisearch-spaces fedisearch-column-value)
(:function (lambda (a) (format nil
"~a = ~a"
(first a)
(fifth a)))))
(defrule fedisearch-<-term (and fedisearch-column fedisearch-spaces "<" fedisearch-spaces fedisearch-column-value)
(:function (lambda (a) (format nil
"~a < ~a"
(first a)
(fifth a)))))
(defrule fedisearch->-term (and fedisearch-column fedisearch-spaces ">" fedisearch-spaces fedisearch-column-value)
(:function (lambda (a) (format nil
"~a > ~a"
(first a)
(fifth a)))))
(defrule fedisearch-<=-term (and fedisearch-column fedisearch-spaces "<=" fedisearch-spaces fedisearch-column-value)
(:function (lambda (a) (format nil
"~a <= ~a"
(first a)
(fifth a)))))
(defrule fedisearch->=-term (and fedisearch-column fedisearch-spaces ">=" fedisearch-spaces fedisearch-column-value)
(:function (lambda (a) (format nil
"~a >= ~a"
(first a)
(fifth a)))))
(defrule fedisearch-!=-term (and fedisearch-column fedisearch-spaces "!=" fedisearch-spaces fedisearch-column-value)
(:function (lambda (a) (format nil
"~a != ~a"
(first a)
(fifth a)))))
(defrule fedisearch-and-where (and fedisearch-term fedisearch-spaces "and" fedisearch-spaces fedisearch-term))
(defrule fedisearch-or-where (and fedisearch-term fedisearch-spaces "or" fedisearch-spaces fedisearch-term))
(defrule fedisearch-where-clause (and "where" fedisearch-spaces (+ fedisearch-term))
(:function (lambda (a)
(if (listp a)
(strcat "where " (join-with-strings (third a) " "))
""))))
(defun parse-search-statuses (query)
(let* ((where-clause (parse 'fedisearch-where-clause query))
(sql-query (strcat (format nil
"select * from \"~a\" ~a"
+view-search-fediverse-statuses+
where-clause))))
(db-utils:query-low-level sql-query)))

21
src/package.lisp
View File

@ -876,6 +876,7 @@
:encode-datetime-string
:encoded-datetime-year
:make-insert
:insert-query
:make-delete
:make-update
:get-max-id
@ -908,6 +909,7 @@
:+table-crypto-data+
:+table-gemini-subscription+
:+table-bookmark+
:+view-search-fediverse-statuses+
:+bookmark-gemini-type-entry+
:+federated-timeline+
:+local-timeline+
@ -1798,6 +1800,7 @@
:show-announcements-event
:check-announcements-event
:fediverse-query-event
:fediverse-local-query-event
:delete-all-notifications-event
:dispatch-program-events
:dispatch-program-events-or-wait))
@ -3230,6 +3233,7 @@
:thread-go-to-parent-post
:thread-open-parent-post
:search-fediverse
:search-fediverse-local
:localized-default-string))
(defpackage :scheduled-events
@ -3312,6 +3316,23 @@
(:shadowing-import-from :misc :random-elt :shuffle)
(:export))
(defpackage :fediverse-post-local-search
(:use
:cl
:cl-ppcre
:esrap
:config
:constants
:text-utils
:misc-utils
:db-utils
:db)
(:local-nicknames (:a :alexandria))
(:export
:parse-search-statuses))
;; GUI
(defpackage :json-rpc-communication
(:use
:cl

19
src/program-events.lisp
View File

@ -2030,6 +2030,25 @@
:payload query-page))
(ui:info-message (_ "Search completed"))))))
(defclass fediverse-local-query-event (program-event) ())
(defmethod process-event ((object fediverse-local-query-event))
(with-accessors ((payload payload)) object
(loop for status-results in (fediverse-post-local-search:parse-search-statuses payload)
do
(let ((status-row (db:find-status-id (db:row-message-status-id status-results))))
(setf (getf status-row :folder)
(query-results-folder-name))
(setf (getf status-row :timeline)
db:+home-timeline+)
(multiple-value-bind (query column-values)
(db-utils:insert-query db:+table-status+ status-row)
(db-utils:query-low-level query column-values))))
(let ((refresh-event (make-instance 'refresh-thread-windows-event
:new-folder (query-results-folder-name)
:new-timeline db:+home-timeline+)))
(push-event refresh-event))))
;;;; end events
(defun dispatch-program-events ()

26
src/ui-goodies.lisp
View File

@ -3671,16 +3671,26 @@ gemini client certificates!)."
(thread-go-to-parent-post)
(thread-open-selected-message))
(defun search-fediverse ()
"Search the fediverse for statuses, account and hashtags that match a query string."
(labels ((on-input-complete (query)
(if (string-not-empty-p query)
(push-event (make-instance 'program-events:fediverse-query-event
:payload query))
(defun localized-default-string ()
(_ "Default"))
(defmacro with-search-fediverse ((query) &body body)
`(labels ((on-input-complete (,query)
(if (string-not-empty-p ,query)
(progn ,@body)
(error-message (_ "Empty query")))))
(ask-string-input #'on-input-complete
:prompt (_ "Search query: ")
:complete-fn #'complete:fediverse-search-complete)))
(defun localized-default-string ()
(_ "Default"))
(defun search-fediverse ()
"Search the fediverse for statuses, account and hashtags that match a query string."
(with-search-fediverse (query)
(push-event (make-instance 'program-events:fediverse-query-event
:payload query))))
(defun search-fediverse-local ()
"Search the fediverse local database for statuses that match a query string. See the manpage for reference"
(with-search-fediverse (query)
(push-event (make-instance 'program-events:fediverse-local-query-event
:payload query))))

1
tinmop.asd
View File

@ -148,6 +148,7 @@
(:file "ui-goodies")
(:file "scheduled-events")
(:file "modules")
(:file "fediverse-post-local-search")
(:file "json-rpc2")
(:module gui-server
:pathname "gui/server"