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

- chats can be fetched, via UI, and printed on window.

This commit is contained in:
cage 2020-09-05 17:02:00 +02:00
parent 4046f516f8
commit 75d81ec708
16 changed files with 645 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
etc/default-theme.conf
View File

@ -485,3 +485,7 @@ open-gemini-stream-window.foreground = #FEB200
open-gemini-stream-window.input.selected.background = black
open-gemini-stream-window.input.selected.foreground = #FFB200
# chats
chat-window.date-format.value = "[%hour:%min]"

22
etc/init.lisp
View File

@ -135,6 +135,8 @@
(define-key ">" #'open-gemini-address)
(define-key "M-c" #'open-chats-list-window)
;; focus
(define-key "f1" #'focus-to-tags-window)
@ -355,17 +357,21 @@
;; message links keymap
(define-key "C-J" #'open-message-link-perform-opening
*open-message-link-keymap*)
(define-key "C-J" #'open-message-link-perform-opening *open-message-link-keymap*)
(define-key "up" #'open-message-link-go-up
*open-message-link-keymap*)
(define-key "up" #'open-message-link-go-up *open-message-link-keymap*)
(define-key "down" #'open-message-link-go-down
*open-message-link-keymap*)
(define-key "down" #'open-message-link-go-down *open-message-link-keymap*)
(define-key "q" #'close-open-message-link-window
*open-message-link-keymap*)
(define-key "q" #'close-open-message-link-window *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

44
etc/shared.conf
View File

@ -59,44 +59,86 @@ editor = "nano --locking"
# Some examples follows, order matters!
# http links
color-regexp = "http(s)?://[^ ]+" #ff0000
# gemini address header
color-regexp = "-> gemini://[^ ]+" yellow underline
#gemini links
color-regexp = "gemini://[^ ]+" #ff0000
# (c) and (r)
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
# numbers
color-regexp = "-?[0-9]+(.[0-9]+)?%" #ff00ff bold
# *bold*
color-regexp = "\*[^*]+\*" #ffff00 bold
# _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 = "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 links
color-regexp = "→ .+" blue bold
# non gemini links
color-regexp = "➶ .+" magenta bold
# header level 1
color-regexp = "🞂 .+" white bold
# header level 2
color-regexp = "🞓 .+" blue bold
# header level 3
color-regexp = "🞐 .+" yellow bold
# header level 4
color-regexp = "🞎 " yellow
# list bullet
color-regexp = "• " blue bold
# stream statuses
color-regexp = ":completed" green bold
color-regexp = ":aborted" red

81
src/api-pleroma-entities.lisp Normal file
View File

@ -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))))

74
src/api-pleroma.lisp
View File

@ -26,68 +26,6 @@
(defmethod delete-notification ((object tooter:client) (notification tooter: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))
(defmethod create-chat ((object tooter:client) (account-id string))
@ -100,7 +38,7 @@
(defgeneric get-all-chats (object))
(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")))
(defgeneric post-chat-message (object chat-id content media))
@ -144,3 +82,13 @@ media `media'. Returns a `chat-message' instance"
chat-id
message-id)
: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*))

112
src/chats-list-window.lisp Normal file
View File

@ -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
View File

@ -272,25 +272,39 @@
" bitrate TEXT,"
" description TEXT,"
" blurhash TEXT,"
" \"status-id\" TEXT"
" \"attached-to-id\" TEXT"
+make-close+)))
(defun make-chat ()
(query-low-level (strcat (prepare-table +table-chat+ :autogenerated-id-p nil)
"id TEXT NOT NULL,"
;; timestamp
" \"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+)))
(defun make-chat-message ()
(query-low-level (strcat (prepare-table +table-chat-message+ :autogenerated-id-p nil)
"id TEXT NOT NULL,"
;; boolean
" unreadp INTEGER DEFAULT 0,"
" unreadp INTEGER DEFAULT 1,"
" content TEXT,"
" \"chat-id\" TEXT "
(make-foreign +table-chat+ "id" +cascade+ +cascade+) +col-sep+
" \"attachment-id\" TEXT NOT NULL"
" \"chat-id\" TEXT, "
;; timestamp
" \"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+)))
(defun make-conversation ()
@ -889,7 +903,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
(voted tooter:voted)
(own-votes tooter:own-votes)
(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-multiple (prepare-for-db multiple :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
(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)
(kind tooter:kind)
(url tooter:url)
@ -931,7 +945,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
(metadata tooter:metadata)
(description tooter:description)
(blurhash tooter:blurhash)) object
(assert status-id)
(assert attached-to-id)
(let* ((actual-attachment-type (prepare-for-db kind))
(original-file-metadata (metadata-original 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
:description
:blurhash
:status-id)
:attached-to-id)
(id
actual-attachment-type
url
@ -967,11 +981,13 @@ than (swconf:config-purge-history-days-offset) days in the past"
bitrate
description
blurhash
status-id)))
attached-to-id)))
(attachment-exists-p (fetch-single (select :*
(from +table-attachment+)
(where (:and (:= :status-id status-id)
(:= :id id)))))))
(where (:and (:= :attached-to-id
attached-to-id)
(:= :id
id)))))))
(when (not attachment-exists-p)
(query insert-query)))))
@ -1007,7 +1023,7 @@ than (swconf:config-purge-history-days-offset) days in the past"
(statuses-count tooter:statuses-count)
(moved tooter:moved)
(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-discoverable (prepare-for-db discoverable :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
(map nil
(lambda (media-attachment)
(update-db media-attachment :status-id id))
(update-db media-attachment :attached-to-id id))
media-attachments)
(loop
for tag in tags
@ -1206,6 +1222,104 @@ than (swconf:config-purge-history-days-offset) days in the past"
(when poll
(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)
"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 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)
(and row (db-getf row :votes-count 0)))
@ -1749,7 +1877,12 @@ messages are sorted as below:
(defun all-attachments-to-status (status-id)
(fetch-all-rows (select :*
(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)
"Return the status that identified by `wrapper-status-id'

44
src/gemini-viewer.lisp
View File

@ -544,28 +544,28 @@
(when redraw
(draw object))))))
(defmethod draw :before ((object gemini-streams-window))
(with-accessors ((rows rows)
(uses-border-p uses-border-p)
(single-row-height single-row-height)
(top-row-padding top-row-padding)
(new-messages-mark new-messages-mark)
(top-rows-slice top-rows-slice)
(bottom-rows-slice bottom-rows-slice)) object
(let ((y-start (if uses-border-p
1
0)))
(renderizable-rows-data object) ; set top and bottom slice
(win-clear object)
(with-croatoan-window (croatoan-window object)
(loop
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
(print-text object
gemini-stream
1 y
:bgcolor (bgcolor croatoan-window)
:fgcolor (fgcolor croatoan-window)))))))
;; (defmethod draw :before ((object gemini-streams-window))
;; (with-accessors ((rows rows)
;; (uses-border-p uses-border-p)
;; (single-row-height single-row-height)
;; (top-row-padding top-row-padding)
;; (new-messages-mark new-messages-mark)
;; (top-rows-slice top-rows-slice)
;; (bottom-rows-slice bottom-rows-slice)) object
;; (let ((y-start (if uses-border-p
;; 1
;; 0)))
;; (renderizable-rows-data object) ; set top and bottom slice
;; (win-clear object)
;; (with-croatoan-window (croatoan-window object)
;; (loop
;; 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
;; (print-text object
;; gemini-stream
;; 1 y
;; :bgcolor (bgcolor croatoan-window)
;; :fgcolor (fgcolor croatoan-window)))))))
(defun open-gemini-stream-window ()
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))

3
src/keybindings.lisp
View File

@ -255,6 +255,9 @@ produces a tree and graft the latter on `existing-tree'"
(defparameter *gemini-downloads-keymap* (make-starting-comand-tree)
"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*))
"Define a key sequence that trigger a function:

3
src/main.lisp
View File

@ -144,11 +144,12 @@ etc.) happened"
(unwind-protect
(progn
(hooks:run-hooks 'hooks:*before-main-loop*)
(ui:update-all-chats-data)
(run-event-loop croatoan-window))
(end-screen)))))
(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)
(load-configuration-files)
(init-db)

75
src/package.lisp
View File

@ -721,6 +721,14 @@
:find-poll
:find-poll-option
: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
:message-root
:message-children
@ -733,6 +741,8 @@
:find-message-id
:data-id
:row-id
:row-type
:row-label
:row-message-visibility
:row-message-status-id
:row-message-index
@ -756,8 +766,13 @@
:row-poll-multiple-vote-p
:row-title
:row-expire-date
:row-account-id
:row-updated-at
:row-created-at
:row-chat-id
:row-votes-count
:row-message-reply-to-id
:row-text-url
:next-status-tree
:previous-status-tree
:message-tree-root-equal
@ -765,6 +780,7 @@
:renumber-timeline-message-index
:renumber-all-timelines
:all-attachments-to-status
:attachment-to-chat-message
:all-attachments-urls-to-status
:mark-status-red-p
:mark-status-unread
@ -919,6 +935,7 @@
:+key-main-window+
:+key-thread-window+
:+key-message-window+
:+key-chat-window+
:+key-favourite+
:+key-sensitive+
:+key-boosted+
@ -1108,7 +1125,8 @@
:*conversations-window*
:*open-attach-window*
:*open-message-link-window*
:*gemini-streams-window*))
:*gemini-streams-window*
:*chats-list-window*))
(defpackage :complete
(:use
@ -1217,10 +1235,14 @@
:poll-vote-event
:gemini-request-event
:gemini-back-event
:function-event
:gemini-got-line-event
:gemini-abort-downloading-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
:add-pagination-status-event
:status-id
@ -1231,21 +1253,32 @@
:cl
:alexandria
:config
:constants)
:constants
:misc)
(:shadowing-import-from :misc :random-elt :shuffle)
(:export
:delete-notification
:chat-message
:message-id
:nreadp
:emojis
:updated-at
:created-at
:content
:chat-id
:unreadp
:emojis
:attachment
:account-id
:chat
:unread-count
:last-message
:account
:create-chat
:get-all-chats
:post-chat-message
:fetch-chat-messages
:delete-chat-message))
:delete-chat-message
:get-chat-messages
:get-chats))
(defpackage :api-client
(:use
@ -1261,6 +1294,7 @@
(:nicknames :client)
(:export
:*client*
:*client-lock*
:forget-credentials
:authorize
:favourite-status
@ -1350,6 +1384,7 @@
:*open-message-link-keymap*
:*open-gemini-link-keymap*
:*gemini-downloads-keymap*
:*chats-list-keymap*
:define-key
:init-keyboard-mapping
:find-keymap-node
@ -1911,6 +1946,28 @@
:resync-rows-db
: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
(:use
:cl
@ -2115,6 +2172,12 @@
:show-about-window
:reset-timeline-pagination
: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
:gemini-history-back
:gemini-view-source

57
src/program-events.lisp
View File

@ -981,6 +981,62 @@
(with-accessors ((stream-object payload)) 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) ())
(defmethod process-event ((object function-event))
@ -988,6 +1044,7 @@
(assert (functionp payload))
(funcall payload)))
;;;; end events
(defun dispatch-program-events ()

1
src/software-configuration.lisp
View File

@ -363,6 +363,7 @@
main-window
thread-window
message-window
chat-window
attachment-header
max-numbers-allowed-attachments
max-message-length

3
src/specials.lisp
View File

@ -54,3 +54,6 @@
(defparameter *gemini-streams-window* nil
"The window that shows all gemini-streams.")
(defparameter *chats-list-window* nil
"The window that shows all the chats.")

79
src/ui-goodies.lisp
View File

@ -354,6 +354,7 @@ Metadata includes:
(if print-message
(_ "focus passed on threads window")
nil)
*chats-list-window*
*gemini-streams-window*
*open-message-link-window*
*open-attach-window*
@ -367,7 +368,8 @@ Metadata includes:
specials:*message-window*
:documentation "Move focus 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-attach-window*
specials:*conversations-window*
@ -380,7 +382,8 @@ Metadata includes:
specials:*send-message-window*
:documentation "Move focus 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-attach-window*
specials:*conversations-window*
@ -393,7 +396,8 @@ Metadata includes:
specials:*follow-requests-window*
:documentation "Move focus 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-attach-window*
specials:*conversations-window*
@ -406,7 +410,8 @@ Metadata includes:
specials:*tags-window*
:documentation "Move focus 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-attach-window*
specials:*conversations-window*
@ -418,7 +423,8 @@ Metadata includes:
specials:*conversations-window*
:documentation "Move focus on conversations 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-attach-window*
specials:*tags-window*
@ -431,7 +437,8 @@ Metadata includes:
specials:*open-attach-window*
:documentation "Move focus on open-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:*conversations-window*
specials:*tags-window*
@ -444,7 +451,8 @@ Metadata includes:
specials:*open-message-link-window*
:documentation "Move focus on open-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:*open-attach-window*
specials:*tags-window*
@ -457,7 +465,8 @@ Metadata includes:
specials:*gemini-streams-window*
:documentation "Move focus on open gemini streams 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:*open-attach-window*
specials:*tags-window*
@ -465,6 +474,22 @@ Metadata includes:
specials:*thread-window*
specials:*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 ()
"Print a quick help"
(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: "))
(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
(defun open-gemini-address ()

4
tinmop.asd
View File

@ -74,6 +74,7 @@
(:file "stack")
(:file "x509-ffi")
(:file "x509")
(:file "api-pleroma-entities")
(:file "db-utils")
(:file "db")
(:file "date-formatter")
@ -91,8 +92,8 @@
(:file "complete")
(:file "gemini-viewer-metadata")
(:file "program-events")
(:file "api-pleroma")
(:file "api-client")
(:file "api-pleroma")
(:file "hooks")
(:file "windows")
(:file "notify-window")
@ -112,6 +113,7 @@
(:file "follow-requests")
(:file "tags-window")
(:file "conversations-window")
(:file "chats-list-window")
(:file "gemini-viewer")
(:file "main-window")
(:file "ui-goodies")