mirror of https://codeberg.org/cage/tinmop/
- chats can be fetched, via UI, and printed on window.
This commit is contained in:
parent
4046f516f8
commit
75d81ec708
|
@ -485,3 +485,7 @@ open-gemini-stream-window.foreground = #FEB200
|
||||||
open-gemini-stream-window.input.selected.background = black
|
open-gemini-stream-window.input.selected.background = black
|
||||||
|
|
||||||
open-gemini-stream-window.input.selected.foreground = #FFB200
|
open-gemini-stream-window.input.selected.foreground = #FFB200
|
||||||
|
|
||||||
|
# chats
|
||||||
|
|
||||||
|
chat-window.date-format.value = "[%hour:%min]"
|
|
@ -135,6 +135,8 @@
|
||||||
|
|
||||||
(define-key ">" #'open-gemini-address)
|
(define-key ">" #'open-gemini-address)
|
||||||
|
|
||||||
|
(define-key "M-c" #'open-chats-list-window)
|
||||||
|
|
||||||
;; focus
|
;; focus
|
||||||
|
|
||||||
(define-key "f1" #'focus-to-tags-window)
|
(define-key "f1" #'focus-to-tags-window)
|
||||||
|
@ -355,17 +357,21 @@
|
||||||
|
|
||||||
;; message links keymap
|
;; message links keymap
|
||||||
|
|
||||||
(define-key "C-J" #'open-message-link-perform-opening
|
(define-key "C-J" #'open-message-link-perform-opening *open-message-link-keymap*)
|
||||||
*open-message-link-keymap*)
|
|
||||||
|
|
||||||
(define-key "up" #'open-message-link-go-up
|
(define-key "up" #'open-message-link-go-up *open-message-link-keymap*)
|
||||||
*open-message-link-keymap*)
|
|
||||||
|
|
||||||
(define-key "down" #'open-message-link-go-down
|
(define-key "down" #'open-message-link-go-down *open-message-link-keymap*)
|
||||||
*open-message-link-keymap*)
|
|
||||||
|
|
||||||
(define-key "q" #'close-open-message-link-window
|
(define-key "q" #'close-open-message-link-window *open-message-link-keymap*)
|
||||||
*open-message-link-keymap*)
|
|
||||||
|
;; chat window
|
||||||
|
|
||||||
|
(define-key "r" #'refresh-chat-messages *chats-list-keymap*)
|
||||||
|
|
||||||
|
(define-key "q" #'close-chats-list-window *chats-list-keymap*)
|
||||||
|
|
||||||
|
(define-key "C-J" #'show-chat-to-screen *chats-list-keymap*)
|
||||||
|
|
||||||
;;;; hooks
|
;;;; hooks
|
||||||
|
|
||||||
|
|
|
@ -59,44 +59,86 @@ editor = "nano --locking"
|
||||||
|
|
||||||
# Some examples follows, order matters!
|
# Some examples follows, order matters!
|
||||||
|
|
||||||
|
# http links
|
||||||
color-regexp = "http(s)?://[^ ]+" #ff0000
|
color-regexp = "http(s)?://[^ ]+" #ff0000
|
||||||
|
|
||||||
|
# gemini address header
|
||||||
|
|
||||||
color-regexp = "-> gemini://[^ ]+" yellow underline
|
color-regexp = "-> gemini://[^ ]+" yellow underline
|
||||||
|
|
||||||
|
#gemini links
|
||||||
|
|
||||||
color-regexp = "gemini://[^ ]+" #ff0000
|
color-regexp = "gemini://[^ ]+" #ff0000
|
||||||
|
|
||||||
|
# (c) and (r)
|
||||||
|
|
||||||
color-regexp = "(?i)(\\(c\\))|(\\(r\\))" #ff0000 bold
|
color-regexp = "(?i)(\\(c\\))|(\\(r\\))" #ff0000 bold
|
||||||
|
|
||||||
|
# date yyyy-mm-dd
|
||||||
|
|
||||||
color-regexp = "[0-9]{4}-[0-9]?[0-9]-[0-9]?[0-9]" #0000ff bold
|
color-regexp = "[0-9]{4}-[0-9]?[0-9]-[0-9]?[0-9]" #0000ff bold
|
||||||
|
|
||||||
|
# numbers
|
||||||
|
|
||||||
color-regexp = "-?[0-9]+(.[0-9]+)?%" #ff00ff bold
|
color-regexp = "-?[0-9]+(.[0-9]+)?%" #ff00ff bold
|
||||||
|
|
||||||
|
# *bold*
|
||||||
|
|
||||||
color-regexp = "\*[^*]+\*" #ffff00 bold
|
color-regexp = "\*[^*]+\*" #ffff00 bold
|
||||||
|
|
||||||
|
# _underline_
|
||||||
|
|
||||||
color-regexp = "_[^_]+_" #ffff00 underline
|
color-regexp = "_[^_]+_" #ffff00 underline
|
||||||
|
|
||||||
color-regexp = "/[^/]+/" #ffff00 italic
|
# /italic/
|
||||||
|
|
||||||
|
#color-regexp = "/[^/]+/" #ffff00 italic
|
||||||
|
|
||||||
|
# by default polls uses that
|
||||||
|
|
||||||
color-regexp = "⯀" green bold
|
color-regexp = "⯀" green bold
|
||||||
|
|
||||||
color-regexp = "The poll has expired" #ff00ff bold
|
color-regexp = "The poll has expired" #ff00ff bold
|
||||||
|
|
||||||
|
# HH:MM
|
||||||
|
|
||||||
|
color-regexp = "[012][0-9]:[0123456][0-9]" cyan bold
|
||||||
|
|
||||||
|
# your username mentioned
|
||||||
|
|
||||||
|
#color-regexp = "your-username" #ff00ff bold
|
||||||
|
|
||||||
# gemini colorization
|
# gemini colorization
|
||||||
|
|
||||||
|
# gemini links
|
||||||
color-regexp = "→ .+" blue bold
|
color-regexp = "→ .+" blue bold
|
||||||
|
|
||||||
|
# non gemini links
|
||||||
|
|
||||||
color-regexp = "➶ .+" magenta bold
|
color-regexp = "➶ .+" magenta bold
|
||||||
|
|
||||||
|
# header level 1
|
||||||
|
|
||||||
color-regexp = "🞂 .+" white bold
|
color-regexp = "🞂 .+" white bold
|
||||||
|
|
||||||
|
# header level 2
|
||||||
|
|
||||||
color-regexp = "🞓 .+" blue bold
|
color-regexp = "🞓 .+" blue bold
|
||||||
|
|
||||||
|
# header level 3
|
||||||
|
|
||||||
color-regexp = "🞐 .+" yellow bold
|
color-regexp = "🞐 .+" yellow bold
|
||||||
|
|
||||||
|
# header level 4
|
||||||
|
|
||||||
color-regexp = "🞎 " yellow
|
color-regexp = "🞎 " yellow
|
||||||
|
|
||||||
|
# list bullet
|
||||||
|
|
||||||
color-regexp = "• " blue bold
|
color-regexp = "• " blue bold
|
||||||
|
|
||||||
|
# stream statuses
|
||||||
|
|
||||||
color-regexp = ":completed" green bold
|
color-regexp = ":completed" green bold
|
||||||
|
|
||||||
color-regexp = ":aborted" red
|
color-regexp = ":aborted" red
|
||||||
|
|
|
@ -0,0 +1,81 @@
|
||||||
|
;; tinmop: an humble mastodon client
|
||||||
|
;; Copyright (C) 2020 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 :api-pleroma)
|
||||||
|
|
||||||
|
(defmacro gen-translate-entity-field-fn (class-name)
|
||||||
|
`(defun ,(misc:format-fn-symbol t "decode-~a" class-name) (a)
|
||||||
|
(tooter:decode-entity ',class-name a)))
|
||||||
|
|
||||||
|
(gen-translate-entity-field-fn tooter:account)
|
||||||
|
|
||||||
|
(gen-translate-entity-field-fn tooter:emoji)
|
||||||
|
|
||||||
|
(gen-translate-entity-field-fn tooter:attachment)
|
||||||
|
|
||||||
|
(gen-translate-entity-field-fn tooter:card)
|
||||||
|
|
||||||
|
(tooter:define-entity chat-message
|
||||||
|
(message-id :field "id")
|
||||||
|
(unreadp :field "unread")
|
||||||
|
(emojis :translate-with #'decode-emoji)
|
||||||
|
(updated-at :translate-with #'tooter:convert-timestamp)
|
||||||
|
(created-at :translate-with #'tooter:convert-timestamp)
|
||||||
|
(content)
|
||||||
|
(chat-id :field "chat_id")
|
||||||
|
(card :translate-with #'decode-card)
|
||||||
|
(attachment :translate-with #'decode-attachment)
|
||||||
|
(account-id :field "account_id"))
|
||||||
|
|
||||||
|
(defmethod print-object ((object chat-message) stream)
|
||||||
|
(print-unreadable-object (object stream :type t)
|
||||||
|
(with-accessors ((message-id message-id)
|
||||||
|
(chat-id chat-id)
|
||||||
|
(unreadp unreadp)
|
||||||
|
(content content)
|
||||||
|
(account-id account-id)
|
||||||
|
(attachment attachment)) object
|
||||||
|
(format stream
|
||||||
|
"chat ~a id ~a unread ~a content ~s sender account ~a attachment ~a"
|
||||||
|
chat-id
|
||||||
|
message-id
|
||||||
|
unreadp
|
||||||
|
content
|
||||||
|
account-id
|
||||||
|
attachment))))
|
||||||
|
|
||||||
|
(tooter:define-entity chat
|
||||||
|
(chat-id :field "id")
|
||||||
|
(updated-at :translate-with #'tooter:convert-timestamp)
|
||||||
|
(created-at :translate-with #'tooter:convert-timestamp)
|
||||||
|
(unread-count :field "unread")
|
||||||
|
(last-message :field "last_message" :translate-with #'decode-chat-message)
|
||||||
|
(account :translate-with #'decode-account))
|
||||||
|
|
||||||
|
(defmethod print-object ((object chat) stream)
|
||||||
|
(print-unreadable-object (object stream :type t)
|
||||||
|
(with-accessors ((chat-id chat-id)
|
||||||
|
(updated-at updated-at)
|
||||||
|
(unread-count unread-count)
|
||||||
|
(last-message last-message)
|
||||||
|
(account account)) object
|
||||||
|
(format stream
|
||||||
|
"id ~a updated-at ~a unread ~a last-message ~a account ~a"
|
||||||
|
chat-id
|
||||||
|
updated-at
|
||||||
|
unread-count
|
||||||
|
last-message
|
||||||
|
account))))
|
|
@ -26,68 +26,6 @@
|
||||||
(defmethod delete-notification ((object tooter:client) (notification tooter:notification))
|
(defmethod delete-notification ((object tooter:client) (notification tooter:notification))
|
||||||
(delete-notification object (tooter:id notification)))
|
(delete-notification object (tooter:id notification)))
|
||||||
|
|
||||||
(defmacro gen-translate-fn (class-name)
|
|
||||||
`(defun ,(misc:format-fn-symbol t "decode-~a" class-name) (a)
|
|
||||||
(tooter:decode-entity ',class-name a)))
|
|
||||||
|
|
||||||
(gen-translate-fn tooter:account)
|
|
||||||
|
|
||||||
(gen-translate-fn tooter:emoji)
|
|
||||||
|
|
||||||
(gen-translate-fn tooter:attachment)
|
|
||||||
|
|
||||||
(gen-translate-fn tooter:card)
|
|
||||||
|
|
||||||
(tooter:define-entity chat-message
|
|
||||||
(message-id :field "id")
|
|
||||||
(unreadp :field "unread")
|
|
||||||
(emojis :translate-with #'decode-emoji)
|
|
||||||
(updated-at :translate-with #'tooter:convert-timestamp)
|
|
||||||
(content)
|
|
||||||
(chat-id :field "chat_id")
|
|
||||||
(card :translate-with #'decode-card)
|
|
||||||
(attachment :translate-with #'decode-attachment)
|
|
||||||
(account-id :field "account_id"))
|
|
||||||
|
|
||||||
(defmethod print-object ((object chat-message) stream)
|
|
||||||
(print-unreadable-object (object stream :type t)
|
|
||||||
(with-accessors ((message-id message-id)
|
|
||||||
(chat-id chat-id)
|
|
||||||
(unreadp unreadp)
|
|
||||||
(content content)
|
|
||||||
(account-id account-id)
|
|
||||||
(attachment attachment)) object
|
|
||||||
(format stream
|
|
||||||
"chat ~a id ~a unread ~a content ~s sender account ~a attachment ~a"
|
|
||||||
chat-id
|
|
||||||
message-id
|
|
||||||
unreadp
|
|
||||||
content
|
|
||||||
account-id
|
|
||||||
attachment))))
|
|
||||||
|
|
||||||
(tooter:define-entity chat
|
|
||||||
(chat-id :field "id")
|
|
||||||
(updated-at :translate-with #'tooter:convert-timestamp)
|
|
||||||
(unread-count :field "unread")
|
|
||||||
(last-message :field "last_message" :translate-with #'decode-chat-message)
|
|
||||||
(account :translate-with #'decode-account))
|
|
||||||
|
|
||||||
(defmethod print-object ((object chat) stream)
|
|
||||||
(print-unreadable-object (object stream :type t)
|
|
||||||
(with-accessors ((chat-id chat-id)
|
|
||||||
(updated-at updated-at)
|
|
||||||
(unread-count unread-count)
|
|
||||||
(last-message last-message)
|
|
||||||
(account account)) object
|
|
||||||
(format stream
|
|
||||||
"id ~a updated-at ~a unread ~a last-message ~a account ~a"
|
|
||||||
chat-id
|
|
||||||
updated-at
|
|
||||||
unread-count
|
|
||||||
last-message
|
|
||||||
account))))
|
|
||||||
|
|
||||||
(defgeneric create-chat (object user-id))
|
(defgeneric create-chat (object user-id))
|
||||||
|
|
||||||
(defmethod create-chat ((object tooter:client) (account-id string))
|
(defmethod create-chat ((object tooter:client) (account-id string))
|
||||||
|
@ -100,7 +38,7 @@
|
||||||
(defgeneric get-all-chats (object))
|
(defgeneric get-all-chats (object))
|
||||||
|
|
||||||
(defmethod get-all-chats ((object tooter:client))
|
(defmethod get-all-chats ((object tooter:client))
|
||||||
"Geat a list o all chats, ordered from the more recent updated."
|
"Get a list of all chats, ordered from the more recent updated."
|
||||||
(decode-chat (tooter:query object "/api/v1/pleroma/chats")))
|
(decode-chat (tooter:query object "/api/v1/pleroma/chats")))
|
||||||
|
|
||||||
(defgeneric post-chat-message (object chat-id content media))
|
(defgeneric post-chat-message (object chat-id content media))
|
||||||
|
@ -144,3 +82,13 @@ media `media'. Returns a `chat-message' instance"
|
||||||
chat-id
|
chat-id
|
||||||
message-id)
|
message-id)
|
||||||
:http-method :delete)))
|
:http-method :delete)))
|
||||||
|
|
||||||
|
|
||||||
|
(defun-w-lock get-chat-messages (chat-id min-id)
|
||||||
|
api-client:*client-lock*
|
||||||
|
(fetch-chat-messages api-client:*client* chat-id :min-id min-id))
|
||||||
|
|
||||||
|
|
||||||
|
(defun-w-lock get-chats ()
|
||||||
|
api-client:*client-lock*
|
||||||
|
(get-all-chats api-client:*client*))
|
||||||
|
|
|
@ -0,0 +1,112 @@
|
||||||
|
;; tinmop: an humble mastodon client
|
||||||
|
;; Copyright (C) 2020 cage
|
||||||
|
|
||||||
|
;; This program is free software: you can redistribute it and/or modify
|
||||||
|
;; it under the terms of the GNU General Public License as published by
|
||||||
|
;; the Free Software Foundation, either version 3 of the License, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;; GNU General Public License for more details.
|
||||||
|
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this program.
|
||||||
|
;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
|
||||||
|
|
||||||
|
(in-package :chats-list-window)
|
||||||
|
|
||||||
|
(defclass chats-list-window (focus-marked-window
|
||||||
|
simple-line-navigation-window
|
||||||
|
title-window
|
||||||
|
border-window)
|
||||||
|
())
|
||||||
|
|
||||||
|
(defmethod refresh-config :after ((object chats-list-window))
|
||||||
|
(open-attach-window:refresh-view-links-window-config object
|
||||||
|
swconf:+key-open-gemini-stream-window+)
|
||||||
|
(let* ((win-w (truncate (* (win-width specials:*main-window*) 1/2)))
|
||||||
|
(win-h (truncate (* (win-height specials:*main-window*) 1/2)))
|
||||||
|
(x (truncate (- (/ (win-width specials:*main-window*) 2)
|
||||||
|
(/ win-w 2))))
|
||||||
|
(y (truncate (- (/ (win-height specials:*main-window*) 2)
|
||||||
|
(/ win-h 2)))))
|
||||||
|
(win-resize object win-w win-h)
|
||||||
|
(win-move object x y)
|
||||||
|
object))
|
||||||
|
|
||||||
|
(defun chat->list-item (chat-db-row)
|
||||||
|
(format nil
|
||||||
|
(_ "~@[~a~]~@[~a~] ~a unread: ~a")
|
||||||
|
(db:row-id chat-db-row)
|
||||||
|
(db:row-label chat-db-row)
|
||||||
|
(db:user-id->username (db:row-account-id chat-db-row))
|
||||||
|
(db:count-unread-chat-messages (db:row-id chat-db-row))))
|
||||||
|
|
||||||
|
(defun chat->text (chat-db-row)
|
||||||
|
(with-output-to-string (stream)
|
||||||
|
(let ((all-messages (db:all-chat-messages (db:row-id chat-db-row))))
|
||||||
|
(dolist (message all-messages)
|
||||||
|
(let* ((date-fmt (or (swconf:date-fmt swconf:+key-chat-window+)
|
||||||
|
(swconf:date-fmt swconf:+key-thread-window+)))
|
||||||
|
(created-date (db:row-created-at message))
|
||||||
|
(encoded-created-date (db-utils:encode-datetime-string created-date))
|
||||||
|
(formatted-created-date (format-time encoded-created-date date-fmt))
|
||||||
|
(attachment (db:attachment-to-chat-message (db:row-id message)))
|
||||||
|
(attachment-type (if attachment
|
||||||
|
(format nil "~a attachment" (db:row-type attachment))
|
||||||
|
""))
|
||||||
|
(content (or (db:row-message-content message)
|
||||||
|
""))
|
||||||
|
(username (db:user-id->username (db:row-account-id message))))
|
||||||
|
(format stream
|
||||||
|
(_ "~a ~a said:~%~a ~a~2%")
|
||||||
|
formatted-created-date
|
||||||
|
username
|
||||||
|
content
|
||||||
|
attachment-type))))))
|
||||||
|
|
||||||
|
(defmethod resync-rows-db ((object chats-list-window)
|
||||||
|
&key
|
||||||
|
(redraw t)
|
||||||
|
(suggested-message-index nil))
|
||||||
|
(with-accessors ((rows rows)
|
||||||
|
(selected-line-bg selected-line-bg)
|
||||||
|
(selected-line-fg selected-line-fg)) object
|
||||||
|
(flet ((make-rows (chats bg fg)
|
||||||
|
(mapcar (lambda (chat)
|
||||||
|
(make-instance 'line
|
||||||
|
:normal-text (chat->list-item chat)
|
||||||
|
:selected-text (chat->list-item chat)
|
||||||
|
:fields chat
|
||||||
|
:normal-bg bg
|
||||||
|
:normal-fg fg
|
||||||
|
:selected-bg fg
|
||||||
|
:selected-fg bg))
|
||||||
|
chats)))
|
||||||
|
(with-croatoan-window (croatoan-window object)
|
||||||
|
(setf rows (make-rows (db:all-chats)
|
||||||
|
selected-line-bg
|
||||||
|
selected-line-fg))
|
||||||
|
(when suggested-message-index
|
||||||
|
(select-row object suggested-message-index))
|
||||||
|
(when redraw
|
||||||
|
(draw object))))))
|
||||||
|
|
||||||
|
(defun open-chats-list-window ()
|
||||||
|
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
|
||||||
|
(setf *chats-list-window*
|
||||||
|
(make-instance 'chats-list-window
|
||||||
|
:top-row-padding 0
|
||||||
|
:title (_ "Current chats")
|
||||||
|
:single-row-height 1
|
||||||
|
:uses-border-p t
|
||||||
|
:keybindings keybindings:*chats-list-keymap*
|
||||||
|
:croatoan-window low-level-window))
|
||||||
|
(refresh-config *chats-list-window*)
|
||||||
|
(resync-rows-db *chats-list-window* :redraw nil)
|
||||||
|
(when (rows *chats-list-window*)
|
||||||
|
(select-row *chats-list-window* 0))
|
||||||
|
(draw *chats-list-window*)
|
||||||
|
*chats-list-window*))
|
165
src/db.lisp
165
src/db.lisp
|
@ -272,25 +272,39 @@
|
||||||
" bitrate TEXT,"
|
" bitrate TEXT,"
|
||||||
" description TEXT,"
|
" description TEXT,"
|
||||||
" blurhash TEXT,"
|
" blurhash TEXT,"
|
||||||
" \"status-id\" TEXT"
|
" \"attached-to-id\" TEXT"
|
||||||
+make-close+)))
|
+make-close+)))
|
||||||
|
|
||||||
(defun make-chat ()
|
(defun make-chat ()
|
||||||
(query-low-level (strcat (prepare-table +table-chat+ :autogenerated-id-p nil)
|
(query-low-level (strcat (prepare-table +table-chat+ :autogenerated-id-p nil)
|
||||||
"id TEXT NOT NULL,"
|
"id TEXT NOT NULL,"
|
||||||
|
;; timestamp
|
||||||
" \"updated-at\" TEXT NOT NULL,"
|
" \"updated-at\" TEXT NOT NULL,"
|
||||||
" \"unread-count\" INTEGER DEFAULT 0"
|
;; timestamp
|
||||||
|
" \"created-at\" TEXT NOT NULL,"
|
||||||
|
" \"unread-count\" INTEGER DEFAULT 0,"
|
||||||
|
" label TEXT DEFAULT \"-\" ,"
|
||||||
|
;; boolean
|
||||||
|
" ignoredp INTEGER DEFAULT 0,"
|
||||||
|
|
||||||
|
" \"account-id\" TEXT NOT NULL"
|
||||||
|
(make-foreign +table-account+ "id" +cascade+ +cascade+)
|
||||||
+make-close+)))
|
+make-close+)))
|
||||||
|
|
||||||
(defun make-chat-message ()
|
(defun make-chat-message ()
|
||||||
(query-low-level (strcat (prepare-table +table-chat-message+ :autogenerated-id-p nil)
|
(query-low-level (strcat (prepare-table +table-chat-message+ :autogenerated-id-p nil)
|
||||||
"id TEXT NOT NULL,"
|
"id TEXT NOT NULL,"
|
||||||
;; boolean
|
;; boolean
|
||||||
" unreadp INTEGER DEFAULT 0,"
|
" unreadp INTEGER DEFAULT 1,"
|
||||||
" content TEXT,"
|
" content TEXT,"
|
||||||
" \"chat-id\" TEXT "
|
" \"chat-id\" TEXT, "
|
||||||
(make-foreign +table-chat+ "id" +cascade+ +cascade+) +col-sep+
|
;; timestamp
|
||||||
" \"attachment-id\" TEXT NOT NULL"
|
" \"updated-at\" TEXT,"
|
||||||
|
;; timestamp
|
||||||
|
" \"created-at\" TEXT NOT NULL,"
|
||||||
|
" \"attachment-id\" TEXT,"
|
||||||
|
" \"account-id\" TEXT NOT NULL"
|
||||||
|
(make-foreign +table-account+ "id" +cascade+ +cascade+)
|
||||||
+make-close+)))
|
+make-close+)))
|
||||||
|
|
||||||
(defun make-conversation ()
|
(defun make-conversation ()
|
||||||
|
@ -889,7 +903,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
|
||||||
(voted tooter:voted)
|
(voted tooter:voted)
|
||||||
(own-votes tooter:own-votes)
|
(own-votes tooter:own-votes)
|
||||||
(options tooter:options)) object
|
(options tooter:options)) object
|
||||||
(let* ((expire-date (prepare-for-db expires-at))
|
(let* ((expire-date (decode-datetime-string expires-at))
|
||||||
(actual-expired (prepare-for-db expired :to-integer t))
|
(actual-expired (prepare-for-db expired :to-integer t))
|
||||||
(actual-multiple (prepare-for-db multiple :to-integer t))
|
(actual-multiple (prepare-for-db multiple :to-integer t))
|
||||||
(actual-voted (prepare-for-db voted :to-integer t))
|
(actual-voted (prepare-for-db voted :to-integer t))
|
||||||
|
@ -921,7 +935,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
|
||||||
(loop for option in options do
|
(loop for option in options do
|
||||||
(update-db option :poll-id id)))))
|
(update-db option :poll-id id)))))
|
||||||
|
|
||||||
(defmethod update-db ((object tooter:attachment) &key (status-id nil) &allow-other-keys)
|
(defmethod update-db ((object tooter:attachment) &key (attached-to-id nil) &allow-other-keys)
|
||||||
(with-accessors ((id tooter:id)
|
(with-accessors ((id tooter:id)
|
||||||
(kind tooter:kind)
|
(kind tooter:kind)
|
||||||
(url tooter:url)
|
(url tooter:url)
|
||||||
|
@ -931,7 +945,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
|
||||||
(metadata tooter:metadata)
|
(metadata tooter:metadata)
|
||||||
(description tooter:description)
|
(description tooter:description)
|
||||||
(blurhash tooter:blurhash)) object
|
(blurhash tooter:blurhash)) object
|
||||||
(assert status-id)
|
(assert attached-to-id)
|
||||||
(let* ((actual-attachment-type (prepare-for-db kind))
|
(let* ((actual-attachment-type (prepare-for-db kind))
|
||||||
(original-file-metadata (metadata-original metadata))
|
(original-file-metadata (metadata-original metadata))
|
||||||
(width (prepare-for-db (metadata-width original-file-metadata)))
|
(width (prepare-for-db (metadata-width original-file-metadata)))
|
||||||
|
@ -953,7 +967,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
|
||||||
:bitrate
|
:bitrate
|
||||||
:description
|
:description
|
||||||
:blurhash
|
:blurhash
|
||||||
:status-id)
|
:attached-to-id)
|
||||||
(id
|
(id
|
||||||
actual-attachment-type
|
actual-attachment-type
|
||||||
url
|
url
|
||||||
|
@ -967,11 +981,13 @@ than (swconf:config-purge-history-days-offset) days in the past"
|
||||||
bitrate
|
bitrate
|
||||||
description
|
description
|
||||||
blurhash
|
blurhash
|
||||||
status-id)))
|
attached-to-id)))
|
||||||
(attachment-exists-p (fetch-single (select :*
|
(attachment-exists-p (fetch-single (select :*
|
||||||
(from +table-attachment+)
|
(from +table-attachment+)
|
||||||
(where (:and (:= :status-id status-id)
|
(where (:and (:= :attached-to-id
|
||||||
(:= :id id)))))))
|
attached-to-id)
|
||||||
|
(:= :id
|
||||||
|
id)))))))
|
||||||
(when (not attachment-exists-p)
|
(when (not attachment-exists-p)
|
||||||
(query insert-query)))))
|
(query insert-query)))))
|
||||||
|
|
||||||
|
@ -1007,7 +1023,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
|
||||||
(statuses-count tooter:statuses-count)
|
(statuses-count tooter:statuses-count)
|
||||||
(moved tooter:moved)
|
(moved tooter:moved)
|
||||||
(bot tooter:bot)) object
|
(bot tooter:bot)) object
|
||||||
(let ((actual-created-at (prepare-for-db created-at))
|
(let ((actual-created-at (decode-datetime-string created-at))
|
||||||
(actual-botp (prepare-for-db bot :to-integer t))
|
(actual-botp (prepare-for-db bot :to-integer t))
|
||||||
(actual-discoverable (prepare-for-db discoverable :to-integer t))
|
(actual-discoverable (prepare-for-db discoverable :to-integer t))
|
||||||
(actual-locked (prepare-for-db locked :to-integer t))
|
(actual-locked (prepare-for-db locked :to-integer t))
|
||||||
|
@ -1189,7 +1205,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
|
||||||
;; reference from this table to table status
|
;; reference from this table to table status
|
||||||
(map nil
|
(map nil
|
||||||
(lambda (media-attachment)
|
(lambda (media-attachment)
|
||||||
(update-db media-attachment :status-id id))
|
(update-db media-attachment :attached-to-id id))
|
||||||
media-attachments)
|
media-attachments)
|
||||||
(loop
|
(loop
|
||||||
for tag in tags
|
for tag in tags
|
||||||
|
@ -1206,6 +1222,104 @@ than (swconf:config-purge-history-days-offset) days in the past"
|
||||||
(when poll
|
(when poll
|
||||||
(update-db poll :status-id id)))))))
|
(update-db poll :status-id id)))))))
|
||||||
|
|
||||||
|
(defun find-chat (chat-id)
|
||||||
|
(fetch-single (select :*
|
||||||
|
(from +table-chat+)
|
||||||
|
(where (:= :id chat-id)))))
|
||||||
|
|
||||||
|
(defun chat-message-exists-p (chat-id message-id)
|
||||||
|
(query (select :*
|
||||||
|
(from +table-chat-message+)
|
||||||
|
(where (:and (:= :chat-id chat-id)
|
||||||
|
(:= :message-id message-id))))))
|
||||||
|
|
||||||
|
(defun mark-all-chat-messages-read (chat-id)
|
||||||
|
(query (make-update +table-chat-message+
|
||||||
|
(:unreadp)
|
||||||
|
(+db-false+)
|
||||||
|
(:= :chat-id chat-id))))
|
||||||
|
|
||||||
|
(defun count-unread-chat-messages (chat-id)
|
||||||
|
(second (fetch-single (select (fields (:count :id))
|
||||||
|
(from +table-chat-message+)
|
||||||
|
(where (:and (:= :chat-id chat-id)
|
||||||
|
(:= :unreadp +db-true+)))))))
|
||||||
|
|
||||||
|
(defmethod update-db ((object api-pleroma:chat-message) &key &allow-other-keys)
|
||||||
|
(with-accessors ((message-id api-pleroma:message-id)
|
||||||
|
(emojis api-pleroma:emojis)
|
||||||
|
(updated-at api-pleroma:updated-at)
|
||||||
|
(created-at api-pleroma:created-at)
|
||||||
|
(content api-pleroma:content)
|
||||||
|
(chat-id api-pleroma:chat-id)
|
||||||
|
(attachment api-pleroma:attachment)
|
||||||
|
(account-id api-pleroma:account-id)) object
|
||||||
|
(when (and (user-id->user account-id)
|
||||||
|
(not (chat-message-exists-p chat-id message-id)))
|
||||||
|
(update-db attachment :attached-to-id message-id)
|
||||||
|
(let ((attachment-id (and attachment
|
||||||
|
(tooter:id attachment)))
|
||||||
|
(actual-updated-at (decode-datetime-string updated-at))
|
||||||
|
(actual-created-at (decode-datetime-string created-at)))
|
||||||
|
(query (make-insert +table-chat-message+
|
||||||
|
(:id
|
||||||
|
:content
|
||||||
|
:chat-id
|
||||||
|
:attachment-id
|
||||||
|
:account-id
|
||||||
|
:updated-at
|
||||||
|
:created-at)
|
||||||
|
(message-id
|
||||||
|
content
|
||||||
|
chat-id
|
||||||
|
attachment-id
|
||||||
|
account-id
|
||||||
|
actual-updated-at
|
||||||
|
actual-created-at)))))))
|
||||||
|
|
||||||
|
(defun chat-exists-p (chat-id)
|
||||||
|
(query (select :*
|
||||||
|
(from +table-chat+)
|
||||||
|
(where (:= :id chat-id)))))
|
||||||
|
|
||||||
|
(defun all-chats ()
|
||||||
|
"Return all chats ordered by most recent updated to last recent updated"
|
||||||
|
(query (select :*
|
||||||
|
(from +table-chat+)
|
||||||
|
(order-by (:desc :updated-at)))))
|
||||||
|
|
||||||
|
(defun all-chat-messages (chat-id)
|
||||||
|
"Return all messages belonging to `chat-id' ordered by `message-id'
|
||||||
|
in ascending order"
|
||||||
|
(query (select :*
|
||||||
|
(from +table-chat-message+)
|
||||||
|
(where (:= :chat-id chat-id))
|
||||||
|
(order-by (:asc :message-id)))))
|
||||||
|
|
||||||
|
(defun last-chat-message-id (chat-id)
|
||||||
|
(second (fetch-single (select ((:as (fields (:max :id)) :max-id))
|
||||||
|
(from +table-chat-message+)
|
||||||
|
(where (:= :chat-id chat-id))))))
|
||||||
|
|
||||||
|
(defmethod update-db ((object api-pleroma:chat) &key &allow-other-keys)
|
||||||
|
(with-accessors ((chat-id api-pleroma:chat-id)
|
||||||
|
(updated-at api-pleroma:updated-at)
|
||||||
|
(created-at api-pleroma:created-at)
|
||||||
|
(account api-pleroma:account)) object
|
||||||
|
(when (not (chat-exists-p chat-id))
|
||||||
|
(let ((actual-updated-at (decode-datetime-string updated-at))
|
||||||
|
(actual-created-at (decode-datetime-string created-at)))
|
||||||
|
(update-db account)
|
||||||
|
(query (make-insert +table-chat+
|
||||||
|
(:id
|
||||||
|
:account-id
|
||||||
|
:updated-at
|
||||||
|
:created-at)
|
||||||
|
(chat-id
|
||||||
|
(tooter:id account)
|
||||||
|
actual-updated-at
|
||||||
|
actual-created-at)))))))
|
||||||
|
|
||||||
(defun maybe-decrypt-update-status-text (status-id timeline folder)
|
(defun maybe-decrypt-update-status-text (status-id timeline folder)
|
||||||
"Decrypt, if possible, status identified by `status-id', `timeline' and `folder'.
|
"Decrypt, if possible, status identified by `status-id', `timeline' and `folder'.
|
||||||
|
|
||||||
|
@ -1575,6 +1689,20 @@ row."
|
||||||
|
|
||||||
(gen-access-message-row expire-date :expire-date)
|
(gen-access-message-row expire-date :expire-date)
|
||||||
|
|
||||||
|
(gen-access-message-row chat-id :chat-id)
|
||||||
|
|
||||||
|
(gen-access-message-row account-id :account-id)
|
||||||
|
|
||||||
|
(gen-access-message-row updated-at :updated-at)
|
||||||
|
|
||||||
|
(gen-access-message-row created-at :created-at)
|
||||||
|
|
||||||
|
(gen-access-message-row text-url :text-url)
|
||||||
|
|
||||||
|
(gen-access-message-row type :type)
|
||||||
|
|
||||||
|
(gen-access-message-row label :label)
|
||||||
|
|
||||||
(defun row-votes-count (row)
|
(defun row-votes-count (row)
|
||||||
(and row (db-getf row :votes-count 0)))
|
(and row (db-getf row :votes-count 0)))
|
||||||
|
|
||||||
|
@ -1749,7 +1877,12 @@ messages are sorted as below:
|
||||||
(defun all-attachments-to-status (status-id)
|
(defun all-attachments-to-status (status-id)
|
||||||
(fetch-all-rows (select :*
|
(fetch-all-rows (select :*
|
||||||
(from +table-attachment+)
|
(from +table-attachment+)
|
||||||
(where (:= :status-id status-id)))))
|
(where (:= :attached-to-id status-id)))))
|
||||||
|
|
||||||
|
(defun attachment-to-chat-message (chat-message-id)
|
||||||
|
(fetch-single (select :*
|
||||||
|
(from +table-attachment+)
|
||||||
|
(where (:= :attached-to-id chat-message-id)))))
|
||||||
|
|
||||||
(defun status->reblogged-status (wrapper-status-id)
|
(defun status->reblogged-status (wrapper-status-id)
|
||||||
"Return the status that identified by `wrapper-status-id'
|
"Return the status that identified by `wrapper-status-id'
|
||||||
|
|
|
@ -544,28 +544,28 @@
|
||||||
(when redraw
|
(when redraw
|
||||||
(draw object))))))
|
(draw object))))))
|
||||||
|
|
||||||
(defmethod draw :before ((object gemini-streams-window))
|
;; (defmethod draw :before ((object gemini-streams-window))
|
||||||
(with-accessors ((rows rows)
|
;; (with-accessors ((rows rows)
|
||||||
(uses-border-p uses-border-p)
|
;; (uses-border-p uses-border-p)
|
||||||
(single-row-height single-row-height)
|
;; (single-row-height single-row-height)
|
||||||
(top-row-padding top-row-padding)
|
;; (top-row-padding top-row-padding)
|
||||||
(new-messages-mark new-messages-mark)
|
;; (new-messages-mark new-messages-mark)
|
||||||
(top-rows-slice top-rows-slice)
|
;; (top-rows-slice top-rows-slice)
|
||||||
(bottom-rows-slice bottom-rows-slice)) object
|
;; (bottom-rows-slice bottom-rows-slice)) object
|
||||||
(let ((y-start (if uses-border-p
|
;; (let ((y-start (if uses-border-p
|
||||||
1
|
;; 1
|
||||||
0)))
|
;; 0)))
|
||||||
(renderizable-rows-data object) ; set top and bottom slice
|
;; (renderizable-rows-data object) ; set top and bottom slice
|
||||||
(win-clear object)
|
;; (win-clear object)
|
||||||
(with-croatoan-window (croatoan-window object)
|
;; (with-croatoan-window (croatoan-window object)
|
||||||
(loop
|
;; (loop
|
||||||
for gemini-stream in (safe-subseq rows top-rows-slice bottom-rows-slice)
|
;; for gemini-stream in (safe-subseq rows top-rows-slice bottom-rows-slice)
|
||||||
for y from (+ y-start top-row-padding) by single-row-height do
|
;; for y from (+ y-start top-row-padding) by single-row-height do
|
||||||
(print-text object
|
;; (print-text object
|
||||||
gemini-stream
|
;; gemini-stream
|
||||||
1 y
|
;; 1 y
|
||||||
:bgcolor (bgcolor croatoan-window)
|
;; :bgcolor (bgcolor croatoan-window)
|
||||||
:fgcolor (fgcolor croatoan-window)))))))
|
;; :fgcolor (fgcolor croatoan-window)))))))
|
||||||
|
|
||||||
(defun open-gemini-stream-window ()
|
(defun open-gemini-stream-window ()
|
||||||
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
|
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
|
||||||
|
|
|
@ -255,6 +255,9 @@ produces a tree and graft the latter on `existing-tree'"
|
||||||
(defparameter *gemini-downloads-keymap* (make-starting-comand-tree)
|
(defparameter *gemini-downloads-keymap* (make-starting-comand-tree)
|
||||||
"The keymap for window that shows all gemini streams.")
|
"The keymap for window that shows all gemini streams.")
|
||||||
|
|
||||||
|
(defparameter *chats-list-keymap* (make-starting-comand-tree)
|
||||||
|
"The keymap for window that shows all the chats.")
|
||||||
|
|
||||||
(defun define-key (key-sequence function &optional (existing-keymap *global-keymap*))
|
(defun define-key (key-sequence function &optional (existing-keymap *global-keymap*))
|
||||||
"Define a key sequence that trigger a function:
|
"Define a key sequence that trigger a function:
|
||||||
|
|
||||||
|
|
|
@ -144,11 +144,12 @@ etc.) happened"
|
||||||
(unwind-protect
|
(unwind-protect
|
||||||
(progn
|
(progn
|
||||||
(hooks:run-hooks 'hooks:*before-main-loop*)
|
(hooks:run-hooks 'hooks:*before-main-loop*)
|
||||||
|
(ui:update-all-chats-data)
|
||||||
(run-event-loop croatoan-window))
|
(run-event-loop croatoan-window))
|
||||||
(end-screen)))))
|
(end-screen)))))
|
||||||
|
|
||||||
(defun load-script-file ()
|
(defun load-script-file ()
|
||||||
"Load (exexute) a lisp file used in requests of a command line switch"
|
"Load (execute) a lisp file used in requests of a command line switch"
|
||||||
(setf program-events:*process-events-immediately* t)
|
(setf program-events:*process-events-immediately* t)
|
||||||
(load-configuration-files)
|
(load-configuration-files)
|
||||||
(init-db)
|
(init-db)
|
||||||
|
|
|
@ -721,6 +721,14 @@
|
||||||
:find-poll
|
:find-poll
|
||||||
:find-poll-option
|
:find-poll-option
|
||||||
:find-poll-bound-to-status
|
:find-poll-bound-to-status
|
||||||
|
:chat-message-exists-p
|
||||||
|
:find-chat
|
||||||
|
:mark-all-chat-messages-read
|
||||||
|
:count-unread-chat-messages
|
||||||
|
:chat-exists-p
|
||||||
|
:all-chats
|
||||||
|
:all-chat-messages
|
||||||
|
:last-chat-message-id
|
||||||
:update-db
|
:update-db
|
||||||
:message-root
|
:message-root
|
||||||
:message-children
|
:message-children
|
||||||
|
@ -733,6 +741,8 @@
|
||||||
:find-message-id
|
:find-message-id
|
||||||
:data-id
|
:data-id
|
||||||
:row-id
|
:row-id
|
||||||
|
:row-type
|
||||||
|
:row-label
|
||||||
:row-message-visibility
|
:row-message-visibility
|
||||||
:row-message-status-id
|
:row-message-status-id
|
||||||
:row-message-index
|
:row-message-index
|
||||||
|
@ -756,8 +766,13 @@
|
||||||
:row-poll-multiple-vote-p
|
:row-poll-multiple-vote-p
|
||||||
:row-title
|
:row-title
|
||||||
:row-expire-date
|
:row-expire-date
|
||||||
|
:row-account-id
|
||||||
|
:row-updated-at
|
||||||
|
:row-created-at
|
||||||
|
:row-chat-id
|
||||||
:row-votes-count
|
:row-votes-count
|
||||||
:row-message-reply-to-id
|
:row-message-reply-to-id
|
||||||
|
:row-text-url
|
||||||
:next-status-tree
|
:next-status-tree
|
||||||
:previous-status-tree
|
:previous-status-tree
|
||||||
:message-tree-root-equal
|
:message-tree-root-equal
|
||||||
|
@ -765,6 +780,7 @@
|
||||||
:renumber-timeline-message-index
|
:renumber-timeline-message-index
|
||||||
:renumber-all-timelines
|
:renumber-all-timelines
|
||||||
:all-attachments-to-status
|
:all-attachments-to-status
|
||||||
|
:attachment-to-chat-message
|
||||||
:all-attachments-urls-to-status
|
:all-attachments-urls-to-status
|
||||||
:mark-status-red-p
|
:mark-status-red-p
|
||||||
:mark-status-unread
|
:mark-status-unread
|
||||||
|
@ -919,6 +935,7 @@
|
||||||
:+key-main-window+
|
:+key-main-window+
|
||||||
:+key-thread-window+
|
:+key-thread-window+
|
||||||
:+key-message-window+
|
:+key-message-window+
|
||||||
|
:+key-chat-window+
|
||||||
:+key-favourite+
|
:+key-favourite+
|
||||||
:+key-sensitive+
|
:+key-sensitive+
|
||||||
:+key-boosted+
|
:+key-boosted+
|
||||||
|
@ -1108,7 +1125,8 @@
|
||||||
:*conversations-window*
|
:*conversations-window*
|
||||||
:*open-attach-window*
|
:*open-attach-window*
|
||||||
:*open-message-link-window*
|
:*open-message-link-window*
|
||||||
:*gemini-streams-window*))
|
:*gemini-streams-window*
|
||||||
|
:*chats-list-window*))
|
||||||
|
|
||||||
(defpackage :complete
|
(defpackage :complete
|
||||||
(:use
|
(:use
|
||||||
|
@ -1217,10 +1235,14 @@
|
||||||
:poll-vote-event
|
:poll-vote-event
|
||||||
:gemini-request-event
|
:gemini-request-event
|
||||||
:gemini-back-event
|
:gemini-back-event
|
||||||
:function-event
|
|
||||||
:gemini-got-line-event
|
:gemini-got-line-event
|
||||||
:gemini-abort-downloading-event
|
:gemini-abort-downloading-event
|
||||||
:gemini-enqueue-download-event
|
:gemini-enqueue-download-event
|
||||||
|
:get-chat-messages-event
|
||||||
|
:get-chats-event
|
||||||
|
:chat-show-event
|
||||||
|
:update-all-chat-messages-event
|
||||||
|
:function-event
|
||||||
:dispatch-program-events
|
:dispatch-program-events
|
||||||
:add-pagination-status-event
|
:add-pagination-status-event
|
||||||
:status-id
|
:status-id
|
||||||
|
@ -1231,21 +1253,32 @@
|
||||||
:cl
|
:cl
|
||||||
:alexandria
|
:alexandria
|
||||||
:config
|
:config
|
||||||
:constants)
|
:constants
|
||||||
|
:misc)
|
||||||
|
(:shadowing-import-from :misc :random-elt :shuffle)
|
||||||
(:export
|
(:export
|
||||||
:delete-notification
|
:delete-notification
|
||||||
|
:chat-message
|
||||||
:message-id
|
:message-id
|
||||||
:nreadp
|
:nreadp
|
||||||
|
:emojis
|
||||||
:updated-at
|
:updated-at
|
||||||
|
:created-at
|
||||||
:content
|
:content
|
||||||
:chat-id
|
:chat-id
|
||||||
:unreadp
|
:attachment
|
||||||
:emojis
|
:account-id
|
||||||
|
:chat
|
||||||
|
:unread-count
|
||||||
|
:last-message
|
||||||
|
:account
|
||||||
:create-chat
|
:create-chat
|
||||||
:get-all-chats
|
:get-all-chats
|
||||||
:post-chat-message
|
:post-chat-message
|
||||||
:fetch-chat-messages
|
:fetch-chat-messages
|
||||||
:delete-chat-message))
|
:delete-chat-message
|
||||||
|
:get-chat-messages
|
||||||
|
:get-chats))
|
||||||
|
|
||||||
(defpackage :api-client
|
(defpackage :api-client
|
||||||
(:use
|
(:use
|
||||||
|
@ -1261,6 +1294,7 @@
|
||||||
(:nicknames :client)
|
(:nicknames :client)
|
||||||
(:export
|
(:export
|
||||||
:*client*
|
:*client*
|
||||||
|
:*client-lock*
|
||||||
:forget-credentials
|
:forget-credentials
|
||||||
:authorize
|
:authorize
|
||||||
:favourite-status
|
:favourite-status
|
||||||
|
@ -1350,6 +1384,7 @@
|
||||||
:*open-message-link-keymap*
|
:*open-message-link-keymap*
|
||||||
:*open-gemini-link-keymap*
|
:*open-gemini-link-keymap*
|
||||||
:*gemini-downloads-keymap*
|
:*gemini-downloads-keymap*
|
||||||
|
:*chats-list-keymap*
|
||||||
:define-key
|
:define-key
|
||||||
:init-keyboard-mapping
|
:init-keyboard-mapping
|
||||||
:find-keymap-node
|
:find-keymap-node
|
||||||
|
@ -1911,6 +1946,28 @@
|
||||||
:resync-rows-db
|
:resync-rows-db
|
||||||
:init))
|
:init))
|
||||||
|
|
||||||
|
(defpackage :chats-list-window
|
||||||
|
(:use
|
||||||
|
:cl
|
||||||
|
:alexandria
|
||||||
|
:cl-ppcre
|
||||||
|
:access
|
||||||
|
:croatoan
|
||||||
|
:config
|
||||||
|
:constants
|
||||||
|
:text-utils
|
||||||
|
:misc
|
||||||
|
:mtree
|
||||||
|
:specials
|
||||||
|
:windows
|
||||||
|
:line-oriented-window
|
||||||
|
:tui-utils)
|
||||||
|
(:shadowing-import-from :misc :random-elt :shuffle)
|
||||||
|
(:export
|
||||||
|
:chats-list-window
|
||||||
|
:chat->text
|
||||||
|
:open-chats-list-window))
|
||||||
|
|
||||||
(defpackage :gemini-viewer
|
(defpackage :gemini-viewer
|
||||||
(:use
|
(:use
|
||||||
:cl
|
:cl
|
||||||
|
@ -2115,6 +2172,12 @@
|
||||||
:show-about-window
|
:show-about-window
|
||||||
:reset-timeline-pagination
|
:reset-timeline-pagination
|
||||||
:poll-vote
|
:poll-vote
|
||||||
|
:refresh-chats
|
||||||
|
:refresh-chat-messages
|
||||||
|
:close-chats-list-window
|
||||||
|
:update-all-chats-data
|
||||||
|
:open-chats-list-window
|
||||||
|
:show-chat-to-screen
|
||||||
:open-gemini-address
|
:open-gemini-address
|
||||||
:gemini-history-back
|
:gemini-history-back
|
||||||
:gemini-view-source
|
:gemini-view-source
|
||||||
|
|
|
@ -981,6 +981,62 @@
|
||||||
(with-accessors ((stream-object payload)) object
|
(with-accessors ((stream-object payload)) object
|
||||||
(gemini-viewer:push-db-stream stream-object)))
|
(gemini-viewer:push-db-stream stream-object)))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; 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)
|
||||||
|
(db:update-db message)))))
|
||||||
|
|
||||||
|
(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
|
||||||
|
(let ((chats (api-pleroma:get-chats)))
|
||||||
|
(dolist (chat chats)
|
||||||
|
(db:update-db chat)))))
|
||||||
|
|
||||||
|
(defclass update-all-chat-messages-event (program-event) ())
|
||||||
|
|
||||||
|
(defmethod process-event ((object update-all-chat-messages-event))
|
||||||
|
(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)))
|
||||||
|
(program-events:push-event (make-instance 'program-events:get-chat-messages-event
|
||||||
|
:chat-id chat-id
|
||||||
|
:min-message-id min-id))))))
|
||||||
|
|
||||||
|
(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)
|
||||||
|
(setf (message-window:source-text specials:*message-window*)
|
||||||
|
(chats-list-window:chat->text chat))
|
||||||
|
(windows:draw specials:*message-window*))))
|
||||||
|
|
||||||
|
;;;; general usage
|
||||||
|
|
||||||
(defclass function-event (program-event) ())
|
(defclass function-event (program-event) ())
|
||||||
|
|
||||||
(defmethod process-event ((object function-event))
|
(defmethod process-event ((object function-event))
|
||||||
|
@ -988,6 +1044,7 @@
|
||||||
(assert (functionp payload))
|
(assert (functionp payload))
|
||||||
(funcall payload)))
|
(funcall payload)))
|
||||||
|
|
||||||
|
|
||||||
;;;; end events
|
;;;; end events
|
||||||
|
|
||||||
(defun dispatch-program-events ()
|
(defun dispatch-program-events ()
|
||||||
|
|
|
@ -363,6 +363,7 @@
|
||||||
main-window
|
main-window
|
||||||
thread-window
|
thread-window
|
||||||
message-window
|
message-window
|
||||||
|
chat-window
|
||||||
attachment-header
|
attachment-header
|
||||||
max-numbers-allowed-attachments
|
max-numbers-allowed-attachments
|
||||||
max-message-length
|
max-message-length
|
||||||
|
|
|
@ -54,3 +54,6 @@
|
||||||
|
|
||||||
(defparameter *gemini-streams-window* nil
|
(defparameter *gemini-streams-window* nil
|
||||||
"The window that shows all gemini-streams.")
|
"The window that shows all gemini-streams.")
|
||||||
|
|
||||||
|
(defparameter *chats-list-window* nil
|
||||||
|
"The window that shows all the chats.")
|
||||||
|
|
|
@ -354,6 +354,7 @@ Metadata includes:
|
||||||
(if print-message
|
(if print-message
|
||||||
(_ "focus passed on threads window")
|
(_ "focus passed on threads window")
|
||||||
nil)
|
nil)
|
||||||
|
*chats-list-window*
|
||||||
*gemini-streams-window*
|
*gemini-streams-window*
|
||||||
*open-message-link-window*
|
*open-message-link-window*
|
||||||
*open-attach-window*
|
*open-attach-window*
|
||||||
|
@ -367,7 +368,8 @@ Metadata includes:
|
||||||
specials:*message-window*
|
specials:*message-window*
|
||||||
:documentation "Move focus on message window"
|
:documentation "Move focus on message window"
|
||||||
:info-change-focus-message (_ "Focus passed on message window")
|
:info-change-focus-message (_ "Focus passed on message window")
|
||||||
:windows-lose-focus (specials:*gemini-streams-window*
|
:windows-lose-focus (*chats-list-window*
|
||||||
|
specials:*gemini-streams-window*
|
||||||
specials:*open-message-link-window*
|
specials:*open-message-link-window*
|
||||||
specials:*open-attach-window*
|
specials:*open-attach-window*
|
||||||
specials:*conversations-window*
|
specials:*conversations-window*
|
||||||
|
@ -380,7 +382,8 @@ Metadata includes:
|
||||||
specials:*send-message-window*
|
specials:*send-message-window*
|
||||||
:documentation "Move focus on send message window"
|
:documentation "Move focus on send message window"
|
||||||
:info-change-focus-message (_ "Focus passed on send message window")
|
:info-change-focus-message (_ "Focus passed on send message window")
|
||||||
:windows-lose-focus (specials:*gemini-streams-window*
|
:windows-lose-focus (*chats-list-window*
|
||||||
|
specials:*gemini-streams-window*
|
||||||
specials:*open-message-link-window*
|
specials:*open-message-link-window*
|
||||||
specials:*open-attach-window*
|
specials:*open-attach-window*
|
||||||
specials:*conversations-window*
|
specials:*conversations-window*
|
||||||
|
@ -393,7 +396,8 @@ Metadata includes:
|
||||||
specials:*follow-requests-window*
|
specials:*follow-requests-window*
|
||||||
:documentation "Move focus on follow requests window"
|
:documentation "Move focus on follow requests window"
|
||||||
:info-change-focus-message (_ "Focus passed on follow requests window")
|
:info-change-focus-message (_ "Focus passed on follow requests window")
|
||||||
:windows-lose-focus (specials:*gemini-streams-window*
|
:windows-lose-focus (*chats-list-window*
|
||||||
|
specials:*gemini-streams-window*
|
||||||
specials:*open-message-link-window*
|
specials:*open-message-link-window*
|
||||||
specials:*open-attach-window*
|
specials:*open-attach-window*
|
||||||
specials:*conversations-window*
|
specials:*conversations-window*
|
||||||
|
@ -406,7 +410,8 @@ Metadata includes:
|
||||||
specials:*tags-window*
|
specials:*tags-window*
|
||||||
:documentation "Move focus on tags window"
|
:documentation "Move focus on tags window"
|
||||||
:info-change-focus-message (_ "Focus passed on tags window")
|
:info-change-focus-message (_ "Focus passed on tags window")
|
||||||
:windows-lose-focus (specials:*gemini-streams-window*
|
:windows-lose-focus (*chats-list-window*
|
||||||
|
specials:*gemini-streams-window*
|
||||||
specials:*open-message-link-window*
|
specials:*open-message-link-window*
|
||||||
specials:*open-attach-window*
|
specials:*open-attach-window*
|
||||||
specials:*conversations-window*
|
specials:*conversations-window*
|
||||||
|
@ -418,7 +423,8 @@ Metadata includes:
|
||||||
specials:*conversations-window*
|
specials:*conversations-window*
|
||||||
:documentation "Move focus on conversations window"
|
:documentation "Move focus on conversations window"
|
||||||
:info-change-focus-message (_ "Focus passed on conversation window")
|
:info-change-focus-message (_ "Focus passed on conversation window")
|
||||||
:windows-lose-focus (specials:*gemini-streams-window*
|
:windows-lose-focus (*chats-list-window*
|
||||||
|
specials:*gemini-streams-window*
|
||||||
specials:*open-message-link-window*
|
specials:*open-message-link-window*
|
||||||
specials:*open-attach-window*
|
specials:*open-attach-window*
|
||||||
specials:*tags-window*
|
specials:*tags-window*
|
||||||
|
@ -431,7 +437,8 @@ Metadata includes:
|
||||||
specials:*open-attach-window*
|
specials:*open-attach-window*
|
||||||
:documentation "Move focus on open-attach window"
|
:documentation "Move focus on open-attach window"
|
||||||
:info-change-focus-message (_ "Focus passed on attach window")
|
:info-change-focus-message (_ "Focus passed on attach window")
|
||||||
:windows-lose-focus (specials:*gemini-streams-window*
|
:windows-lose-focus (*chats-list-window*
|
||||||
|
specials:*gemini-streams-window*
|
||||||
specials:*open-message-link-window*
|
specials:*open-message-link-window*
|
||||||
specials:*conversations-window*
|
specials:*conversations-window*
|
||||||
specials:*tags-window*
|
specials:*tags-window*
|
||||||
|
@ -444,7 +451,8 @@ Metadata includes:
|
||||||
specials:*open-message-link-window*
|
specials:*open-message-link-window*
|
||||||
:documentation "Move focus on open-link window"
|
:documentation "Move focus on open-link window"
|
||||||
:info-change-focus-message (_ "Focus passed on link window")
|
:info-change-focus-message (_ "Focus passed on link window")
|
||||||
:windows-lose-focus (specials:*gemini-streams-window*
|
:windows-lose-focus (*chats-list-window*
|
||||||
|
specials:*gemini-streams-window*
|
||||||
specials:*conversations-window*
|
specials:*conversations-window*
|
||||||
specials:*open-attach-window*
|
specials:*open-attach-window*
|
||||||
specials:*tags-window*
|
specials:*tags-window*
|
||||||
|
@ -457,7 +465,8 @@ Metadata includes:
|
||||||
specials:*gemini-streams-window*
|
specials:*gemini-streams-window*
|
||||||
:documentation "Move focus on open gemini streams window"
|
:documentation "Move focus on open gemini streams window"
|
||||||
:info-change-focus-message (_ "Focus passed on gemini-stream window")
|
:info-change-focus-message (_ "Focus passed on gemini-stream window")
|
||||||
:windows-lose-focus (specials:*open-message-link-window*
|
:windows-lose-focus (*chats-list-window*
|
||||||
|
specials:*open-message-link-window*
|
||||||
specials:*conversations-window*
|
specials:*conversations-window*
|
||||||
specials:*open-attach-window*
|
specials:*open-attach-window*
|
||||||
specials:*tags-window*
|
specials:*tags-window*
|
||||||
|
@ -465,6 +474,22 @@ Metadata includes:
|
||||||
specials:*thread-window*
|
specials:*thread-window*
|
||||||
specials:*message-window*
|
specials:*message-window*
|
||||||
specials:*send-message-window*))
|
specials:*send-message-window*))
|
||||||
|
|
||||||
|
(gen-focus-to-window chats-list-window
|
||||||
|
*chats-list-window*
|
||||||
|
:documentation "Move focus on chats list window"
|
||||||
|
:info-change-focus-message (_ "Focus passed on chats list window")
|
||||||
|
:windows-lose-focus (specials:*gemini-streams-window*
|
||||||
|
specials:*open-message-link-window*
|
||||||
|
specials:*conversations-window*
|
||||||
|
specials:*open-attach-window*
|
||||||
|
specials:*tags-window*
|
||||||
|
specials:*follow-requests-window*
|
||||||
|
specials:*thread-window*
|
||||||
|
specials:*message-window*
|
||||||
|
specials:*send-message-window*))
|
||||||
|
|
||||||
|
|
||||||
(defun print-quick-help ()
|
(defun print-quick-help ()
|
||||||
"Print a quick help"
|
"Print a quick help"
|
||||||
(keybindings:print-help specials:*main-window*))
|
(keybindings:print-help specials:*main-window*))
|
||||||
|
@ -1376,6 +1401,44 @@ This command will remove those limits so that we can just jump to the last messa
|
||||||
(_ "Type the index (or space separated indices) of selected choices: "))
|
(_ "Type the index (or space separated indices) of selected choices: "))
|
||||||
(error-message (_ "This in not a poll")))))))
|
(error-message (_ "This in not a poll")))))))
|
||||||
|
|
||||||
|
|
||||||
|
;;;; chats
|
||||||
|
|
||||||
|
(defun refresh-chats ()
|
||||||
|
"Refresh the chats, but not the chat's messages"
|
||||||
|
(program-events:push-event (make-instance 'program-events:get-chats-event)))
|
||||||
|
|
||||||
|
(defun refresh-chat-messages ()
|
||||||
|
"Force the refresh of the chat's messages"
|
||||||
|
(when-let* ((fields (line-oriented-window:selected-row-fields *chats-list-window*))
|
||||||
|
(chat-id (db:row-id fields)))
|
||||||
|
(let* ((min-message-id (db:last-chat-message-id chat-id))
|
||||||
|
(event (make-instance 'program-events:get-chat-messages-event
|
||||||
|
:chat-id chat-id
|
||||||
|
:min-message-id min-message-id)))
|
||||||
|
(program-events:push-event event))))
|
||||||
|
|
||||||
|
(defun open-chats-list-window ()
|
||||||
|
"open a window containing the list of active chat ordered from the
|
||||||
|
mot recent updated to least recent"
|
||||||
|
(chats-list-window:open-chats-list-window)
|
||||||
|
(focus-to-chats-list-window))
|
||||||
|
|
||||||
|
(defun close-chats-list-window ()
|
||||||
|
(close-window-and-return-to-threads specials:*chats-list-window*))
|
||||||
|
|
||||||
|
(defun update-all-chats-data ()
|
||||||
|
(refresh-chats)
|
||||||
|
(program-events:push-event (make-instance 'program-events:update-all-chat-messages-event)))
|
||||||
|
|
||||||
|
(defun show-chat-to-screen ()
|
||||||
|
(when-let* ((fields (line-oriented-window:selected-row-fields *chats-list-window*))
|
||||||
|
(chat-id (db:row-id fields))
|
||||||
|
(chat (db:find-chat chat-id))
|
||||||
|
(event (make-instance 'program-events:chat-show-event
|
||||||
|
:chat chat)))
|
||||||
|
(program-events:push-event event)))
|
||||||
|
|
||||||
;;;; gemini
|
;;;; gemini
|
||||||
|
|
||||||
(defun open-gemini-address ()
|
(defun open-gemini-address ()
|
||||||
|
|
|
@ -74,6 +74,7 @@
|
||||||
(:file "stack")
|
(:file "stack")
|
||||||
(:file "x509-ffi")
|
(:file "x509-ffi")
|
||||||
(:file "x509")
|
(:file "x509")
|
||||||
|
(:file "api-pleroma-entities")
|
||||||
(:file "db-utils")
|
(:file "db-utils")
|
||||||
(:file "db")
|
(:file "db")
|
||||||
(:file "date-formatter")
|
(:file "date-formatter")
|
||||||
|
@ -91,8 +92,8 @@
|
||||||
(:file "complete")
|
(:file "complete")
|
||||||
(:file "gemini-viewer-metadata")
|
(:file "gemini-viewer-metadata")
|
||||||
(:file "program-events")
|
(:file "program-events")
|
||||||
(:file "api-pleroma")
|
|
||||||
(:file "api-client")
|
(:file "api-client")
|
||||||
|
(:file "api-pleroma")
|
||||||
(:file "hooks")
|
(:file "hooks")
|
||||||
(:file "windows")
|
(:file "windows")
|
||||||
(:file "notify-window")
|
(:file "notify-window")
|
||||||
|
@ -112,6 +113,7 @@
|
||||||
(:file "follow-requests")
|
(:file "follow-requests")
|
||||||
(:file "tags-window")
|
(:file "tags-window")
|
||||||
(:file "conversations-window")
|
(:file "conversations-window")
|
||||||
|
(:file "chats-list-window")
|
||||||
(:file "gemini-viewer")
|
(:file "gemini-viewer")
|
||||||
(:file "main-window")
|
(:file "main-window")
|
||||||
(:file "ui-goodies")
|
(:file "ui-goodies")
|
||||||
|
|
Loading…
Reference in New Issue