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

- added a new command: 'search-fediverse'.

This commit is contained in:
cage 2024-05-04 14:07:33 +02:00
parent e75793133e
commit 4eb0963d06
6 changed files with 88 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
etc/init.lisp
View File

@ -278,6 +278,8 @@
(define-key "^" #'thread-open-parent-post *thread-keymap*) (define-key "^" #'thread-open-parent-post *thread-keymap*)
(define-key "/ q" #'search-fediverse *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*)

27
src/api-client.lisp
View File

@ -559,21 +559,24 @@ database."
(kind "statuses") (kind "statuses")
(exclude-unreviewed nil) (exclude-unreviewed nil)
(resolve t) (resolve t)
(limit 20) (limit 40)
(offset 0) (offset 0)
(following nil)) (following nil))
"Search stuff, default statuses" "Search stuff, default statuses"
(tooter:find-results *client* (let ((results (tooter:find-results *client*
query query
:account-id account-id :account-id account-id
:max-id max-id :max-id max-id
:min-id min-id :min-id min-id
:kind kind :kind kind
:exclude-unreviewed exclude-unreviewed :exclude-unreviewed exclude-unreviewed
:resolve resolve :resolve resolve
:limit limit :limit limit
:offset offset :offset offset
:following following)) :following following)))
(values (tooter:results-statuses results)
(tooter:results-accounts results)
(tooter:results-tags results))))
(defun-api-call follow-user (user-id) (defun-api-call follow-user (user-id)
"Follow user identified by user-id" "Follow user identified by user-id"

3
src/complete.lisp
View File

@ -293,3 +293,6 @@ list af all possible candidates for completion."
(when-let ((matched (remove-if-not (contains-clsr hint) (when-let ((matched (remove-if-not (contains-clsr hint)
(db:bookmark-description-for-complete type)))) (db:bookmark-description-for-complete type))))
(values matched (reduce-to-common-prefix matched))))) (values matched (reduce-to-common-prefix matched)))))
(with-simple-complete fediverse-search-complete
(lambda () '("has:" "is:" "language:" "from:" "before:" "during:" "after:" "in:")))

5
src/package.lisp
View File

@ -1646,6 +1646,7 @@
:complete-always-empty :complete-always-empty
:bookmark-section-complete :bookmark-section-complete
:bookmark-description-complete-clsr :bookmark-description-complete-clsr
:fediverse-search-complete
:fediverse-account :fediverse-account
:language-codes)) :language-codes))
@ -1794,6 +1795,7 @@
:print-mentions-event :print-mentions-event
:show-announcements-event :show-announcements-event
:check-announcements-event :check-announcements-event
:fediverse-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))
@ -3221,7 +3223,8 @@
:show-parent-post :show-parent-post
:switch-fediverse-account :switch-fediverse-account
:thread-go-to-parent-post :thread-go-to-parent-post
:thread-open-parent-post)) :thread-open-parent-post
:search-fediverse))
(defpackage :scheduled-events (defpackage :scheduled-events
(:use (:use

52
src/program-events.lisp
View File

@ -1964,6 +1964,58 @@
(thread-window:remove-announcements-notification specials:*thread-window*)) (thread-window:remove-announcements-notification specials:*thread-window*))
(windows:draw specials:*thread-window*)) (windows:draw specials:*thread-window*))
(defun query-results-folder-name ()
(_ "query-results"))
(defclass fediverse-query-event (program-event) ())
(defmethod process-event ((object fediverse-query-event))
(flet ((get-results-info (query kind nth-index name-fn)
(let ((results (nth-value nth-index
(api-client:find-results query :kind kind))))
(with-output-to-string (str)
(loop for result in results do
(let ((line (text-utils:join-with-strings* " "
(tooter:url result)
(funcall name-fn result))))
(format str "~a~%" (gemini-parser:geminize-link line))))))))
(with-accessors ((payload payload)) object
(let* ((found-statuses (api-client:find-results payload))
(found-hashtags (get-results-info payload "hashtags" 2 #'tooter:name))
(found-accounts (get-results-info payload "accounts" 1 #'tooter:username))
(query-page (text-utils:strcat (gemini-parser:geminize-h1 (format nil
(_ "Query results~2%")))
(format nil
(n_ "The matching status (~a founds) can be found in folder: ~a, timeline: home~%"
"The matching statuses (~a found) can be found in folder: ~a, timeline: home~%" (length found-statuses))
(length found-statuses)
(query-results-folder-name))
(gemini-parser:geminize-h2 (format nil
(_ "Query: ~a~2%")
payload))
(gemini-parser:geminize-h3 (format nil
(_ "Hashtags~2%")
payload))
found-hashtags
(format nil "~%")
(gemini-parser:geminize-h3 (format nil
(_ "accounts~2%")))
found-accounts)))
(loop for status in found-statuses do
(db:remove-from-status-ignored (tooter:id status)
(query-results-folder-name)
db:+home-timeline+)
(db:update-db status
:folder (query-results-folder-name)
:timeline db:+home-timeline+))
(db:renumber-timeline-message-index db:+home-timeline+
(query-results-folder-name)
:account-id nil)
(push-event (make-instance 'gemini-display-data-page
:window specials:*message-window*
:payload query-page))
(ui:info-message (_ "Search completed"))))))
;;;; end events ;;;; end events
(defun dispatch-program-events () (defun dispatch-program-events ()

13
src/ui-goodies.lisp
View File

@ -3649,7 +3649,7 @@ gemini client certificates!)."
;; NB: db:get-parent-status-row does not take into account the folder or timeline... ;; NB: db:get-parent-status-row does not take into account the folder or timeline...
(generic-parent-row (db:get-parent-status-row status-id)) (generic-parent-row (db:get-parent-status-row status-id))
(generic-parent-id (db:row-message-status-id generic-parent-row)) (generic-parent-id (db:row-message-status-id generic-parent-row))
;; ...so we need to call ;; ...so we need to call
;; db::find-status-id-folder-timeline to get the actual ;; db::find-status-id-folder-timeline to get the actual
;; row for the folder and timeline the user is reading... ;; row for the folder and timeline the user is reading...
(status-parent-row (db::find-status-id-folder-timeline generic-parent-id folder timeline)) (status-parent-row (db::find-status-id-folder-timeline generic-parent-id folder timeline))
@ -3663,3 +3663,14 @@ gemini client certificates!)."
"Move to, select and open parent post" "Move to, select and open parent post"
(thread-go-to-parent-post) (thread-go-to-parent-post)
(thread-open-selected-message)) (thread-open-selected-message))
(defun search-fediverse ()
"Search the fediverse"
(labels ((on-input-complete (query)
(if (string-not-empty-p query)
(push-event (make-instance 'program-events:fediverse-query-event
:payload query))
(error-message (_ "Empty query")))))
(ask-string-input #'on-input-complete
:prompt (_ "Search query: ")
:complete-fn #'complete:fediverse-search-complete)))