tinmop/src/sending-message.lisp

;; tinmop: a multiprotocol client
;; Copyright © 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 :sending-message)

(define-constant +header-send-window-height+ 6 :test #'=)

(defclass message-ready-to-send ()
  ((language
    :initform nil
    :initarg  :language
    :accessor language)
   (subject
    :initform nil
    :initarg  :subject
    :accessor subject)
   (attachments
    :initform ()
    :initarg  :attachments
    :accessor attachments)
   (reply-to
    :initform ()
    :initarg  :reply-to
    :accessor reply-to
    :documentation "The id  of table 'status' you are replying to.")
   (mentions
    :initform ""
    :initarg  :mentions
    :accessor mentions)
   (visibility
    :initform +status-public-visibility+
    :initarg  :visibility
    :accessor visibility
    :documentation "One of swconf:*allowed-status-visibility*.")
   (body
    :initform nil
    :initarg  :body
    :accessor body)))

(defmethod print-object ((object message-ready-to-send) stream)
  (print-unreadable-object (object stream :type t)
    (with-accessors ((subject     subject)
                     (attachments attachments)
                     (reply-to    reply-to)
                     (body        body)) object
      (format stream
              "~@[subj: ~a ~] ~@[reply-to: ~a ~] ~@[attach: ~a ~] ~a"
              subject reply-to attachments body))))

(defclass confirm-sending-window (focus-marked-window simple-line-navigation-window)
  ((screen
    :initarg  :screen
    :initform nil
    :accessor screen)
   (message-data
    :initarg  :message-data
    :initform (make-instance 'message-ready-to-send)
    :accessor message-data
    :type     message-ready-to-send)
   (style
    :initarg  :style
    :initform nil
    :accessor style)))

(defmethod refresh-config :after ((object confirm-sending-window))
  (with-accessors ((screen          screen)
                   (croatoan-window croatoan-window)
                   (bgcolor         bgcolor)
                   (fgcolor         fgcolor)
                   (top-row-padding top-row-padding)
                   (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)
                                        2)))
           (height         (truncate (/ (win-height screen)
                                        2)))
           (y              (truncate (- (/ (win-height screen) 2)
                                        (/ height 2))))
           (x              (truncate (- (/ (win-width  screen) 2)
                                        (/ width 2))))
           (attach-y-start +header-send-window-height+))
      (setf (c:background croatoan-window) (tui:make-win-background bg))
      (setf (c:bgcolor croatoan-window) bg)
      (setf (c:fgcolor croatoan-window) fg)
      (setf style theme-style)
      (win-resize object width height)
      (win-move object x y)
      (setf (top-row-padding object) attach-y-start)
      object)))

(defmethod draw :after ((object confirm-sending-window))
  (with-accessors ((message-data  message-data)
                   (style         style)) object
    (with-accessors ((reply-to    reply-to)
                     (attachments attachments)
                     (body        body)
                     (subject     subject)
                     (mentions    mentions)
                     (visibility  visibility)
                     (language    language)) message-data
      (with-croatoan-window (croatoan-window object)
        (let* ((bgcolor                     (c:bgcolor croatoan-window))
               (fgcolor                     (c:fgcolor croatoan-window))
               (input-bg                    (swconf:input-background style))
               (input-fg                    (swconf:input-foreground style))
               (user                        (if reply-to
                                                (db:status-id->username reply-to)
                                                (_ "none")))
               (label-reply-raw             (_ "Reply to: "))
               (label-mentions-raw          (_ "Mentions: "))
               (label-subject-raw           (_ "Subject: "))
               (label-visibility-raw        (_ "Visibility: "))
               (label-language-raw          (_ "Language: "))
               (label-reply-length-raw      (length label-reply-raw))
               (label-mentions-length-raw   (length label-mentions-raw))
               (label-subject-raw-length    (length label-subject-raw))
               (label-visibility-raw-length (length label-visibility-raw))
               (label-language-raw-length   (length label-language-raw))
               (max-field-length            (max label-reply-length-raw
                                                 label-mentions-length-raw
                                                 label-subject-raw-length
                                                 label-visibility-raw-length
                                                 label-language-raw-length))
               (label-subject               (text-utils:right-padding label-subject-raw
                                                                      max-field-length))
               (label-reply                 (text-utils:right-padding label-reply-raw
                                                                      max-field-length))
               (label-mentions              (text-utils:right-padding label-mentions-raw
                                                                      max-field-length))
               (label-visibility            (text-utils:right-padding label-visibility-raw
                                                                      max-field-length))
               (label-language              (text-utils:right-padding label-language-raw
                                                                      max-field-length))
               (value-max-length            (- (win-width-no-border object)
                                               max-field-length))
               (label-attachments           (_ "Attachments")))
          (flet ((print-field (text x y bg fg &key (inverse nil))
                   (print-text object text x y
                               :bgcolor (if inverse
                                            fg
                                            bg)
                               :fgcolor (if inverse
                                            bg
                                            fg))))
            (print-field label-reply 1 1 bgcolor fgcolor)
            (print-field (right-padding user
                                        value-max-length)
                         max-field-length
                         1
                         input-bg input-fg)
            (print-field label-mentions 1 2 bgcolor fgcolor)
            (print-field (right-padding mentions
                                        value-max-length)
                         max-field-length
                         2
                         input-bg input-fg)
            (print-field label-subject 1 3 bgcolor fgcolor)
            (print-field (right-padding subject
                                        value-max-length)
                         max-field-length
                         3
                         input-bg input-fg)
            (print-field label-visibility 1 4 bgcolor fgcolor)
            (print-field (right-padding visibility
                                        value-max-length)
                         max-field-length
                         4
                         input-bg input-fg)
            (print-field label-language 1 5 bgcolor fgcolor)
            (print-field (right-padding language
                                        value-max-length)
                         max-field-length
                         5
                         input-bg input-fg)
            (print-field (right-padding (text-ellipsis label-attachments
                                                       (win-width-no-border object))
                                        (win-width-no-border object))
                         1
                         6
                         bgcolor fgcolor
                         :inverse t)))))))

(defun init (message-data screen)
  (flet ((make-rows (data bg fg)
           (mapcar #'(lambda (a)
                       (make-instance 'line
                                      :normal-text   a
                                      :selected-text a
                                      :normal-bg     bg
                                      :normal-fg     fg
                                      :selected-bg   fg
                                      :selected-fg   bg))
                   data)))
  (let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
    (setf *send-message-window*
          (make-instance 'confirm-sending-window
                         :uses-border-p   t
                         :screen          screen
                         :keybindings     keybindings:*send-message-keymap*
                         :croatoan-window low-level-window
                         :message-data    message-data))
    (refresh-config *send-message-window*)
    (line-oriented-window:update-all-rows *send-message-window*
                                          (make-rows (attachments message-data)
                                                     (c:bgcolor low-level-window)
                                                     (c:fgcolor low-level-window)))
    (setf (row-selected-index *send-message-window*) 0)
    *send-message-window*)))