mirror of https://codeberg.org/cage/tinmop/
- [fediverse] added command for posts local search.
This commit is contained in:
parent
3290f12226
commit
0b73087e4d
|
@ -280,6 +280,8 @@
|
||||||
|
|
||||||
(define-key "/ q" #'search-fediverse *thread-keymap*)
|
(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 "/ b" #'thread-search-next-message-body *thread-keymap*)
|
||||||
|
|
||||||
(define-key "/ m" #'thread-search-next-message-meta *thread-keymap*)
|
(define-key "/ m" #'thread-search-next-message-meta *thread-keymap*)
|
||||||
|
|
|
@ -328,6 +328,17 @@ nil (default T), start a new connection"
|
||||||
(defun encoded-datetime-year (decoded)
|
(defun encoded-datetime-year (decoded)
|
||||||
(misc:extract-year-from-timestamp (encode-datetime-string 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)
|
(defmacro make-insert (table-name names values)
|
||||||
"Generate an sxql insert statement
|
"Generate an sxql insert statement
|
||||||
|
|
||||||
|
|
42
src/db.lisp
42
src/db.lisp
|
@ -137,6 +137,9 @@
|
||||||
(define-constant +table-titan-token+ :titan-token
|
(define-constant +table-titan-token+ :titan-token
|
||||||
:test #'eq)
|
:test #'eq)
|
||||||
|
|
||||||
|
(define-constant +view-search-fediverse-statuses+ :view-search-fediverse-statuses
|
||||||
|
:test #'eq)
|
||||||
|
|
||||||
(define-constant +bookmark-gemini-type-entry+ "gemini"
|
(define-constant +bookmark-gemini-type-entry+ "gemini"
|
||||||
:test #'string=)
|
:test #'string=)
|
||||||
|
|
||||||
|
@ -620,6 +623,34 @@
|
||||||
"UNIQUE(url) ON CONFLICT FAIL"
|
"UNIQUE(url) ON CONFLICT FAIL"
|
||||||
+make-close+)))
|
+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 ()
|
(defun build-all-indices ()
|
||||||
(create-table-index +table-status+ '(:folder :timeline :status-id))
|
(create-table-index +table-status+ '(:folder :timeline :status-id))
|
||||||
(create-table-index +table-account+ '(:id :acct))
|
(create-table-index +table-account+ '(:id :acct))
|
||||||
|
@ -667,9 +698,11 @@
|
||||||
+table-gempub-metadata+
|
+table-gempub-metadata+
|
||||||
+table-titan-token+))
|
+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 ()
|
(defun delete-database ()
|
||||||
(with-disabled-foreign
|
(with-disabled-foreign
|
||||||
|
@ -703,6 +736,7 @@
|
||||||
(make-gempub-metadata)
|
(make-gempub-metadata)
|
||||||
(make-titan-token)
|
(make-titan-token)
|
||||||
(build-all-indices)
|
(build-all-indices)
|
||||||
|
(build-views)
|
||||||
(fs:set-file-permissions (db-path) (logior fs:+s-irusr+ fs:+s-iwusr+))))
|
(fs:set-file-permissions (db-path) (logior fs:+s-irusr+ fs:+s-iwusr+))))
|
||||||
|
|
||||||
;; specific utils
|
;; specific utils
|
||||||
|
@ -1650,8 +1684,8 @@ identifier despite the name."
|
||||||
(where (:= :status-id status-id)))))
|
(where (:= :status-id status-id)))))
|
||||||
|
|
||||||
(defun find-message-id (status-id)
|
(defun find-message-id (status-id)
|
||||||
"Find a message (status with other columns like acct) by id, notes
|
"Find a message (status with other columns like acct) by id; please note
|
||||||
that status id is not a unique identifier despite the name."
|
that status-id is not a unique identifier despite the name."
|
||||||
(fetch-single (make-filtered-message-select nil
|
(fetch-single (make-filtered-message-select nil
|
||||||
nil
|
nil
|
||||||
nil
|
nil
|
||||||
|
|
|
@ -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)))
|
|
@ -876,6 +876,7 @@
|
||||||
:encode-datetime-string
|
:encode-datetime-string
|
||||||
:encoded-datetime-year
|
:encoded-datetime-year
|
||||||
:make-insert
|
:make-insert
|
||||||
|
:insert-query
|
||||||
:make-delete
|
:make-delete
|
||||||
:make-update
|
:make-update
|
||||||
:get-max-id
|
:get-max-id
|
||||||
|
@ -908,6 +909,7 @@
|
||||||
:+table-crypto-data+
|
:+table-crypto-data+
|
||||||
:+table-gemini-subscription+
|
:+table-gemini-subscription+
|
||||||
:+table-bookmark+
|
:+table-bookmark+
|
||||||
|
:+view-search-fediverse-statuses+
|
||||||
:+bookmark-gemini-type-entry+
|
:+bookmark-gemini-type-entry+
|
||||||
:+federated-timeline+
|
:+federated-timeline+
|
||||||
:+local-timeline+
|
:+local-timeline+
|
||||||
|
@ -1798,6 +1800,7 @@
|
||||||
:show-announcements-event
|
:show-announcements-event
|
||||||
:check-announcements-event
|
:check-announcements-event
|
||||||
:fediverse-query-event
|
:fediverse-query-event
|
||||||
|
:fediverse-local-query-event
|
||||||
:delete-all-notifications-event
|
:delete-all-notifications-event
|
||||||
:dispatch-program-events
|
:dispatch-program-events
|
||||||
:dispatch-program-events-or-wait))
|
:dispatch-program-events-or-wait))
|
||||||
|
@ -3230,6 +3233,7 @@
|
||||||
:thread-go-to-parent-post
|
:thread-go-to-parent-post
|
||||||
:thread-open-parent-post
|
:thread-open-parent-post
|
||||||
:search-fediverse
|
:search-fediverse
|
||||||
|
:search-fediverse-local
|
||||||
:localized-default-string))
|
:localized-default-string))
|
||||||
|
|
||||||
(defpackage :scheduled-events
|
(defpackage :scheduled-events
|
||||||
|
@ -3312,6 +3316,23 @@
|
||||||
(:shadowing-import-from :misc :random-elt :shuffle)
|
(:shadowing-import-from :misc :random-elt :shuffle)
|
||||||
(:export))
|
(: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
|
(defpackage :json-rpc-communication
|
||||||
(:use
|
(:use
|
||||||
:cl
|
:cl
|
||||||
|
|
|
@ -2030,6 +2030,25 @@
|
||||||
:payload query-page))
|
:payload query-page))
|
||||||
(ui:info-message (_ "Search completed"))))))
|
(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
|
;;;; end events
|
||||||
|
|
||||||
(defun dispatch-program-events ()
|
(defun dispatch-program-events ()
|
||||||
|
|
|
@ -3671,16 +3671,26 @@ gemini client certificates!)."
|
||||||
(thread-go-to-parent-post)
|
(thread-go-to-parent-post)
|
||||||
(thread-open-selected-message))
|
(thread-open-selected-message))
|
||||||
|
|
||||||
(defun search-fediverse ()
|
(defun localized-default-string ()
|
||||||
"Search the fediverse for statuses, account and hashtags that match a query string."
|
(_ "Default"))
|
||||||
(labels ((on-input-complete (query)
|
|
||||||
(if (string-not-empty-p query)
|
(defmacro with-search-fediverse ((query) &body body)
|
||||||
(push-event (make-instance 'program-events:fediverse-query-event
|
`(labels ((on-input-complete (,query)
|
||||||
:payload query))
|
(if (string-not-empty-p ,query)
|
||||||
|
(progn ,@body)
|
||||||
(error-message (_ "Empty query")))))
|
(error-message (_ "Empty query")))))
|
||||||
(ask-string-input #'on-input-complete
|
(ask-string-input #'on-input-complete
|
||||||
:prompt (_ "Search query: ")
|
:prompt (_ "Search query: ")
|
||||||
:complete-fn #'complete:fediverse-search-complete)))
|
:complete-fn #'complete:fediverse-search-complete)))
|
||||||
|
|
||||||
(defun localized-default-string ()
|
(defun search-fediverse ()
|
||||||
(_ "Default"))
|
"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))))
|
||||||
|
|
|
@ -148,6 +148,7 @@
|
||||||
(:file "ui-goodies")
|
(:file "ui-goodies")
|
||||||
(:file "scheduled-events")
|
(:file "scheduled-events")
|
||||||
(:file "modules")
|
(:file "modules")
|
||||||
|
(:file "fediverse-post-local-search")
|
||||||
(:file "json-rpc2")
|
(:file "json-rpc2")
|
||||||
(:module gui-server
|
(:module gui-server
|
||||||
:pathname "gui/server"
|
:pathname "gui/server"
|
||||||
|
|
Loading…
Reference in New Issue