1
0
Fork 0
tinmop/src/follow-requests.lisp

149 lines
7.0 KiB
Common Lisp
Raw Normal View History

;; tinmop: a multiprotocol client
2023-10-19 17:46:22 +02:00
;; Copyright © cage
2020-05-08 15:45:43 +02:00
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(in-package :follow-requests)
(defclass follow-requests-window (focus-marked-window simple-line-navigation-window)
((requests
:initarg :requests
:initform ()
2020-05-08 15:45:43 +02:00
:accessor requests
:documentation "All the accounts that request to follow you")
(header-message-lines
:initarg :header-message-lines
:initform ()
:accessor header-message-lines
:documentation "lines of text printed on top of the window")
(screen
:initarg :screen
:initform nil
:accessor screen
:documentation "A reference to the main window (the screen)")
(style
:initarg :style
:initform nil
:accessor style
:documentation "The visual style of the window")))
(defmethod refresh-config :after ((object follow-requests-window))
(with-accessors ((screen screen)
(croatoan-window croatoan-window)
(bgcolor bgcolor)
(fgcolor fgcolor)
(top-row-padding top-row-padding)
(header-message-lines header-message-lines)
(style style)) object
(let* ((theme-style (swconf:form-style swconf:+key-input-dialog+))
(fg (swconf:foreground theme-style))
(bg (swconf:background theme-style))
(width (truncate (/ (win-width screen)
3)))
(height (truncate (/ (win-height screen)
3)))
(y (truncate (- (/ (win-height screen) 2)
(/ height 2))))
(x (truncate (- (/ (win-width screen) 2)
(/ width 2)))))
(setf (c:background croatoan-window)
(tui:make-win-background bg))
(setf (c:bgcolor croatoan-window) bg)
(setf (c:fgcolor croatoan-window) fg)
2020-05-08 15:45:43 +02:00
(setf style theme-style)
(win-resize object width height)
(win-move object x y)
(let* ((header (_ "Please evaluate the following requests, only items shown below will be accepted, deleted ones will be rejected"))
2020-05-08 15:45:43 +02:00
(header-words (text-utils:split-words header))
(header-lines (text-utils:flush-left-mono-text header-words
(win-width-no-border object)))
(attach-y-start (1+ (length header-lines))))
(setf top-row-padding attach-y-start)
(setf header-message-lines header-lines))
object)))
(defmethod draw :after ((object follow-requests-window))
(with-accessors ((style style)
(header-message-lines header-message-lines)) object
(with-croatoan-window (croatoan-window object)
(let* ((bgcolor (c:bgcolor croatoan-window))
(fgcolor (c:fgcolor croatoan-window))
2020-05-08 15:45:43 +02:00
(win-width (win-width-no-border object)))
(loop
for y from 1
for line in header-message-lines do
(print-text object
(text-utils:right-padding line win-width)
1 y
:fgcolor fgcolor
:bgcolor bgcolor
:attributes (attribute-bold)))))))
(defun init (follow-requests usernames-follow-requests screen)
"Initialize the window
- follows-requests the account entity (from tooter library) that requestes to follow you
- username-follow-requests the username of the accounts that requestes to follow you
- screen the main window
"
(flet ((make-rows (usernames bg fg)
(mapcar (lambda (username)
(make-instance 'line
:normal-text username
:selected-text username
:normal-bg bg
:normal-fg fg
:selected-bg fg
:selected-fg bg))
usernames)))
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
(setf *follow-requests-window*
(make-instance 'follow-requests-window
:requests follow-requests
:uses-border-p t
:screen screen
:keybindings keybindings:*follow-requests-keymap*
:croatoan-window low-level-window))
(refresh-config *follow-requests-window*)
(line-oriented-window:update-all-rows *follow-requests-window*
(make-rows usernames-follow-requests
(c:bgcolor low-level-window)
(c:fgcolor low-level-window)))
2020-05-08 15:45:43 +02:00
(setf (row-selected-index *follow-requests-window*) 0)
*follow-requests-window*)))
(defun process-requests ()
"Process the accepted or follow' requests, the accepted are the
requeste that are not be erased from the window (see the class
row-oriented-widget)"
(with-accessors ((all-accounts requests)) specials:*follow-requests-window*
(let* ((accepted-usernames (line-oriented-window:map-rows specials:*follow-requests-window*
#'normal-text))
2020-05-08 15:45:43 +02:00
(accepted-accounts (remove-if-not (lambda (acc)
(find-if (lambda (a)
(string= a
(tooter:account-name acc)))
accepted-usernames))
all-accounts))
(rejected-accounts (set-difference all-accounts
accepted-accounts
:key #'tooter:id
:test #'string=)))
(loop for accepted-account in accepted-accounts do
(let ((id (tooter:id accepted-account)))
(api-client:accept-follow-request id)))
(loop for rejected-account in rejected-accounts do
(let ((id (tooter:id rejected-account)))
(api-client:reject-follow-request id))))))