2023-10-19 17:49:54 +02:00
;; tinmop: a multiprotocol client
2023-10-19 17:46:22 +02:00
;; Copyright © cage
2020-05-08 15:45:43 +02:00
;; 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/]].
( in-package :program-events )
2020-12-31 11:36:34 +01:00
( define-constant +standard-event-priority+ 10 :test #' = )
( define-constant +minimum-event-priority+ -1 :test #' = )
( define-constant +maximum-event-priority+ -2 :test #' = )
2024-04-06 19:15:15 +02:00
( defparameter *id-lock* ( make-lock "id-event-lock" ) )
2020-05-08 15:45:43 +02:00
( defparameter *event-id* 0 )
;; used only in batch mode from the command line
( defparameter *process-events-immediately* nil
2024-04-06 19:15:15 +02:00
" Should be used only in batch mode from the command line ( but i have
broken this rule rule here and there! ) .
When non nil , instead of pushing the event on a priority queue that
will be picked ( and ran ) by another thread, runs the event
immediately. Be very careful when binding this variable to non nil
value: no code when binding is true can call 'push-event '.
for example
( let ( ( *process-events-immediately* t ) )
( push-event ( make-instance 'function-event
;;;;; vvvvvv !recursive locking!
:payload ( lambda ( ) ( push-event ( make-instance 'an-event ) ) )
:priority , priority ) ) )
will raise an error
instead:
;;;; vvvvv notice the value nil
( let ( ( *process-events-immediately* nil ) )
( push-event ( make-instance 'function-event
:payload ( lambda ( ) ( push-event ( make-instance 'an-event ) ) )
:priority , priority ) ) )
will not.
To clarify this is the implementation of 'push-event ' :
( defun push-event ( event )
( wrapped-in-lock ( *events-queue* )
( if *process-events-immediately*
( process-event event )
( push-element *events-queue* event ) ) ) ) " )
2020-05-08 15:45:43 +02:00
2020-12-31 11:36:34 +01:00
( defparameter *stop-event-dispatching* nil )
2020-05-30 09:53:12 +02:00
2020-12-31 11:36:34 +01:00
( defun stop-event-dispatching ( )
( setf *stop-event-dispatching* t ) )
2020-05-08 15:45:43 +02:00
2020-12-31 11:36:34 +01:00
( defun start-event-dispatching ( )
( setf *stop-event-dispatching* nil ) )
( defun stop-event-dispatching-p ( )
*stop-event-dispatching* )
( defmacro with-stop-event-dispatching ( &body body )
` ( unwind-protect
( progn
( stop-event-dispatching )
,@ body )
( start-event-dispatching ) ) )
2020-06-11 17:28:39 +02:00
2020-05-08 15:45:43 +02:00
;; keep this function stricly monotonic otherwise the order of
;; elements in priority queue is going to be messed up
( defun-w-lock next-id ( ) *id-lock*
( incf *event-id* )
*event-id* )
( defclass program-event ( )
( ( event-id
:initform ( next-id )
:initarg :event-id
:accessor event-id )
( payload
:initform nil
:initarg :payload
:accessor payload )
( priority
:initform +standard-event-priority+
:initarg :priority
2020-05-30 09:53:12 +02:00
:accessor priority )
( notes
:initform nil
:initarg :notes
:accessor notes
:documentation "Someway useful for debugging" ) ) )
2020-05-08 15:45:43 +02:00
( defmethod print-object ( ( object program-event ) stream )
( print-unreadable-object ( object stream :type t :identity nil )
2020-05-30 09:53:12 +02:00
( format stream
"id ~a priority ~a notes ~a"
( event-id object )
( priority object )
( notes object ) ) ) )
2020-05-08 15:45:43 +02:00
2024-04-06 19:15:15 +02:00
( defgeneric process-event ( object )
( :documentation "Process a program event. NB: In the body of this method an event can not recursively push another event, this error can happens expcecially if *process-events-immediately* is bound to true." ) )
2020-05-08 15:45:43 +02:00
2020-09-06 17:28:16 +02:00
#+ debug
( defmethod process-event :before ( object )
( misc:dbg "processing event ~a" object ) )
2020-05-08 15:45:43 +02:00
( defgeneric reinitialize-id ( object ) )
2020-05-30 09:53:12 +02:00
( defmacro wrapped-in-lock ( ( queue ) &body body )
( with-gensyms ( lock )
` ( with-accessors ( ( , lock lock ) ) , queue
2024-02-11 15:08:16 +01:00
( with-lock-held ( , lock )
2020-05-30 09:53:12 +02:00
,@ body ) ) ) )
2020-05-08 15:45:43 +02:00
( defclass events-queue ( priority-queue )
( ( lock
2024-04-06 19:15:15 +02:00
:initform ( make-lock "event-queue-lock" )
2020-05-08 15:45:43 +02:00
:initarg :lock
2023-02-02 16:10:08 +01:00
:accessor lock )
( blocking-lock
2024-04-06 19:15:15 +02:00
:initform ( make-lock "event-blocking-queue-lock" )
2023-02-02 16:10:08 +01:00
:initarg :blocking-lock
:accessor blocking-lock )
( condition-variable
2024-02-11 12:32:22 +01:00
:initform ( make-condition-variable )
2023-02-02 16:10:08 +01:00
:initarg :condition-variable
:accessor condition-variable ) ) )
2020-05-08 15:45:43 +02:00
( defun queue-compare-predicate ( a b )
( let ( ( same-priority-p ( = ( priority a )
( priority b ) ) ) )
2020-07-06 16:11:34 +02:00
( cond
( ( = ( priority a ) +minimum-event-priority+ )
nil )
( ( = ( priority b ) +minimum-event-priority+ )
t )
( ( = ( priority a ) +maximum-event-priority+ )
t )
( ( = ( priority b ) +maximum-event-priority+ )
nil )
( same-priority-p
( < ( event-id a )
( event-id b ) ) )
( t
( < ( priority a )
( priority b ) ) ) ) ) )
2020-05-08 15:45:43 +02:00
( defun queue-equals-predicate ( a b )
( = ( event-id a )
( event-id b ) ) )
( defmethod initialize-instance :after ( ( object events-queue ) &key &allow-other-keys )
( with-accessors ( ( key-function key-function )
( compare-function compare-function )
( equal-function equal-function ) ) object
( setf key-function #' identity )
( setf equal-function #' queue-equals-predicate )
( setf compare-function #' queue-compare-predicate ) ) )
( defparameter *events-queue* ( make-instance 'events-queue ) )
2020-05-30 09:53:12 +02:00
( defmethod reinitialize-id ( ( object program-event ) )
( wrapped-in-lock ( *events-queue* )
( setf ( event-id object )
( next-id ) )
object ) )
2023-02-02 16:10:08 +01:00
( defun pop-event-block ( )
2024-02-11 15:08:16 +01:00
( with-lock-held ( ( blocking-lock *events-queue* ) )
2023-02-02 16:10:08 +01:00
( loop while ( emptyp *events-queue* )
do
2024-02-11 12:32:22 +01:00
( condition-wait ( condition-variable *events-queue* )
2023-02-02 16:10:08 +01:00
( blocking-lock *events-queue* ) ) )
( pop-element *events-queue* ) ) )
( defun push-event-unblock ( value )
2024-02-11 15:08:16 +01:00
( with-lock-held ( ( blocking-lock *events-queue* ) )
2023-02-02 16:10:08 +01:00
( push-element *events-queue* value )
2024-02-11 12:32:22 +01:00
( condition-notify ( condition-variable *events-queue* ) ) ) )
2023-02-02 16:10:08 +01:00
2020-05-08 15:45:43 +02:00
( defun push-event ( event )
( wrapped-in-lock ( *events-queue* )
( if *process-events-immediately*
( process-event event )
( push-element *events-queue* event ) ) ) )
( defun pop-event ( )
( wrapped-in-lock ( *events-queue* )
( pop-element *events-queue* ) ) )
( defun remove-event ( event )
( wrapped-in-lock ( *events-queue* )
( remove-element *events-queue* event ) ) )
( defun find-event ( event &key ( key-fn #' identity ) ( test-fn #' eq ) )
( wrapped-in-lock ( *events-queue* )
( find-element *events-queue* event :test-fn test-fn :key-fn key-fn ) ) )
( defun no-events-p ( )
( wrapped-in-lock ( *events-queue* )
( emptyp *events-queue* ) ) )
( defun event-available-p ( )
( not ( no-events-p ) ) )
( defun count-events ( predicate )
( wrapped-in-lock ( *events-queue* )
( count-elements-if *events-queue* predicate :key-fn #' identity ) ) )
2020-09-30 16:36:34 +02:00
( defun remove-event-if ( predicate )
( wrapped-in-lock ( *events-queue* )
( remove-element-if *events-queue* predicate ) ) )
2023-12-07 17:47:00 +01:00
( defun map-events ( fn &key ( lock-queue t ) )
( if lock-queue
( wrapped-in-lock ( *events-queue* )
( map-elements *events-queue* fn ) )
( map-elements *events-queue* fn ) ) )
2020-09-30 18:24:58 +02:00
2023-01-15 15:56:00 +01:00
;;;; generic events
( defclass function-event ( program-event ) ( ) )
( defmethod process-event ( ( object function-event ) )
( with-accessors ( ( payload payload ) ) object
( assert ( functionp payload ) )
( funcall payload ) ) )
( defmacro with-enqueued-process ( ( &optional ( priority +standard-event-priority+ ) ) &body body )
` ( push-event ( make-instance 'function-event
:payload ( lambda ( ) ,@ body )
:priority , priority ) ) )
2023-02-09 16:28:53 +01:00
( defmacro with-enqueued-process-and-unblock ( ( &optional ( priority +standard-event-priority+ ) ) &body body )
` ( push-event-unblock ( make-instance 'function-event
:payload ( lambda ( ) ,@ body )
:priority , priority ) ) )
2020-05-08 15:45:43 +02:00
( defclass event-on-own-thread ( program-event )
( ( lock
2024-02-11 12:32:22 +01:00
:initform ( make-lock )
2020-05-08 15:45:43 +02:00
:initarg :lock
:accessor lock )
( condition-variable
2024-02-11 12:32:22 +01:00
:initform ( make-condition-variable )
2020-05-08 15:45:43 +02:00
:initarg :condition-variable
:accessor condition-variable ) )
( :documentation " This is the parent of all events that are
2023-01-15 15:56:00 +01:00
generated in a thread that is not the main thread, contains a
2020-05-08 15:45:43 +02:00
condition variable and associated lock " ) )
2023-01-15 15:56:00 +01:00
( defclass blocking-caller-event ( event-on-own-thread function-event )
( ( results
2023-03-24 10:46:54 +01:00
:initform ( make-instance 'box:box :contents :nothing )
2023-01-15 15:56:00 +01:00
:initarg :results
:accessor results ) ) )
( defmethod process-event ( ( object blocking-caller-event ) )
( with-accessors ( ( lock lock )
( condition-variable condition-variable )
( callback payload )
( results results ) ) object
2023-03-11 12:42:46 +01:00
( handler-case
( progn
( setf ( box:unbox results ) ( funcall callback ) )
2024-02-11 15:08:16 +01:00
( with-lock-held ( lock )
2024-02-11 12:32:22 +01:00
( condition-notify condition-variable ) ) )
2023-03-11 12:42:46 +01:00
( error ( e )
( setf ( box:unbox results ) e )
2024-02-11 15:08:16 +01:00
( with-lock-held ( lock )
2024-02-11 12:32:22 +01:00
( condition-notify condition-variable ) ) ) ) ) )
2023-01-15 15:56:00 +01:00
2023-02-09 17:04:29 +01:00
( defun push-function-and-wait-results ( fn &key
( priority +standard-event-priority+ )
( push-event-fn #' push-event ) )
( let* ( ( event ( make-instance 'blocking-caller-event
:payload fn
:priority priority ) )
2023-01-15 15:56:00 +01:00
( lock ( lock event ) )
( condition-variable ( condition-variable event ) ) )
2023-02-09 17:04:29 +01:00
( funcall push-event-fn event )
2024-02-11 15:08:16 +01:00
( with-lock-held ( lock )
2023-01-15 15:56:00 +01:00
( loop
2023-03-24 10:46:54 +01:00
while ( eq ( box:unbox ( results event ) ) :nothing )
2023-01-15 15:56:00 +01:00
do
2024-02-11 12:32:22 +01:00
( condition-wait condition-variable lock ) ) )
2023-03-11 12:42:46 +01:00
( let* ( ( event-results ( results event ) )
( actual-results ( box:unbox event-results ) ) )
( if ( typep actual-results 'error )
( error actual-results )
actual-results ) ) ) )
2023-01-15 15:56:00 +01:00
;;;;
2020-05-08 15:45:43 +02:00
( defclass ask-user-input-string-event ( event-on-own-thread )
( ( prompt
:initform +default-command-prompt+
:initarg :prompt
:accessor prompt )
( initial-value
:initform nil
:initarg :initial-value
:accessor initial-value )
2020-08-15 14:58:54 +02:00
( echo-character
:initform nil
:initarg :echo-character
:accessor echo-character )
2020-05-08 15:45:43 +02:00
( complete-fn
:initform nil
:initarg :complete-fn
:accessor complete-fn ) )
( :documentation " This events, when processed, will prepare the
command-window ` specials:*command-window* ' to ask for user
2024-03-01 14:57:36 +01:00
input. The most important thing is that the process-event will bind
2020-05-08 15:45:43 +02:00
the slot ` command-window:event-to-answer ' with this events and will
2024-03-01 14:57:36 +01:00
bind the slot ` payload ' of this events with the user provided
string. " ) )
2020-05-08 15:45:43 +02:00
( defmethod initialize-instance :after ( ( object ask-user-input-string-event )
2020-06-27 22:43:13 +02:00
&key ( forced-priority nil ) &allow-other-keys )
( if forced-priority
2020-09-18 22:27:11 +02:00
( setf ( priority object ) forced-priority )
( setf ( priority object ) ( truncate ( / +standard-event-priority+ 2 ) ) ) ) )
2020-05-08 15:45:43 +02:00
( defmethod process-event ( ( object ask-user-input-string-event ) )
2020-08-15 14:58:54 +02:00
( with-accessors ( ( prompt prompt )
( initial-value initial-value )
( complete-fn complete-fn )
( echo-character echo-character ) ) object
2020-05-08 15:45:43 +02:00
( setf ( command-window:event-to-answer specials:*command-window* )
object )
( setf ( point-tracker:prompt specials:*command-window* )
prompt )
2020-06-27 22:43:13 +02:00
( command-window:remove-messages specials:*command-window* )
2020-05-08 15:45:43 +02:00
( setf complete:*complete-function* complete-fn )
( command-window:set-string-mode specials:*command-window* )
( command-window:set-history-most-recent specials:*command-window* prompt )
( setf ( command-window:command-line specials:*command-window* )
initial-value )
( point-tracker:move-point-to-end specials:*command-window* initial-value )
2020-08-15 14:58:54 +02:00
( setf ( command-window:echo-character specials:*command-window* )
echo-character )
( windows:draw specials:*command-window* ) ) )
2020-05-08 15:45:43 +02:00
( defclass user-input-string-event ( ask-user-input-string-event )
( )
( :documentation " When user provided a string as this event is
2020-05-31 16:49:26 +02:00
generated. When processed it just will notify the condition variable
2020-05-08 15:45:43 +02:00
of the slots ` command-window:event-to-answer ' in the object
` specials:*command-window* ' so that the callee thread can restart
the computation with the input. " ) )
( defmethod initialize-instance :after ( ( object user-input-string-event )
&key &allow-other-keys )
( setf ( priority object ) ( truncate ( / +standard-event-priority+ 2 ) ) ) )
( defmethod process-event ( ( object user-input-string-event ) )
( with-accessors ( ( lock lock )
( condition-variable condition-variable ) ) object
2020-08-15 14:58:54 +02:00
( setf ( command-window:echo-character specials:*command-window* )
2022-02-11 14:12:02 +01:00
:completed )
2024-02-11 15:08:16 +01:00
( with-lock-held ( lock )
2024-02-11 12:32:22 +01:00
( condition-notify condition-variable ) ) ) )
2020-05-08 15:45:43 +02:00
( defclass notify-user-event ( program-event )
( ( added-to-pending-p
:initform nil
:initarg :added-to-pending
:reader added-to-pending-p
:writer ( setf added-to-pending ) )
( life
:initform nil
:initarg :life
:accessor life )
( notify-error
:initform nil
:initarg :notify-error
:accessor notify-error ) ) )
( defun notify-user-event-p ( a )
( typep a 'notify-user-event ) )
( defmethod process-event ( ( object notify-user-event ) )
( with-accessors ( ( added-to-pending-p added-to-pending-p )
( notify-error notify-error ) ) object
( let ( ( other-notification-win ( first ( mtree:find-child-if specials:*main-window*
#' notify-window:notify-window-p ) ) )
( pending-before ( count-events #' notify-user-event-p ) ) )
( if ( null other-notification-win )
( let* ( ( life ( or ( life object )
( swconf:config-notification-life ) ) )
( notify-win ( notify-window:make-notification-window ( payload object )
life
:pending
pending-before
:notify-error
notify-error ) ) )
( notify-window:draw-pending notify-win ) )
( progn
( when ( not added-to-pending-p )
( setf ( notify-window:pending other-notification-win )
( 1+ pending-before ) )
( notify-window:draw-pending other-notification-win )
( setf ( added-to-pending object ) t ) )
( progn
( setf ( event-id object ) ; id must be monotonic, so we need to give the event a new one
( next-id ) )
( push-event object ) ) ) ) ) ) )
( defclass remove-notify-user-event ( program-event ) ( ) )
( defmethod process-event ( ( object remove-notify-user-event ) )
( let ( ( win ( payload object ) ) )
( mtree:remove-child specials:*main-window* win ) ) )
2021-11-12 19:11:28 +01:00
( defclass change-window-title-event ( program-event )
( ( window
:initform nil
:initarg :window
:accessor window ) ) )
( defmethod process-event ( ( object change-window-title-event ) )
( with-accessors ( ( title payload )
( window window ) ) object
2022-03-21 21:42:50 +01:00
( setf ( windows::title window ) title ) ) )
2021-11-12 19:11:28 +01:00
2020-06-11 17:28:39 +02:00
( define-constant +max-recover-count+ 3 )
2020-05-14 16:49:05 +02:00
( defclass save-timeline-in-db-event ( program-event )
2020-06-11 17:28:39 +02:00
( ( kind
:initform nil
:initarg :kind
:accessor kind )
( timeline-type
:initform nil
:initarg :timeline-type
:accessor timeline-type )
2020-05-08 15:45:43 +02:00
( folder
2020-06-11 17:28:39 +02:00
:initform nil
:initarg :folder
:accessor folder )
2020-05-08 15:45:43 +02:00
( local
2020-06-11 17:28:39 +02:00
:initform nil
:initarg :localp
:reader localp
:writer ( setf local ) )
2020-05-08 15:45:43 +02:00
( min-id
2020-06-11 17:28:39 +02:00
:initform nil
:initarg :min-id
:accessor min-id )
( max-id
:initform nil
:initarg :max-id
:accessor max-id )
( recover-from-skipped-statuses
:initform nil
:initarg :recover-from-skipped-statuses
:reader recover-from-skipped-statuses-p
:writer recover-from-skipped-statuses )
( recover-count
:initform 0
:initarg :recover-count
2021-06-13 14:07:47 +02:00
:accessor recover-count )
( force-saving-of-ignored-status
:initform nil
:initarg :force-saving-of-ignored-status
:reader force-saving-of-ignored-status-p
:writer ( setf force-saving-of-ignored-status ) ) ) )
2020-05-08 15:45:43 +02:00
2020-05-14 16:49:05 +02:00
( defmethod process-event ( ( object save-timeline-in-db-event ) )
2020-05-08 15:45:43 +02:00
"Update a timeline, save messages, performs topological sorts"
2020-06-11 17:28:39 +02:00
( let ( ( statuses ( payload object ) )
( ignored-count 0 ) )
2021-06-13 14:07:47 +02:00
( with-accessors ( ( timeline-type timeline-type )
( folder folder )
( min-id min-id )
( max-id max-id )
( kind kind )
( recover-count recover-count )
( force-saving-of-ignored-status-p force-saving-of-ignored-status-p ) ) object
2020-06-11 17:28:39 +02:00
#+ debug-mode
( let ( ( dump ( with-output-to-string ( stream )
( mapcar ( lambda ( toot ) ( tooter::present toot stream ) )
statuses ) ) ) )
( dbg "statuses ~a" dump ) )
( loop for status in statuses do
2023-10-27 18:15:32 +02:00
( let* ( ( account-id ( tooter:id ( tooter:account status ) ) )
( status-id ( tooter:id status ) )
( rebloggedp ( tooter:parent status ) )
( language ( if rebloggedp
( tooter:language ( tooter:parent status ) )
( tooter:language status ) ) )
( tags ( if rebloggedp
( db::concat-tags ( tooter:parent status ) )
( db::concat-tags status ) ) )
( skip-this-status nil ) )
2021-06-13 14:07:47 +02:00
( when force-saving-of-ignored-status-p
( db:remove-from-status-ignored status-id folder timeline-type ) )
( when ( or ( and ( db:user-ignored-p account-id )
( not ( db:status-skipped-p status-id folder timeline-type ) ) )
2021-10-13 15:01:15 +02:00
( and language
2023-09-24 11:07:07 +02:00
( not ( cl-ppcre:scan ( swconf:config-post-allowed-language )
( string-downcase ( string language ) ) ) ) )
2022-11-18 18:01:19 +01:00
( and rebloggedp
( db:boost-ignored-p account-id ) )
2022-11-29 18:55:03 +01:00
( and ( text-utils:string-not-empty-p tags )
( db:tags-ignored-p tags ) )
2021-06-13 14:07:47 +02:00
( hooks:run-hook-until-success 'hooks:*skip-message-hook*
status
timeline-type
folder
kind
( localp object ) ) )
( db:add-to-status-skipped status-id folder timeline-type )
( setf skip-this-status t )
( incf ignored-count ) )
( when ( not skip-this-status )
( db:update-db status
:timeline timeline-type
:folder folder
:skip-ignored-p t ) ) ) )
2020-06-11 17:28:39 +02:00
( db:renumber-timeline-message-index timeline-type
folder
:account-id nil )
( when ( and recover-count
( < recover-count +max-recover-count+ )
( > ignored-count 0 )
( recover-from-skipped-statuses-p object ) )
( let ( ( going-backward max-id )
( going-forward ( or ( and ( null max-id )
( null min-id ) )
min-id ) ) )
( cond
( going-forward
( ui:update-current-timeline ( 1+ recover-count ) ) )
( going-backward
( ui:update-current-timeline-backwards ( 1+ recover-count ) ) ) ) ) ) ) ) )
2020-05-08 15:45:43 +02:00
( defclass fetch-remote-status-event ( program-event ) ( ) )
( defmethod process-event ( ( object fetch-remote-status-event ) )
( let ( ( status ( payload object ) ) )
#+ debug-mode
( let ( ( dump ( with-output-to-string ( stream )
( tooter::present status stream ) ) ) )
( dbg "fetch single status ~a" dump ) )
( db:update-db status ) ) )
2020-12-29 13:01:59 +01:00
( defparameter *search-next-saved-event* nil )
( defclass search-event ( program-event ) ( ) )
2021-01-02 11:29:46 +01:00
( defun search-event-p ( a )
( typep a 'search-event ) )
2020-12-29 13:01:59 +01:00
( defmethod process-event :before ( ( object search-event ) )
( setf *search-next-saved-event* object ) )
( defclass search-next-event ( program-event ) ( ) )
( defmethod process-event ( ( object search-next-event ) )
2021-01-02 11:29:46 +01:00
( when ( search-event-p *search-next-saved-event* )
( push-event *search-next-saved-event* ) ) )
2020-12-29 13:01:59 +01:00
( defclass search-regex-message-content-event ( search-event ) ( ) )
2020-05-08 15:45:43 +02:00
( defmethod process-event ( ( object search-regex-message-content-event ) )
2021-05-06 17:10:37 +02:00
( let ( ( regexp ( payload object ) )
( win specials:*message-window* ) )
2021-05-13 15:32:31 +02:00
( when ( text-utils:string-not-empty-p regexp )
( handler-case
( let ( ( scanner ( cl-ppcre:create-scanner regexp :case-insensitive-mode t ) ) )
( message-window:search-regex win scanner ) )
( cl-ppcre:ppcre-syntax-error ( )
( ui:error-message ( _ "Invalid regular expression" ) ) ) ) ) ) )
2020-05-08 15:45:43 +02:00
2021-11-06 12:32:03 +01:00
( defclass search-message-gemini-fragment-event ( search-event ) ( ) )
( defmethod process-event ( ( object search-message-gemini-fragment-event ) )
( let ( ( fragment ( payload object ) ) )
( message-window:search-gemini-fragment specials:*message-window* fragment ) ) )
2020-12-29 13:01:59 +01:00
( defclass thread-search-event ( search-event )
2020-05-08 15:45:43 +02:00
( ( search-direction
:initform nil
:initarg :search-direction
:accessor search-direction ) ) )
( defclass thread-search-message-body-event ( thread-search-event ) ( ) )
( defmethod process-event ( ( object thread-search-message-body-event ) )
( let ( ( text-looking-for ( payload object ) )
( search-direction ( search-direction object ) ) )
( if ( eq :next search-direction )
( thread-window:search-next-message-body specials:*thread-window* text-looking-for )
( thread-window:search-previous-message-body specials:*thread-window* text-looking-for ) ) ) )
( defclass thread-search-message-meta-event ( thread-search-event ) ( ) )
( defmethod process-event ( ( object thread-search-message-meta-event ) )
( let ( ( text-looking-for ( payload object ) )
( search-direction ( search-direction object ) ) )
( if ( eq :next search-direction )
( thread-window:search-next-message-meta specials:*thread-window* text-looking-for )
( thread-window:search-previous-message-meta specials:*thread-window* text-looking-for ) ) ) )
2021-12-12 21:40:59 +01:00
( defclass filesystem-tree-search-message-event ( search-event ) ( ) )
( defmethod process-event ( ( object filesystem-tree-search-message-event ) )
( let ( ( text-looking-for ( payload object ) ) )
( line-oriented-window::search-row specials:*filesystem-explorer-window* text-looking-for ) ) )
2020-12-29 13:01:59 +01:00
( defclass thread-goto-message ( program-event ) ( ) )
( defmethod process-event ( ( object thread-goto-message ) )
( let ( ( message-index ( payload object ) ) )
( thread-window:goto-message specials:*thread-window* message-index ) ) )
2020-05-08 15:45:43 +02:00
( defclass delete-all-status-event ( program-event ) ( ) )
( defmethod process-event ( ( object delete-all-status-event ) )
2021-03-21 14:36:47 +01:00
;; do not change the order. Forget, then delete.
( let ( ( timelines/folders-with-forgotten ( db:forget-all-statuses-marked-deleted ) ) )
( db:delete-all-statuses-marked-deleted )
( db:renumber-all-timelines timelines/folders-with-forgotten ) ) )
2020-05-08 15:45:43 +02:00
( defclass quit-program-event ( program-event ) ( ) )
( defmethod process-event ( ( object quit-program-event ) )
( ui:quit-program ) )
( defclass error-message-event ( program-event ) ( ) )
( defmethod process-event ( ( object error-message-event ) )
( command-window:add-error-message specials:*command-window* ( payload object ) ) )
( defclass info-message-event ( program-event ) ( ) )
( defmethod process-event ( ( object info-message-event ) )
( command-window:add-info-message specials:*command-window* ( payload object ) ) )
( defclass dialog-event ( program-event )
( ( buttons
:initform nil
:initarg :buttons
:accessor buttons )
( title
:initform nil
:initarg :title
:accessor title ) ) )
( defclass error-dialog-event ( dialog-event )
( ( buttons
:initform nil
:initarg :buttons
:accessor buttons )
( title
:initform nil
:initarg :title
:accessor title ) ) )
( defmethod process-event ( ( object error-dialog-event ) )
( let ( ( dialog-window ( windows:make-error-message-dialog specials:*main-window*
( title object )
( payload object )
( buttons object ) ) ) )
2023-01-30 20:49:57 +01:00
( windows:menu-select dialog-window :force-show-cursor nil ) ) )
2020-05-08 15:45:43 +02:00
( defclass info-dialog-event ( dialog-event ) ( ) )
( defmethod process-event ( ( object info-dialog-event ) )
( let ( ( dialog-window ( windows:make-info-message-dialog specials:*main-window*
( title object )
( payload object )
( buttons object ) ) ) )
2023-01-30 20:49:57 +01:00
( windows:menu-select dialog-window :force-show-cursor nil ) ) )
2020-05-08 15:45:43 +02:00
( defclass move-selected-tree-event ( program-event )
( ( new-folder
:initform nil
:initarg :new-folder
:accessor new-folder ) ) )
( defmethod process-event ( ( object move-selected-tree-event ) )
( let ( ( selected-fields ( line-oriented-window:selected-row-fields
specials:*thread-window* ) ) )
( if selected-fields
( db:move-tree-to-folder ( db:row-message-timeline selected-fields )
( db:row-message-folder selected-fields )
( db:row-message-index selected-fields )
( new-folder object ) )
( ui:error-message ( _ "No message selected!" ) ) ) ) )
( defclass event-with-message-index ( )
( ( message-index
:initform db:+message-index-start+
:initarg :message-index
:accessor message-index ) ) )
2021-09-10 17:34:03 +02:00
( defclass event-with-message-status-id ( )
( ( message-status-id
:initform nil
:initarg :message-status-id
:accessor message-status-id ) ) )
2020-05-08 15:45:43 +02:00
( defclass event-with-timeline-and-folder ( )
( ( new-folder
:initform nil
:initarg :new-folder
:accessor new-folder )
( new-timeline
:initform nil
:initarg :new-timeline
:accessor new-timeline ) ) )
( defclass refresh-thread-windows-event ( program-event
event-with-message-index
2021-09-10 17:34:03 +02:00
event-with-message-status-id
2020-05-08 15:45:43 +02:00
event-with-timeline-and-folder )
( ) )
( defmethod process-event ( ( object refresh-thread-windows-event ) )
2021-09-10 17:34:03 +02:00
( with-accessors ( ( new-folder new-folder )
( new-timeline new-timeline )
( message-index message-index )
( message-status-id message-status-id ) ) object
2020-05-08 15:45:43 +02:00
( assert message-index )
( when new-timeline
( setf ( thread-window:timeline-type specials:*thread-window* )
new-timeline ) )
( when new-folder
( setf ( thread-window:timeline-folder specials:*thread-window* )
new-folder ) )
( line-oriented-window:resync-rows-db specials:*thread-window*
2021-09-10 17:34:03 +02:00
:suggested-status-id message-status-id
2020-05-08 15:45:43 +02:00
:suggested-message-index message-index
:redraw t ) ) )
( defun change-status-values ( event function-change )
( with-accessors ( ( payload payload )
( message-index message-index ) ) event
( when-let ( ( status-to-change payload ) )
( funcall function-change status-to-change )
( client:fetch-remote-status status-to-change )
( let* ( ( refresh-event ( make-instance 'refresh-thread-windows-event
:message-index message-index ) ) )
( push-event refresh-event ) ) ) ) )
( defclass favourite-status-event ( program-event event-with-message-index ) ( ) )
( defmethod process-event ( ( object favourite-status-event ) )
2020-05-14 18:14:28 +02:00
( tui:with-notify-errors
2020-05-08 15:45:43 +02:00
( change-status-values object #' api-client:favourite-status ) ) )
( defclass unfavourite-status-event ( program-event event-with-message-index ) ( ) )
( defmethod process-event ( ( object unfavourite-status-event ) )
2020-05-14 18:14:28 +02:00
( tui:with-notify-errors
2020-05-08 15:45:43 +02:00
( change-status-values object #' api-client:unfavourite-status ) ) )
( defclass reblog-status-event ( program-event event-with-message-index ) ( ) )
( defmethod process-event ( ( object reblog-status-event ) )
2020-05-14 18:14:28 +02:00
( tui:with-notify-errors
2020-09-14 20:52:19 +02:00
( flet ( ( boost ( status-id )
( let* ( ( status ( db:find-status-id status-id ) )
( status-id-to-boost ( db:row-message-reblog-id status ) ) )
( if status-id-to-boost
( api-client:reblog-status status-id-to-boost )
( api-client:reblog-status status-id ) ) ) ) )
( change-status-values object #' boost ) ) ) )
2020-05-08 15:45:43 +02:00
( defclass unreblog-status-event ( program-event event-with-message-index ) ( ) )
( defmethod process-event ( ( object unreblog-status-event ) )
2020-05-14 18:14:28 +02:00
( tui:with-notify-errors
2020-05-08 15:45:43 +02:00
( change-status-values object #' api-client:unreblog-status ) ) )
( defclass unignore-user-event ( program-event ) ( ) )
( defmethod process-event ( ( object unignore-user-event ) )
( let ( ( username ( payload object ) ) )
( db:unignore-author username ) ) )
2023-09-19 19:50:58 +02:00
( defclass send-message-change-language-event ( program-event ) ( ) )
( defmethod process-event ( ( object send-message-change-language-event ) )
( let ( ( new-language ( payload object ) ) )
( setf ( sending-message:language ( sending-message:message-data specials:*send-message-window* ) )
new-language )
( windows:draw specials:*send-message-window* ) ) )
2020-05-08 15:45:43 +02:00
( defclass send-message-change-subject-event ( program-event ) ( ) )
( defmethod process-event ( ( object send-message-change-subject-event ) )
( let ( ( new-subject ( payload object ) ) )
( setf ( sending-message:subject ( sending-message:message-data specials:*send-message-window* ) )
new-subject )
( windows:draw specials:*send-message-window* ) ) )
( defclass send-message-change-visibility-event ( program-event ) ( ) )
( defmethod process-event ( ( object send-message-change-visibility-event ) )
( let ( ( new-visibility ( payload object ) )
( message-data ( sending-message:message-data specials:*send-message-window* ) ) )
( setf ( sending-message:visibility message-data ) new-visibility )
( windows:draw specials:*send-message-window* ) ) )
( defclass open-send-message-window-event ( program-event ) ( ) )
( defmethod process-event ( ( object open-send-message-window-event ) )
( let ( ( message-data ( payload object ) ) )
( sending-message:init message-data specials:*main-window* )
2020-05-09 21:58:12 +02:00
( ui:focus-to-send-message-window :print-message nil )
2020-05-08 15:45:43 +02:00
( windows:draw specials:*send-message-window* ) ) )
2020-09-18 16:32:04 +02:00
( defclass send-message-change-mentions-event ( program-event ) ( ) )
( defmethod process-event ( ( object send-message-change-mentions-event ) )
( let ( ( new-mentions ( payload object ) )
( message-data ( sending-message:message-data specials:*send-message-window* ) ) )
( setf ( sending-message:mentions message-data ) new-mentions )
( windows:draw specials:*send-message-window* ) ) )
2020-05-08 15:45:43 +02:00
( defclass send-message-add-attachment-event ( program-event ) ( ) )
2022-05-01 12:22:52 +02:00
( defstruct attachment
( path )
( alt-text ) )
2020-05-08 15:45:43 +02:00
( defmethod process-event ( ( object send-message-add-attachment-event ) )
( with-accessors ( ( croatoan-window windows:croatoan-window ) ) specials:*send-message-window*
2022-05-01 12:22:52 +02:00
( let* ( ( new-attachment ( attachment-path ( payload object ) ) )
( alt-text ( attachment-alt-text ( payload object ) ) )
2020-05-08 15:45:43 +02:00
( fg ( croatoan:fgcolor croatoan-window ) )
( bg ( croatoan:bgcolor croatoan-window ) )
( line ( make-instance 'line-oriented-window:line
:normal-text new-attachment
:selected-text new-attachment
2022-05-01 12:22:52 +02:00
:fields ( list :path
new-attachment
:alt-text
alt-text )
2020-05-08 15:45:43 +02:00
:normal-bg bg
:normal-fg fg
:selected-bg fg
2021-04-08 15:13:31 +02:00
:selected-fg bg ) )
( win specials:*send-message-window* ) )
( line-oriented-window:append-new-rows win line )
2020-05-08 15:45:43 +02:00
( line-oriented-window:unselect-all specials:*send-message-window* )
( line-oriented-window:select-row specials:*send-message-window* 0 )
( windows:draw specials:*send-message-window* ) ) ) )
( defclass send-message-event ( program-event )
( ( use-ui-notification
:initform nil
:initarg :use-ui-notification
:reader use-ui-notification-p
:writer use-ui-notification ) ) )
2023-09-13 18:07:29 +02:00
( defmacro with-sending-message-data ( ( message-body subject
reply-to mentions
visibility language )
2022-04-06 19:34:49 +02:00
&body body )
( with-gensyms ( send-win message-data )
` ( let ( ( , send-win specials:*send-message-window* ) )
( with-accessors ( ( , message-data sending-message:message-data ) ) , send-win
( with-accessors ( ( , message-body sending-message:body )
( , subject sending-message:subject )
( , reply-to sending-message:reply-to )
( , mentions sending-message:mentions )
2023-09-13 18:07:29 +02:00
( , visibility sending-message:visibility )
( , language sending-message:language ) ) , message-data
2022-04-06 19:34:49 +02:00
,@ body ) ) ) ) )
2020-05-08 15:45:43 +02:00
( defmethod process-event ( ( object send-message-event ) )
2021-04-08 15:13:31 +02:00
( let ( ( send-win specials:*send-message-window* ) )
2023-09-13 18:07:29 +02:00
( with-sending-message-data ( body subject reply-to mentions visibility language )
2022-04-06 19:34:49 +02:00
( let* ( ( attachments ( line-oriented-window:map-rows send-win
2022-05-01 12:22:52 +02:00
#' line-oriented-window:normal-text ) )
( alt-text ( line-oriented-window:map-rows send-win
( lambda ( row )
( getf ( line-oriented-window:fields row )
:alt-text ) ) ) ) )
2022-04-06 19:34:49 +02:00
( hooks:run-hook 'hooks:*before-sending-message* object )
( msg-utils:maybe-crypt-message send-win
:notify-cant-crypt ( use-ui-notification-p object ) )
( let ( ( exceeding-characters ( ui:message-exceeds-server-limit-p body ) ) )
( if exceeding-characters
( ui:exceeding-characters-notify exceeding-characters )
( let ( ( actual-message-body ( if ( text-utils:string-not-empty-p mentions )
( format nil
"~a~a~%~a"
+mention-prefix+
mentions
body )
body ) ) )
2024-03-31 18:53:23 +02:00
( tui:with-notify-errors
( client:send-status actual-message-body
reply-to
attachments
alt-text
subject
( make-keyword ( string-upcase visibility ) )
language )
( ui:notify ( _ "Message sent" ) ) )
2022-04-06 19:34:49 +02:00
( ui:close-send-message-window ) ) ) ) ) ) ) )
2020-05-08 15:45:43 +02:00
2020-12-21 12:11:15 +01:00
( defun find-user-id-from-exact-acct ( username )
2021-07-10 17:15:09 +02:00
( when-let* ( ( remote-accounts-matching ( api-client:search-user username
:limit 100
:resolve t ) )
2021-06-25 20:59:02 +02:00
( matched-account ( find-if ( lambda ( a )
( string= ( tooter:account-name a )
username ) )
remote-accounts-matching ) ) )
2021-06-26 12:18:03 +02:00
( values ( tooter:id matched-account )
2022-12-09 13:39:32 +01:00
username
matched-account ) ) )
2020-12-21 12:11:15 +01:00
( defmacro with-process-follower ( ( username user-id
2021-11-16 10:15:06 +01:00
&optional
( local-complete-username-fn #' db:all-unfollowed-usernames ) )
2020-12-21 12:11:15 +01:00
&body body )
` ( tui:with-notify-errors
( let ( ( , user-id nil ) )
( if ( find , username ( , local-complete-username-fn ) :test #' string= )
( setf , user-id ( db:acct->id , username ) )
( setf , user-id ( find-user-id-from-exact-acct , username ) ) )
( if , user-id
( progn ,@ body )
( error ( format nil ( _ "Unable to find user ~a" ) , username ) ) ) ) ) )
2020-05-08 15:45:43 +02:00
( defclass follow-user-event ( program-event ) ( ) )
( defmethod process-event ( ( object follow-user-event ) )
2021-11-16 10:15:06 +01:00
( with-accessors ( ( username payload ) ) object
2021-11-16 15:43:08 +01:00
( with-process-follower ( username user-id db:all-unfollowed-usernames )
2022-12-09 13:39:32 +01:00
( let ( ( user-object ( nth-value 2 ( find-user-id-from-exact-acct username ) ) ) )
( if user-object
( progn
( db:update-db user-object )
( client:follow-user user-id )
( db:add-to-followers user-id )
( ui:notify ( format nil ( _ "Followed ~a" ) username ) ) )
( ui:notify ( format nil ( _ "User ~a not found on the server" ) username )
:as-error t ) ) ) ) ) )
2020-05-08 15:45:43 +02:00
( defclass unfollow-user-event ( program-event ) ( ) )
( defmethod process-event ( ( object unfollow-user-event ) )
2021-11-16 10:15:06 +01:00
( with-accessors ( ( username payload ) ) object
( with-process-follower ( username user-id db:all-followed-usernames )
( client:unfollow-user user-id )
( db:remove-from-followers user-id )
( ui:notify ( format nil ( _ "Unfollowed ~a" ) username ) ) ) ) )
2020-05-08 15:45:43 +02:00
( defclass open-follow-requests-window-event ( program-event ) ( ) )
( defmethod process-event ( ( object open-follow-requests-window-event ) )
2020-05-14 18:14:28 +02:00
( tui:with-notify-errors
2020-05-08 15:45:43 +02:00
( multiple-value-bind ( accounts usernames )
( api-client:follow-requests )
( when accounts
( follow-requests:init accounts usernames specials:*main-window* )
( ui:focus-to-follow-requests-window )
( windows:draw specials:*follow-requests-window* ) ) ) ) )
( defclass subscribe-tags-event ( program-event ) ( ) )
( defmethod process-event ( ( object subscribe-tags-event ) )
( when-let* ( ( tags ( payload object ) ) )
( loop for tag in ( cl-ppcre:split db:+tag-separator+ tags ) do
( db:subscribe-to-tag tag ) ) ) )
( defclass unsubscribe-tags-event ( program-event ) ( ) )
( defmethod process-event ( ( object unsubscribe-tags-event ) )
( when-let* ( ( tag ( payload object ) ) )
( db:unsubscribe-to-tag tag ) ) )
( defclass update-last-refresh-subscribe-tags-event ( program-event ) ( ) )
( defmethod process-event ( ( object update-last-refresh-subscribe-tags-event ) )
( db:update-last-seen-status-subscribed-tag ) )
( defclass notify-fetched-new-tag-messages-event ( program-event ) ( ) )
( defmethod process-event ( ( object notify-fetched-new-tag-messages-event ) )
( loop for tag in ( db:all-tags-with-new-message-fetched ) do
( let ( ( message ( format nil
( _ "Downloaded new messages for tag ~a" )
( db:tag->folder-name tag ) ) ) )
( ui:notify message ) ) ) )
( defclass tag-mark-got-messages-event ( program-event ) ( ) )
( defmethod process-event ( ( object tag-mark-got-messages-event ) )
( loop for tag in ( db:all-tags-with-new-message-fetched ) do
2023-10-14 12:32:45 +02:00
( db:mark-tag-got-new-messages tag ) ) )
2020-05-08 15:45:43 +02:00
( defclass refresh-tag-window-event ( program-event ) ( ) )
( defmethod process-event ( ( object refresh-tag-window-event ) )
( tags-window:resync-rows-db specials:*tags-window* ) )
2023-10-14 15:59:31 +02:00
( defclass update-tags-histograms-event ( program-event ) ( ) )
( defmethod process-event ( ( object update-tags-histograms-event ) )
( loop for subscribed-tag in ( db:all-subscribed-tags-name :as-folder-name nil ) do
( when-let ( ( tag-history ( api-client:tag-history subscribed-tag ) ) )
( loop for history-entry in tag-history do
( db:update-db history-entry :tag ( db:folder-name->tag subscribed-tag ) ) ) ) ) )
2020-05-08 15:45:43 +02:00
( defclass update-conversations-event ( program-event
event-with-timeline-and-folder )
( ) )
( defun add-new-conversations ( )
( let* ( ( new-conversations ( api-client:conversations :root-only t ) )
( all-conversations-id ( db:all-conversations-id :remove-ignored nil ) )
( new-conversations ( remove-if ( lambda ( conversation )
( find-if ( lambda ( a )
( string= ( api-client:id conversation )
a ) )
all-conversations-id ) )
new-conversations ) ) )
( loop for new-conversation in new-conversations do
( let ( ( root-id ( client:conversation-root-id new-conversation ) ) )
( when ( not ( db:conversation-root-captured-p root-id ) )
( db:add-conversation ( api-client:id new-conversation )
root-id ) ) ) ) ) )
( defun fetch-conversations ( message-root-id conversation-folder )
( let* ( ( conversation-tree ( api-client:expand-conversations-tree message-root-id ) )
2020-05-14 16:49:05 +02:00
( event ( make-instance 'save-timeline-in-db-event
2020-05-08 15:45:43 +02:00
:payload conversation-tree
:timeline-type db:+default-converation-timeline+
:folder conversation-folder
:localp nil ) ) )
( push-event event )
conversation-tree ) )
( defmethod process-event ( ( object update-conversations-event ) )
( with-accessors ( ( new-timeline new-timeline )
( new-folder new-folder ) ) object
2020-05-14 18:14:28 +02:00
( tui:with-notify-errors
2020-05-08 15:45:43 +02:00
( add-new-conversations )
( let* ( ( all-conversations ( db:all-conversations ) ) )
( loop for conversation in all-conversations do
( let* ( ( conversation-root ( db:row-conversation-root-status-id conversation ) )
( conversation-folder ( db:row-conversation-folder conversation ) ) )
( fetch-conversations conversation-root conversation-folder ) ) )
;; refresh-ui
( let ( ( refresh-thread ( make-instance 'refresh-thread-windows-event
:new-timeline new-timeline
:new-folder new-folder ) )
( refresh-conversation
( make-instance 'refresh-conversations-window-event ) ) )
( push-event refresh-thread )
( push-event refresh-conversation ) ) ) ) ) )
( defclass change-conversation-name-event ( program-event )
( ( old-name
:initform nil
:initarg :old-name
:accessor old-name )
( new-name
:initform nil
:initarg :new-name
:accessor new-name ) ) )
( defmethod process-event ( ( object change-conversation-name-event ) )
( db:change-conversation-name ( old-name object )
( new-name object ) ) )
( defclass refresh-conversations-window-event ( program-event ) ( ) )
( defmethod process-event ( ( object refresh-conversations-window-event ) )
( conversations-window:resync-rows-db specials:*conversations-window* ) )
( defclass ignore-conversations-event ( program-event ) ( ) )
( defmethod process-event ( ( object ignore-conversations-event ) )
( when-let* ( ( selected-row ( line-oriented-window:selected-row
specials:*conversations-window* ) )
( folder ( line-oriented-window:normal-text selected-row ) )
( refresh-event ( make-instance 'refresh-conversations-window-event ) ) )
( db:ignore-conversation folder ) ) )
( defclass delete-conversations-event ( program-event ) ( ) )
( defmethod process-event ( ( object delete-conversations-event ) )
( when-let* ( ( selected-row ( line-oriented-window:selected-row
specials:*conversations-window* ) )
( fields ( line-oriented-window:selected-row-fields
specials:*conversations-window* ) )
( folder ( line-oriented-window:normal-text selected-row ) )
( id ( db:conversation-id fields ) )
( refresh-event ( make-instance 'refresh-conversations-window-event ) ) )
2020-05-14 18:14:28 +02:00
( tui:with-notify-errors
2020-05-08 15:45:43 +02:00
( api-client:delete-conversation id )
( db:delete-conversation folder ) ) ) )
2020-05-30 09:53:12 +02:00
( defclass update-mentions-event ( program-event ) ( ) )
( defmethod process-event ( ( object update-mentions-event ) )
2022-11-27 13:37:50 +01:00
( let ( ( delete-fetched-mentions-required ( swconf:config-delete-fetched-mentions-p ) ) )
( when-let* ( ( mentions ( api-client:update-mentions-folder
2023-05-31 16:35:21 +02:00
:delete-mentions-on-server delete-fetched-mentions-required
2023-10-27 18:15:32 +02:00
:collect-threads nil
:save-mentions-in-home ( not ( api-pleroma:instance-pleroma-p ) ) ) )
2022-11-27 13:37:50 +01:00
( mentions-count ( length mentions ) )
( thread-window specials:*thread-window* ) )
( when command-line:*notify-mentions*
( loop for mention in mentions do
( thread-window:add-mention thread-window mention ) )
( ui:notify ( format nil
( n_ "Got ~a notification"
"Got ~a notifications"
mentions-count )
mentions-count ) ) ) ) ) )
2020-05-30 09:53:12 +02:00
( defclass expand-thread-event ( program-event event-with-timeline-and-folder )
( ( status-id
:initform nil
:initarg :status-id
2021-06-13 14:07:47 +02:00
:accessor status-id )
( force-saving-of-ignored-status
:initform nil
:initarg :force-saving-of-ignored-status
:reader force-saving-of-ignored-status-p
:writer ( setf force-saving-of-ignored-status ) ) ) )
2020-05-30 09:53:12 +02:00
( defmethod process-event ( ( object expand-thread-event ) )
2021-06-13 14:07:47 +02:00
( with-accessors ( ( new-folder new-folder )
( new-timeline new-timeline )
( status-id status-id )
( force-saving-of-ignored-status-p force-saving-of-ignored-status-p ) ) object
( api-client:expand-status-thread status-id
new-timeline
new-folder
force-saving-of-ignored-status-p ) ) )
2020-05-30 09:53:12 +02:00
2020-05-08 15:45:43 +02:00
( defclass report-status-event ( program-event )
( ( status-id
:initform nil
:initarg :status-id
:accessor status-id )
( account-id
:initform nil
:initarg :account-id
:accessor account-id )
( comment
:initform nil
:initarg :comment
:accessor comment )
( forwardp
:initform nil
:initarg :forwardp
:accessor forwardp ) ) )
( defmethod process-event ( ( object report-status-event ) )
( with-accessors ( ( status-id status-id )
( account-id account-id )
( comment comment )
( forwardp forwardp ) ) object
2020-05-14 18:14:28 +02:00
( tui:with-notify-errors
2020-05-08 15:45:43 +02:00
( api-client:make-report account-id status-id comment forwardp ) ) ) )
( defclass add-crypto-data-event ( program-event )
( ( username
:initform nil
:initarg :username
:accessor username )
( key
:initform nil
:initarg :key
:accessor key ) ) )
( defmethod process-event ( ( object add-crypto-data-event ) )
( with-accessors ( ( username username )
( key key ) ) object
( db:import-crypto-data ( db:acct->id username )
key ) ) )
2020-05-14 16:32:01 +02:00
( defclass add-pagination-status-event ( program-event )
( ( status-id
:initform nil
:initarg :status-id
:accessor status-id )
( timeline
:initform nil
:initarg :timeline
:accessor timeline )
( folder
:initform nil
:initarg :folder
:accessor folder ) ) )
( defmethod process-event ( ( object add-pagination-status-event ) )
( with-accessors ( ( status-id status-id )
( timeline timeline )
( folder folder ) ) object
2020-06-13 13:02:23 +02:00
( db:add-to-pagination-status status-id folder timeline :ensure-no-duplicates t ) ) )
2020-05-14 16:32:01 +02:00
2020-05-31 16:49:26 +02:00
( defclass poll-vote-event ( program-event )
( ( poll-id
:initform nil
:initarg :poll-id
:accessor poll-id )
( choices
:initform ( )
:initarg :choices
:accessor choices ) ) )
( defmethod process-event ( ( object poll-vote-event ) )
( with-accessors ( ( poll-id poll-id )
( choices choices ) ) object
( tui:with-notify-errors
( api-client:poll-vote poll-id choices ) ) ) )
2022-08-23 16:36:34 +02:00
( defclass display-output-script-page ( program-event )
( ( window
:initform nil
:initarg :window
:accessor window ) ) )
( defmethod process-event ( ( object display-output-script-page ) )
( with-accessors ( ( page-data payload )
( window window ) ) object
( when ( text-utils:string-not-empty-p page-data )
( tui:with-notify-errors
( message-window:prepare-for-rendering window page-data )
( windows:draw window ) ) ) ) )
2021-08-16 14:22:47 +02:00
( defclass gemini-display-data-page ( program-event )
( ( window
:initform nil
:initarg :window
:accessor window )
( local-path
2022-12-26 16:41:50 +01:00
:initform nil
2021-08-16 14:22:47 +02:00
:initarg :local-path
:accessor local-path ) ) )
( defmethod process-event ( ( object gemini-display-data-page ) )
( with-accessors ( ( page-data payload )
( window window )
( local-path local-path ) ) object
( tui:with-notify-errors
2022-12-29 17:24:53 +01:00
( let* ( ( parsed ( gemini-parser:parse-gemini-file page-data :initialize-parser t ) )
2021-08-16 14:22:47 +02:00
( local-path-p ( text-utils:string-not-empty-p local-path ) )
( links ( gemini-parser:sexp->links parsed
nil
nil
local-path
2022-08-05 11:30:56 +02:00
nil
2021-08-16 14:22:47 +02:00
:comes-from-local-file local-path-p ) )
( ir-text ( gemini-parser:sexp->text-rows parsed
gemini-client:*gemini-page-theme* ) ) )
2021-08-28 19:53:41 +02:00
( setf ( windows:keybindings window )
keybindings:*gemini-message-keymap* )
2021-08-16 14:22:47 +02:00
( gemini-viewer:maybe-initialize-metadata window )
( refresh-gemini-message-window links page-data ir-text nil )
2024-04-06 19:15:15 +02:00
( let ( ( already-enqueued *process-events-immediately* ) )
( if already-enqueued
( process-event ( make-instance 'gemini-toc-open ) )
( ui:open-gemini-toc ) )
( ui:open-gemini-message-link-window :give-focus nil
:enqueue ( not already-enqueued ) )
( ui:focus-to-message-window )
( windows:draw window ) ) ) ) ) )
2021-08-16 14:22:47 +02:00
2020-06-27 22:43:13 +02:00
( defclass gemini-request-event ( program-event )
( ( url
:initform nil
:initarg :url
2020-12-17 13:12:16 +01:00
:accessor url )
( use-cached-file-if-exists
:initform nil
:initarg :use-cached-file-if-exists
2021-03-27 09:19:13 +01:00
:accessor use-cached-file-if-exists )
( give-focus-to-message-window
:initform t
:initarg :give-focus-to-message-window
:reader give-focus-to-message-window-p
2021-05-16 16:19:14 +02:00
:writer ( setf give-focus-to-message-window ) )
2021-08-27 14:17:14 +02:00
( opening-gempub-file
:initform nil
:initarg :opening-gempub-file
:reader opening-gempub-file-p
:writer ( setf opening-gempub-file ) )
2021-05-16 16:19:14 +02:00
( enqueue
:initform nil
:initarg :enqueue
:accessor enqueue ) ) )
2020-06-27 22:43:13 +02:00
2021-08-20 17:52:09 +02:00
( defun relative-path->absolute ( path )
2022-01-28 12:24:24 +01:00
( fs:normalize-path ( fs:prepend-pwd path ) ) )
2021-08-20 17:52:09 +02:00
2021-08-20 17:54:49 +02:00
( defun render-directory-as-gemini-text ( root-directory )
2021-11-12 15:00:34 +01:00
( let* ( ( index-path ( relative-path->absolute root-directory ) )
2022-01-28 12:24:24 +01:00
( all-paths ( mapcar #' fs:normalize-path
2021-08-20 17:52:09 +02:00
( fs:collect-children index-path ) ) )
( link-lines ( ) )
( raw-text ( with-output-to-string ( stream )
( write-sequence ( gemini-parser:geminize-h1
( format nil
( _ "Index of local directory ~a~2%" )
index-path ) )
stream ) ) ) )
( loop for path in all-paths do
( let* ( ( dirp ( fs:dirp path ) )
( dir-symbol ( swconf:directory-symbol ) )
( link-label ( if dirp
( text-utils:strcat path " " dir-symbol )
path ) )
( encoded-path ( gemini-client::percent-encode-path path ) )
2021-10-10 12:38:37 +02:00
( link ( gemini-parser:render-gemini-link encoded-path link-label ) ) )
2021-08-20 17:52:09 +02:00
( push link link-lines ) ) )
( setf link-lines ( sort link-lines #' string< ) )
( text-utils:join-with-strings ( append ( list raw-text ) link-lines )
( format nil "~%" ) ) ) )
2020-06-27 22:43:13 +02:00
( defmethod process-event ( ( object gemini-request-event ) )
2021-03-27 09:19:13 +01:00
( tui:with-notify-errors
2021-04-03 13:04:40 +02:00
( with-accessors ( ( url url ) ; if a local file *not* percent encoded
2021-03-27 09:19:13 +01:00
( give-focus-to-message-window-p give-focus-to-message-window-p )
2021-05-16 16:19:14 +02:00
( use-cached-file-if-exists use-cached-file-if-exists )
( enqueue enqueue ) ) object
2021-04-03 13:04:40 +02:00
( let ( ( window specials:*message-window* )
( local-path ( if ( text-utils:percent-encoded-p url )
2021-05-06 16:59:11 +02:00
( complete:tilde-expand-string ( text-utils:percent-decode url ) )
( complete:tilde-expand-string url ) ) ) )
2021-03-27 09:19:13 +01:00
( setf ( windows:keybindings window )
keybindings:*gemini-message-keymap* )
( when give-focus-to-message-window-p
( ui:focus-to-message-window ) )
2021-03-27 10:21:19 +01:00
( cond
2021-04-25 16:12:49 +02:00
( ( text-utils:string-empty-p url )
( ui:error-message ( _ "Empty address" ) ) )
2023-07-07 14:45:05 +02:00
( ( gemini-client:absolute-gemini-or-titan-url-p url )
2021-06-17 19:41:03 +02:00
( gemini-viewer:bury-download-stream )
( gemini-viewer:ensure-just-one-stream-rendering )
2021-05-16 16:19:14 +02:00
( gemini-viewer:request url
:enqueue enqueue
:use-cached-file-if-exists use-cached-file-if-exists ) )
2021-04-03 13:04:40 +02:00
( ( fs:dirp local-path )
2022-01-06 18:17:07 +01:00
( ui:open-file-explorer local-path ) )
2021-08-27 12:15:12 +02:00
( ( gempub:gempub-file-p local-path :ignore-errors t )
2021-08-20 17:35:45 +02:00
( let ( ( temp-directory ( fs:temporary-directory ) ) )
( os-utils:unzip-file local-path temp-directory )
2021-08-26 15:47:27 +02:00
( let* ( ( library-entry ( db:gempub-metadata-find local-path ) )
( index-file ( and library-entry
( db:row-index-file library-entry ) ) ) )
( if index-file
( setf ( url object ) ( fs:cat-parent-dir temp-directory index-file ) )
( setf ( url object ) temp-directory ) )
2021-08-27 14:17:14 +02:00
( setf ( opening-gempub-file object ) t )
2021-08-26 15:47:27 +02:00
( push-event object ) ) ) )
2021-08-27 14:17:14 +02:00
( ( opening-gempub-file-p object )
( let* ( ( file-string ( fs:slurp-file local-path ) )
2022-12-29 17:24:53 +01:00
( parsed ( gemini-parser:parse-gemini-file file-string :initialize-parser t ) )
2021-08-27 14:17:14 +02:00
( parent-dir ( fs:parent-dir-path local-path ) )
( links ( gemini-parser:sexp->links parsed
nil
nil
parent-dir
2022-08-05 11:30:56 +02:00
nil
2021-08-27 14:17:14 +02:00
:comes-from-local-file t ) )
2021-08-27 14:30:28 +02:00
( local-links ( remove-if ( lambda ( link )
( let ( ( target ( gemini-parser:target link ) ) )
( if target
( uri:scheme ( iri:iri-parse target ) )
t ) ) )
links ) )
2021-08-27 14:17:14 +02:00
( event ( make-instance 'gemini-display-data-page
:local-path parent-dir
:window window
:payload file-string ) ) )
( let ( ( *process-events-immediately* t ) )
( push-event event ) )
( ui:clean-all-tour )
2021-08-27 14:30:28 +02:00
( ui:add-links-to-tour local-links )
2021-08-27 14:17:14 +02:00
( gemini-viewer:push-url-to-history window local-path ) ) )
2021-03-27 10:21:19 +01:00
( t
2021-11-12 20:27:11 +01:00
( handler-case
( let* ( ( file-string ( fs:slurp-file local-path ) )
( parent-dir ( fs:parent-dir-path local-path ) )
( event ( make-instance 'gemini-display-data-page
:local-path parent-dir
:window window
:payload file-string ) ) )
( let ( ( *process-events-immediately* t ) )
( push-event event ) )
( gemini-viewer:push-url-to-history window local-path ) )
( error ( e ) ( ui:error-message ( format nil "~a" e ) ) ) ) ) ) ) ) ) )
2020-06-27 22:43:13 +02:00
2023-07-07 14:45:05 +02:00
( defclass titan-post-event ( program-event )
( ( url
:initform nil
:initarg :url
:accessor url )
( data
:initform nil
:initarg :data
:accessor data )
( size
:initform nil
:initarg :size
:accessor size )
( mime
:initform nil
:initarg :mime
:accessor mime )
( token
:initform nil
:initarg :token
:accessor token ) ) )
( defmethod process-event ( ( object titan-post-event ) )
( tui:with-notify-errors
( with-accessors ( ( url url ) ; if a local file *not* percent encoded
( data data )
( size size )
( mime mime )
( token token ) ) object
( cond
( ( text-utils:string-empty-p url )
( ui:error-message ( _ "Empty address" ) ) )
( ( gemini-client:absolute-titan-url-p url )
( gemini-viewer:request url
:titan-data data
:titan-size size
:titan-mime mime
:titan-token token ) ) ) ) ) )
2020-06-28 17:39:21 +02:00
( defclass gemini-back-event ( program-event ) ( ) )
( defmethod process-event ( ( object gemini-back-event ) )
2020-10-01 16:48:59 +02:00
( push-downloading-behind )
2020-06-28 17:39:21 +02:00
( gemini-viewer:history-back specials:*message-window* ) )
2020-07-26 12:04:46 +02:00
( defclass gemini-got-line-event ( program-event )
2020-08-27 17:51:40 +02:00
( ( wrapper-object
:initform nil
:initarg :wrapper-object
:accessor wrapper-object )
( append-text
2020-07-26 12:04:46 +02:00
:initform t
:initarg :append-text
2020-10-01 16:39:09 +02:00
:accessor append-text )
( skip-rendering
:initform nil
:initarg :skip-rendering
:reader skip-rendering-p
:writer ( setf skip-rendering ) ) ) )
2020-07-26 12:04:46 +02:00
2021-04-07 15:23:15 +02:00
( defun refresh-gemini-message-window ( links source ir-rows append-text )
2021-07-09 13:54:29 +02:00
( let* ( ( win specials:*message-window* )
2020-10-11 18:51:55 +02:00
( window-metadata ( message-window:metadata win ) ) )
2021-04-05 15:48:30 +02:00
( with-accessors ( ( rows message-window::rows ) ) win
( let ( ( new-rows ( message-window:text->rendered-lines-rows win
2021-04-08 15:13:31 +02:00
ir-rows ) ) )
2021-04-05 15:48:30 +02:00
( if append-text
( progn
2021-04-08 15:13:31 +02:00
( line-oriented-window:append-new-rows win new-rows )
2021-04-05 15:48:30 +02:00
( gemini-viewer:append-metadata-link window-metadata links )
2021-10-08 11:37:53 +02:00
( gemini-viewer:append-metadata-source window-metadata source )
( funcall ( message-window:adjust-rows-strategy win ) win ) )
2021-04-05 15:48:30 +02:00
( progn
( setf ( gemini-viewer:gemini-metadata-source-file window-metadata ) source )
2021-04-05 16:28:52 +02:00
( setf ( gemini-viewer:gemini-metadata-links window-metadata ) links )
2021-10-08 12:11:00 +02:00
( line-oriented-window:update-all-rows win new-rows )
( line-oriented-window:adjust-selected-rows specials:*message-window*
#' line-oriented-window:adjust-rows-select-first ) ) ) ) ) ) )
2020-10-11 18:51:55 +02:00
2020-07-26 12:04:46 +02:00
( defmethod process-event ( ( object gemini-got-line-event ) )
2020-08-27 17:51:40 +02:00
( with-accessors ( ( response payload )
( append-text append-text )
( wrapper-object wrapper-object ) ) object
2020-07-26 12:04:46 +02:00
( with-accessors ( ( status-code gemini-client:status-code )
( status-code-message gemini-client:status-code-message )
( meta gemini-client:meta )
( parsed-file gemini-client:parsed-file )
( source-url gemini-client:source-url )
( source gemini-client:source )
( links gemini-client:links )
( text-rendering-theme gemini-client:text-rendering-theme ) ) response
2021-05-15 10:35:09 +02:00
( let* ( ( win specials:*message-window* )
( ir-line ( gemini-parser:sexp->text-rows parsed-file
text-rendering-theme ) ) )
( when ( and ( gemini-viewer:downloading-allowed-p wrapper-object )
( not ( skip-rendering-p object ) )
( message-window:display-gemini-text-p win ) )
2021-04-07 15:23:15 +02:00
( refresh-gemini-message-window links source ir-line append-text )
2021-10-08 11:37:53 +02:00
( windows:draw win )
( when append-text
( message-window:draw-downloading-animation win ) ) ) ) ) ) )
2020-07-26 16:34:05 +02:00
( defclass gemini-abort-downloading-event ( program-event ) ( ) )
( defmethod process-event ( ( object gemini-abort-downloading-event ) )
2020-12-17 13:56:07 +01:00
( with-accessors ( ( iri payload ) ) object
2020-12-29 12:36:10 +01:00
( gemini-viewer:abort-download-stream iri
:remove-wainting-stream-event t
:redraw-stream-window t ) ) )
2020-10-01 16:39:09 +02:00
( defclass gemini-abort-all-downloading-event ( program-event ) ( ) )
( defmethod process-event ( ( object gemini-abort-all-downloading-event ) )
2020-09-30 18:24:58 +02:00
( gemini-viewer:remove-all-db-stream )
( remove-event-if ( lambda ( a ) ( typep a 'gemini-got-line-event ) ) ) )
( defclass gemini-push-behind-downloading-event ( program-event ) ( ) )
2023-12-07 17:47:00 +01:00
( defun push-downloading-behind ( &key ( lock-queue nil ) )
2020-09-30 18:24:58 +02:00
( map-events ( lambda ( a )
2020-10-01 16:39:09 +02:00
( when ( typep a 'gemini-got-line-event )
( setf ( skip-rendering a ) t )
( setf ( priority a ) +minimum-event-priority+ ) )
2023-12-07 17:47:00 +01:00
a )
:lock-queue lock-queue ) )
2020-08-30 15:34:08 +02:00
2020-10-01 16:48:59 +02:00
( defmethod process-event ( ( object gemini-push-behind-downloading-event ) )
( push-downloading-behind ) )
2020-08-30 15:34:08 +02:00
( defclass gemini-enqueue-download-event ( program-event ) ( ) )
( defmethod process-event ( ( object gemini-enqueue-download-event ) )
( with-accessors ( ( stream-object payload ) ) object
( gemini-viewer:push-db-stream stream-object ) ) )
2020-07-26 12:04:46 +02:00
2021-01-09 11:01:10 +01:00
( defclass gemini-gemlog-subscribe-event ( program-event ) ( ) )
( defmethod process-event ( ( object gemini-gemlog-subscribe-event ) )
( with-accessors ( ( url payload ) ) object
( let ( ( subscribedp ( gemini-subscription:subscribe url ) ) )
2021-01-09 16:27:40 +01:00
( if subscribedp
( gemini-subscription:refresh url )
( ui:notify ( format nil
( _ "Unable to subscribe to ~s" )
url )
:as-error t ) ) ) ) )
2021-01-10 11:35:28 +01:00
( defclass gemlog-cancel-subscription-event ( program-event ) ( ) )
( defmethod process-event ( ( object gemlog-cancel-subscription-event ) )
( with-accessors ( ( gemlog-url payload ) ) object
( db:gemini-cancel-subscription gemlog-url )
( handler-bind ( ( conditions:out-of-bounds
( lambda ( e )
( invoke-restart 'line-oriented-window:set-default-index e ) ) ) )
( line-oriented-window:resync-rows-db specials:*gemini-subscription-window*
:suggested-message-index 0
:redraw t ) ) ) )
2021-01-09 16:27:40 +01:00
( defclass gemlog-show-event ( program-event )
( ( title
:initarg :title
:accessor title )
( subtitle
:initarg :subtitle
:accessor subtitle )
( gemlog-url
:initarg :gemlog-url
:accessor gemlog-url )
( entries
:initarg :entries
:accessor entries ) ) )
2023-05-06 12:48:01 +02:00
( defun build-gemlog-page ( title subtitle entries )
( with-output-to-string ( stream )
( format stream
"~a~2%"
( gemini-parser:geminize-h1 title ) )
( if subtitle
( format stream
"~a~2%"
( gemini-parser:geminize-h2 subtitle ) )
( format stream
"~a~2%"
( gemini-parser:geminize-h2 ( _ "No subtitle" ) ) ) )
( loop for entry in entries do
( let* ( ( link ( db:row-post-link entry ) )
( date-format ( swconf:date-fmt swconf:+key-message-window+ ) )
( date ( db:row-post-date entry ) )
( encoded-date ( db-utils:encode-datetime-string date ) )
( title ( text-utils:strcat ( format-time encoded-date date-format )
" "
( db:row-post-title entry ) ) )
( seenp ( db-utils:db-not-nil-p ( db:row-post-seenp entry ) ) ) )
( format stream
( _ "~a ~:[(not opened)~;(opened)~]~%" )
( gemini-parser:render-gemini-link link
title )
seenp ) ) ) ) )
2021-01-09 16:27:40 +01:00
( defmethod process-event ( ( object gemlog-show-event ) )
( with-accessors ( ( title title )
( subtitle subtitle )
( entries entries )
( gemlog-url gemlog-url ) ) object
2023-05-06 12:48:01 +02:00
( let* ( ( gemini-page ( build-gemlog-page title subtitle entries ) )
( url ( iri:iri-parse gemlog-url ) )
( parsed ( gemini-parser:parse-gemini-file gemini-page :initialize-parser t ) )
( links ( gemini-parser:sexp->links parsed
( uri:host url )
( uri:port url )
( uri:path url )
( uri:query url ) ) )
( theme gemini-client:*gemini-page-theme* ) )
2021-01-28 15:35:26 +01:00
( gemini-viewer:maybe-initialize-metadata specials:*message-window* )
2021-01-09 16:27:40 +01:00
( refresh-gemini-message-window links
gemini-page
2021-04-08 15:13:31 +02:00
( gemini-parser:sexp->text-rows parsed theme )
2021-01-09 16:27:40 +01:00
nil )
( setf ( windows:keybindings specials:*message-window* )
keybindings:*gemini-message-keymap* )
( windows:draw specials:*message-window* ) ) ) )
2021-01-09 11:01:10 +01:00
2021-08-14 11:22:26 +02:00
( defclass gemlog-refresh-thread ( program-event ) ( ) )
( defmethod process-event ( ( object gemlog-refresh-thread ) )
( let* ( ( subscription ( payload object ) )
( notification-message ( format nil ( _ "updating gemlog ~a" ) subscription ) ) )
( ui:notify-procedure ( lambda ( )
( db-utils:with-ready-database ( )
2022-06-29 21:26:29 +02:00
( handler-case
( gemini-subscription:refresh subscription )
( condition ( ) nil ) ) ) )
2021-08-14 11:22:26 +02:00
notification-message
:ending-message nil ) ) )
2021-01-10 13:01:03 +01:00
( defclass gemlog-refresh-all-event ( program-event ) ( ) )
( defmethod process-event ( ( object gemlog-refresh-all-event ) )
( let ( ( all-subscribed-gemlogs ( mapcar #' db:row-url ( db:gemini-all-subscriptions ) ) ) )
2021-08-14 11:22:26 +02:00
( loop for subscription in all-subscribed-gemlogs do
( let ( ( event ( make-instance 'gemlog-refresh-thread
:payload subscription
:priority +minimum-event-priority+ ) ) )
( push-event event ) ) ) ) )
2021-01-10 13:01:03 +01:00
2021-05-16 14:18:19 +02:00
( defclass gemini-toc-jump-to-section ( program-event )
( ( toc-win
:initform nil
:initarg :toc-win
:accessor toc-win )
( message-win
:initform nil
:initarg :message-win
:accessor message-win )
( gid-looking-for
:initform nil
:initarg :gid-looking-for
:accessor gid-looking-for ) ) )
( defmethod process-event ( ( object gemini-toc-jump-to-section ) )
( with-accessors ( ( toc-win toc-win )
( message-win message-win )
( gid-looking-for gid-looking-for ) ) object
( let* ( ( selected-row ( line-oriented-window:selected-row-fields toc-win ) )
( gid-looking-for ( message-window:gemini-toc-group-id selected-row ) ) )
( message-window:jump-to-group-id message-win gid-looking-for ) ) ) )
( defclass gemini-toc-open ( program-event ) ( ) )
( defmethod process-event ( ( object gemini-toc-open ) )
2021-05-16 15:38:26 +02:00
( let ( ( message-win specials:*message-window* )
( toc-win specials:*gemini-toc-window* ) )
( cond
( ( not ( message-window:gemini-window-p* message-win ) )
2023-07-15 14:30:09 +02:00
( ui:error-message ( _ "TOC can be shown for gemini windows only" ) ) )
2021-05-16 15:38:26 +02:00
( ( and toc-win
( windows:win-shown-p toc-win ) )
2021-05-17 19:04:07 +02:00
( line-oriented-window:resync-rows-db toc-win :suggested-message-index 0 ) )
2021-05-16 15:38:26 +02:00
( t
( gemini-page-toc:open-toc-window message-win ) ) ) ) )
2021-05-16 14:18:19 +02:00
2020-09-05 17:02:00 +02:00
;;;; pleroma
( defclass get-chat-messages-event ( program-event )
( ( chat-id
:initform nil
:initarg :chat-id
:accessor chat-id )
( min-message-id
:initform nil
:initarg :min-message-id
:accessor min-message-id ) ) )
( defmethod process-event ( ( object get-chat-messages-event ) )
( with-accessors ( ( chat-id chat-id )
( min-message-id min-message-id ) ) object
( let ( ( messages ( api-pleroma:get-chat-messages chat-id min-message-id ) ) )
( dolist ( message messages )
2020-09-09 21:13:57 +02:00
( db:update-db message )
( when ( and specials:*chats-list-window*
( windows:win-shown-p specials:*chats-list-window* ) )
( line-oriented-window:resync-rows-db specials:*chats-list-window* ) ) ) ) ) )
2020-09-05 17:02:00 +02:00
( defclass get-chats-event ( program-event ) ( ) )
( defmethod process-event ( ( object get-chats-event ) )
( with-accessors ( ( chat-id chat-id )
( min-message-id min-message-id ) ) object
2021-07-15 21:17:24 +02:00
( tui:with-notify-errors
( let ( ( chats ( api-pleroma:get-chats ) ) )
( dolist ( chat chats )
2022-11-21 20:30:58 +01:00
( db:update-db chat ) ) )
( line-oriented-window:resync-rows-db specials:*chats-list-window* ) ) ) )
2020-09-05 17:02:00 +02:00
( defclass update-all-chat-messages-event ( program-event ) ( ) )
( defmethod process-event ( ( object update-all-chat-messages-event ) )
2021-07-15 21:17:24 +02:00
( tui:with-notify-errors
( let ( ( all-chats ( db:all-chats ) ) )
( dolist ( chat all-chats )
( let* ( ( chat-id ( db:row-id chat ) )
( min-id ( db:last-chat-message-id chat-id ) ) )
( process-event ( make-instance 'program-events:get-chat-messages-event
:chat-id chat-id
:min-message-id min-id ) ) ) ) ) ) )
2020-09-05 17:02:00 +02:00
( defclass chat-show-event ( program-event )
( ( chat
:initform nil
:initarg :chat
:accessor chat ) ) )
( defmethod process-event ( ( object chat-show-event ) )
( with-accessors ( ( chat chat ) ) object
( let* ( ( chat-id ( db:row-id chat ) ) )
( db:mark-all-chat-messages-read chat-id )
2020-09-06 17:28:16 +02:00
( setf ( windows:keybindings specials:*message-window* )
keybindings:*chat-message-keymap* )
2021-04-10 13:52:56 +02:00
( message-window:prepare-for-rendering specials:*message-window*
( chats-list-window:chat->text chat ) )
2020-09-06 16:37:57 +02:00
( message-window:scroll-end specials:*message-window* )
2020-09-06 17:28:16 +02:00
( setf ( message-window:metadata specials:*message-window* )
chat )
2021-10-08 11:55:16 +02:00
( line-oriented-window:adjust-selected-rows specials:*message-window*
#' line-oriented-window:adjust-rows-select-last )
2020-09-05 17:02:00 +02:00
( windows:draw specials:*message-window* ) ) ) )
2020-09-06 14:42:16 +02:00
( defclass chat-post-message-event ( program-event )
( ( message
:initform nil
:initarg :message
:accessor message )
( chat-id
:initform nil
:initarg :chat-id
:accessor chat-id ) ) )
( defmethod process-event ( ( object chat-post-message-event ) )
( with-accessors ( ( message message )
( chat-id chat-id ) ) object
( api-pleroma:post-on-chat chat-id message ) ) )
2020-09-09 21:13:57 +02:00
( defclass chat-change-label-event ( program-event )
( ( label
:initform nil
:initarg :label
:accessor label )
( chat-id
:initform nil
:initarg :chat-id
:accessor chat-id ) ) )
( defmethod process-event ( ( object chat-change-label-event ) )
( with-accessors ( ( label label )
( chat-id chat-id ) ) object
( db:chat-change-label chat-id label )
( line-oriented-window:resync-rows-db specials:*chats-list-window* ) ) )
2020-09-10 17:50:22 +02:00
( defclass chat-create-event ( program-event )
( ( user-id
:initform nil
:initarg :user-id
:accessor user-id )
( chat-label
:initform ( _ "no label" )
:initarg :chat-label
:accessor chat-label ) ) )
( defmethod process-event ( ( object chat-create-event ) )
( with-accessors ( ( chat-label chat-label )
( user-id user-id ) ) object
( let ( ( chat ( api-pleroma:create-new-chat user-id ) ) )
( db:update-db chat )
( process-event ( make-instance 'chat-change-label-event
:chat-id ( api-pleroma:chat-id chat )
:label chat-label ) ) ) ) )
2020-12-30 12:38:31 +01:00
( defclass search-link-event ( search-event )
2020-10-03 16:58:02 +02:00
( ( window
:initform nil
:initarg :window
:accessor window )
( regex
:initform nil
:initarg :regex
:accessor regex ) ) )
( defmethod process-event ( ( object search-link-event ) )
( with-accessors ( ( window window )
( regex regex ) ) object
( line-oriented-window:search-row window regex ) ) )
2022-02-24 18:42:11 +01:00
( defclass search-toc-event ( search-event )
( ( window
:initform nil
:initarg :window
:accessor window )
( regex
:initform nil
:initarg :regex
:accessor regex ) ) )
( defmethod process-event ( ( object search-toc-event ) )
( with-accessors ( ( window window )
( regex regex ) ) object
( line-oriented-window:search-row window regex )
( ui:gemini-toc-jump-to-entry ) ) )
2020-10-03 21:08:55 +02:00
( defclass help-apropos-event ( program-event )
( ( regex
:initform nil
:initarg :regex
2021-08-28 16:39:34 +02:00
:accessor regex )
( global
:initform nil
:initarg :globalp
:reader globalp
:writer ( setf global ) ) ) )
2020-10-03 21:08:55 +02:00
( defmethod process-event ( ( object help-apropos-event ) )
( with-accessors ( ( regex regex ) ) object
2021-08-28 16:39:34 +02:00
( keybindings:print-help specials:*main-window*
:regex regex
:global-search ( globalp object ) ) ) )
2020-10-03 21:08:55 +02:00
2020-10-23 20:57:17 +02:00
( defclass redraw-window-event ( program-event ) ( ) )
( defmethod process-event ( ( object redraw-window-event ) )
( with-accessors ( ( window payload ) ) object
( windows:draw window ) ) )
2020-12-30 12:24:13 +01:00
( defclass send-to-pipe-event ( program-event )
( ( data
:initform nil
:initarg :data
:accessor data )
( command
:initform nil
:initarg :command
:accessor command ) ) )
( defmethod process-event ( ( object send-to-pipe-event ) )
( with-accessors ( ( data data )
( command command ) ) object
2021-02-02 20:44:18 +01:00
( tui:with-print-error-message
( os-utils:send-to-pipe data command ) ) ) )
2020-12-30 12:24:13 +01:00
2022-11-17 14:03:03 +01:00
( defclass print-mentions-event ( program-event ) ( ) )
( defmethod process-event ( ( object print-mentions-event ) )
( let* ( ( thread-window specials:*thread-window* )
( mentions ( thread-window::mentions thread-window ) )
( message-window specials:*message-window* ) )
( if mentions
2023-01-01 11:11:40 +01:00
( labels ( ( make-rows ( mentions )
2022-11-17 14:03:03 +01:00
( mapcar ( lambda ( mention )
2022-11-19 20:46:39 +01:00
( make-instance 'line-oriented-window:line
2022-11-17 14:03:03 +01:00
:fields ( list :original-object mention )
2023-01-01 11:11:40 +01:00
:normal-text ( api-client:notification->text mention )
:selected-text ( api-client:notification->text mention ) ) )
2022-11-17 14:03:03 +01:00
mentions ) ) )
( line-oriented-window:update-all-rows message-window ( make-rows mentions ) )
( windows:win-clear message-window )
( windows:draw message-window ) )
( ui:info-message ( _ "No mentions" ) ) ) ) )
2023-01-01 11:11:40 +01:00
( defclass delete-all-notifications-event ( program-event ) ( ) )
( defmethod process-event ( ( object delete-all-notifications-event ) )
"Delete all the notification from server"
( let ( ( message-window specials:*message-window* ) )
( line-oriented-window:update-all-rows message-window ' ( ) )
( api-client:delete-all-notifications
( lambda ( notification )
( with-enqueued-process ( )
2023-01-02 19:03:36 +01:00
( let* ( ( message ( tui:make-tui-string ( format nil
( _ "Deleting: ~a" )
( api-client:notification->text notification ) ) ) )
2023-01-01 11:11:40 +01:00
( row ( make-instance 'line-oriented-window:line
:fields ( list :original-object notification )
:normal-text message
:selected-text message ) ) )
( line-oriented-window:append-new-rows message-window ( list row ) )
( windows:win-clear message-window )
( windows:draw message-window ) ) ) ) ) ) )
2023-09-25 19:03:32 +02:00
( defclass show-announcements-event ( program-event ) ( ) )
( defmethod process-event ( ( object show-announcements-event ) )
"Shows a window with all announcements"
( when-let* ( ( all-announcements ( api-client:get-announcements ) )
2023-10-01 18:12:00 +02:00
( all-texts ( mapcar ( lambda ( a )
2024-03-31 13:56:20 +02:00
( text-utils:justify-monospaced-text ( html-utils:html->text a
:quote-prefix
( swconf:message-window-quote-prefix )
:list-item-prefix
( swconf:message-window-bullet-prefix ) )
( truncate ( * 3/4
( windows:win-width specials:*main-window* ) ) ) ) )
2023-09-25 19:03:32 +02:00
( mapcar #' tooter:content all-announcements ) ) )
2024-03-31 13:56:20 +02:00
( lines ( mapcar ( lambda ( a )
( append a
( list ""
( swconf:config-announcements-separator )
"" ) ) )
all-texts ) )
( window-content ( flatten lines ) ) )
2023-09-25 19:03:32 +02:00
( api-client:dismiss-all-announcements all-announcements )
( line-oriented-window:make-blocking-list-dialog-window specials:*main-window*
window-content
window-content
nil
( _ "Announcements " ) )
( push-event ( make-instance 'check-announcements-event ) ) ) )
( defclass check-announcements-event ( program-event ) ( ) )
( defmethod process-event ( ( object check-announcements-event ) )
"Shows a window with all announcements"
( if ( api-client:get-announcements )
( thread-window:add-announcements-notification specials:*thread-window* )
( thread-window:remove-announcements-notification specials:*thread-window* ) )
( windows:draw specials:*thread-window* ) )
2024-05-04 14:07:33 +02:00
( 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
2024-05-04 14:22:08 +02:00
( n_ "The matching status (~a founds) can be found in folder: *~a*, timeline: *home*~2%"
"The matching statuses (~a found) can be found in folder: *~a*, timeline: *home*~2%"
( length found-statuses ) )
2024-05-04 14:07:33 +02:00
( 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" ) ) ) ) ) )
2020-05-08 15:45:43 +02:00
;;;; end events
( defun dispatch-program-events ( )
( when ( event-available-p )
2020-05-30 09:53:12 +02:00
( let ( ( bypassable-event ( pop-event ) ) )
( if ( and ( = ( priority bypassable-event )
+minimum-event-priority+ )
( event-available-p ) )
( let ( ( event ( pop-event ) ) )
( reinitialize-id bypassable-event )
( push-event bypassable-event )
( process-event event ) )
( process-event bypassable-event ) ) ) ) )
2023-02-02 16:10:08 +01:00
( defun dispatch-program-events-or-wait ( )
2023-02-09 16:28:53 +01:00
( let ( ( bypassable-event ( pop-event-block ) ) )
( if ( and ( = ( priority bypassable-event )
+minimum-event-priority+ )
( event-available-p ) )
( let ( ( event ( pop-event-block ) ) )
( reinitialize-id bypassable-event )
2023-02-02 16:10:08 +01:00
( push-event-unblock bypassable-event )
2023-02-09 16:28:53 +01:00
( process-event event ) )
( process-event bypassable-event ) ) ) )