From 75d81ec70852df1a8ec6844a0a269f779ab12fa4 Mon Sep 17 00:00:00 2001 From: cage Date: Sat, 5 Sep 2020 17:02:00 +0200 Subject: [PATCH] - chats can be fetched, via UI, and printed on window. --- etc/default-theme.conf | 4 + etc/init.lisp | 22 +++-- etc/shared.conf | 44 ++++++++- src/api-pleroma-entities.lisp | 81 ++++++++++++++++ src/api-pleroma.lisp | 74 +++----------- src/chats-list-window.lisp | 112 ++++++++++++++++++++++ src/db.lisp | 165 ++++++++++++++++++++++++++++---- src/gemini-viewer.lisp | 44 ++++----- src/keybindings.lisp | 3 + src/main.lisp | 3 +- src/package.lisp | 75 +++++++++++++-- src/program-events.lisp | 57 +++++++++++ src/software-configuration.lisp | 1 + src/specials.lisp | 3 + src/ui-goodies.lisp | 79 +++++++++++++-- tinmop.asd | 4 +- 16 files changed, 645 insertions(+), 126 deletions(-) create mode 100644 src/api-pleroma-entities.lisp create mode 100644 src/chats-list-window.lisp diff --git a/etc/default-theme.conf b/etc/default-theme.conf index 6c7675b..5623731 100644 --- a/etc/default-theme.conf +++ b/etc/default-theme.conf @@ -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]" \ No newline at end of file diff --git a/etc/init.lisp b/etc/init.lisp index 290a058..433069e 100644 --- a/etc/init.lisp +++ b/etc/init.lisp @@ -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 diff --git a/etc/shared.conf b/etc/shared.conf index e8bbb0d..7274016 100644 --- a/etc/shared.conf +++ b/etc/shared.conf @@ -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 diff --git a/src/api-pleroma-entities.lisp b/src/api-pleroma-entities.lisp new file mode 100644 index 0000000..d691847 --- /dev/null +++ b/src/api-pleroma-entities.lisp @@ -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 . + +(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)))) diff --git a/src/api-pleroma.lisp b/src/api-pleroma.lisp index f510db7..120a365 100644 --- a/src/api-pleroma.lisp +++ b/src/api-pleroma.lisp @@ -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*)) diff --git a/src/chats-list-window.lisp b/src/chats-list-window.lisp new file mode 100644 index 0000000..48039cb --- /dev/null +++ b/src/chats-list-window.lisp @@ -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*)) diff --git a/src/db.lisp b/src/db.lisp index 7e0129d..3794649 100644 --- a/src/db.lisp +++ b/src/db.lisp @@ -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' diff --git a/src/gemini-viewer.lisp b/src/gemini-viewer.lisp index 3cb2e40..ed88651 100644 --- a/src/gemini-viewer.lisp +++ b/src/gemini-viewer.lisp @@ -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))) diff --git a/src/keybindings.lisp b/src/keybindings.lisp index 71e845c..6df905b 100644 --- a/src/keybindings.lisp +++ b/src/keybindings.lisp @@ -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: diff --git a/src/main.lisp b/src/main.lisp index 0ea008d..d266bb0 100644 --- a/src/main.lisp +++ b/src/main.lisp @@ -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) diff --git a/src/package.lisp b/src/package.lisp index 0713570..f3adb8d 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -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 diff --git a/src/program-events.lisp b/src/program-events.lisp index 67cc494..d3f8104 100644 --- a/src/program-events.lisp +++ b/src/program-events.lisp @@ -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 () diff --git a/src/software-configuration.lisp b/src/software-configuration.lisp index d6ad893..ad37b42 100644 --- a/src/software-configuration.lisp +++ b/src/software-configuration.lisp @@ -363,6 +363,7 @@ main-window thread-window message-window + chat-window attachment-header max-numbers-allowed-attachments max-message-length diff --git a/src/specials.lisp b/src/specials.lisp index c2c2016..bd45f34 100644 --- a/src/specials.lisp +++ b/src/specials.lisp @@ -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.") diff --git a/src/ui-goodies.lisp b/src/ui-goodies.lisp index 31f8069..24679cb 100644 --- a/src/ui-goodies.lisp +++ b/src/ui-goodies.lisp @@ -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 () diff --git a/tinmop.asd b/tinmop.asd index 750aeee..257d044 100644 --- a/tinmop.asd +++ b/tinmop.asd @@ -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")