- added rendering of polls.

etc/default-theme.conf

@@ -37,7 +37,13 @@ main-window.foreground                             = white
 
 crypted.mark.value                                 = " 🔏👌"
 
+# the character used to draw the vote's horizontal histogram
+# note: keeps it one character wide
+
+vote-vertical-bar                                  = "⯀"
+
 # quick help window style
+
 quick-help.header.foreground                       = white
 
 quick-help.header.background                       = red

etc/shared.conf

@@ -72,3 +72,7 @@ color-regexp                    = "\*[^*]+\*" #ffff00 bold
 color-regexp                    = "_[^_]+_" #ffff00 underline
 
 color-regexp                    = "/[^/]+/" #ffff00 italic
+
+color-regexp                    = "⯀"      green bold
+
+color-regexp                    = "The poll has expired" #ff00ff bold

po/it.po

@@ -8,8 +8,8 @@ msgid ""
 msgstr ""
 "Project-Id-Version: tinmop 0.0.1\n"
 "Report-Msgid-Bugs-To: https://notabug.org/cage/tinmop/\n"
-"POT-Creation-Date: 2020-05-30 12:00+0200\n"
+"POT-Creation-Date: 2020-05-31 12:44+0200\n"
-"PO-Revision-Date: 2020-05-30 12:03+0200\n"
+"PO-Revision-Date: 2020-05-31 12:46+0200\n"
 "Last-Translator: cage <cage@invalid.org>\n"
 "Language-Team: Italian\n"
 "Language: it\n"
@@ -131,7 +131,7 @@ msgstr "Notifica i messaggi che menzionano l'utente."
 msgid "Error: command ~a not found"
 msgstr "Errore: comando ~a non trovato"
 
-#: src/conditions.lisp:67 src/conditions.lisp:71 src/db.lisp:2217
+#: src/conditions.lisp:67 src/conditions.lisp:71 src/db.lisp:2354
 #: src/message-rendering-utils.lisp:132 src/message-rendering-utils.lisp:166
 #: src/message-rendering-utils.lisp:171
 msgid "unknown"
@@ -141,19 +141,19 @@ msgstr "sconosciuto"
 msgid "Conversations"
 msgstr "Conversazioni"
 
-#: src/db.lisp:164
+#: src/db.lisp:170
 msgid "federated"
 msgstr "federata"
 
-#: src/db.lisp:166
+#: src/db.lisp:172
 msgid "local"
 msgstr "locale"
 
-#: src/db.lisp:168
+#: src/db.lisp:174
 msgid "direct"
 msgstr "diretta"
 
-#: src/db.lisp:170
+#: src/db.lisp:176
 msgid "home"
 msgstr "home"
 
@@ -283,6 +283,10 @@ msgstr "Rilanciato per: "
 msgid "Date: "
 msgstr "Scritto il: "
 
+#: src/message-rendering-utils.lisp:259
+msgid "The poll has expired"
+msgstr "Il sondaggio è scaduto"
+
 #: src/message-window.lisp:218
 msgid "Messages"
 msgstr "Messaggi"
@@ -364,7 +368,7 @@ msgstr "Oggetto del messaggio: "
 msgid "Visibility:"
 msgstr "Visibilità:"
 
-#: src/software-configuration.lisp:423
+#: src/software-configuration.lisp:429
 msgid "This message was crypted."
 msgstr "Questo messaggion era cifrato."
 
@@ -406,21 +410,21 @@ msgstr "Oggetto mancante"
 msgid "No message with index ~a exists."
 msgstr "Nessun messaggio esiste alla posizione ~a."
 
-#: src/thread-window.lisp:854 src/thread-window.lisp:888
+#: src/thread-window.lisp:859 src/thread-window.lisp:893
 #, lisp-format
 msgid "No next message that contains ~s exists."
 msgstr "Nessun messaggio successivo che contenga ~s esiste."
 
-#: src/thread-window.lisp:860 src/thread-window.lisp:894
+#: src/thread-window.lisp:865 src/thread-window.lisp:899
 #, lisp-format
 msgid "No previous message that contains ~s exists."
 msgstr "Nessun messaggio precedente che contenga ~s esiste."
 
-#: src/thread-window.lisp:910
+#: src/thread-window.lisp:915
 msgid "No others unread messages exist."
 msgstr "Non ci sono altri messaggi non letti."
 
-#: src/thread-window.lisp:921
+#: src/thread-window.lisp:926
 msgid "Threads"
 msgstr "Discussioni"
 

po/tinmop.pot

@@ -8,7 +8,7 @@ msgid ""
 msgstr ""
 "Project-Id-Version: tinmop 0.0.3\n"
 "Report-Msgid-Bugs-To: https://notabug.org/cage/tinmop/\n"
-"POT-Creation-Date: 2020-05-30 12:00+0200\n"
+"POT-Creation-Date: 2020-05-31 12:44+0200\n"
 "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
 "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
 "Language-Team: LANGUAGE <LL@li.org>\n"
@@ -127,7 +127,7 @@ msgstr ""
 msgid "Error: command ~a not found"
 msgstr ""
 
-#: src/conditions.lisp:67 src/conditions.lisp:71 src/db.lisp:2217
+#: src/conditions.lisp:67 src/conditions.lisp:71 src/db.lisp:2354
 #: src/message-rendering-utils.lisp:132 src/message-rendering-utils.lisp:166
 #: src/message-rendering-utils.lisp:171
 msgid "unknown"
@@ -137,19 +137,19 @@ msgstr ""
 msgid "Conversations"
 msgstr ""
 
-#: src/db.lisp:164
+#: src/db.lisp:170
 msgid "federated"
 msgstr ""
 
-#: src/db.lisp:166
+#: src/db.lisp:172
 msgid "local"
 msgstr ""
 
-#: src/db.lisp:168
+#: src/db.lisp:174
 msgid "direct"
 msgstr ""
 
-#: src/db.lisp:170
+#: src/db.lisp:176
 msgid "home"
 msgstr ""
 
@@ -276,6 +276,10 @@ msgstr ""
 msgid "Date: "
 msgstr ""
 
+#: src/message-rendering-utils.lisp:259
+msgid "The poll has expired"
+msgstr ""
+
 #: src/message-window.lisp:218
 msgid "Messages"
 msgstr ""
@@ -353,7 +357,7 @@ msgstr ""
 msgid "Visibility:"
 msgstr ""
 
-#: src/software-configuration.lisp:423
+#: src/software-configuration.lisp:429
 msgid "This message was crypted."
 msgstr ""
 
@@ -393,21 +397,21 @@ msgstr ""
 msgid "No message with index ~a exists."
 msgstr ""
 
-#: src/thread-window.lisp:854 src/thread-window.lisp:888
+#: src/thread-window.lisp:859 src/thread-window.lisp:893
 #, lisp-format
 msgid "No next message that contains ~s exists."
 msgstr ""
 
-#: src/thread-window.lisp:860 src/thread-window.lisp:894
+#: src/thread-window.lisp:865 src/thread-window.lisp:899
 #, lisp-format
 msgid "No previous message that contains ~s exists."
 msgstr ""
 
-#: src/thread-window.lisp:910
+#: src/thread-window.lisp:915
 msgid "No others unread messages exist."
 msgstr ""
 
-#: src/thread-window.lisp:921
+#: src/thread-window.lisp:926
 msgid "Threads"
 msgstr ""
 

src/db.lisp

@@ -80,6 +80,12 @@
 (define-constant +table-account+                :account
   :test #'eq)
 
+(define-constant +table-poll-option+            :poll-option
+  :test #'eq)
+
+(define-constant +table-poll+                   :poll
+  :test #'eq)
+
 (define-constant +table-attachment+             :attachment
   :test #'eq)
 
@@ -328,6 +334,35 @@
                            " \"created-at\"       TEXT    NOT NULL"
                            +make-close+)))
 
+(defun make-poll-option ()
+  (query-low-level (strcat (prepare-table +table-poll-option+
+                                          :autogenerated-id-p t
+                                          :autoincrementp     t)
+                           " \"poll-id\" TEXT NOT NULL "
+                           (make-foreign +table-poll+ "id" +cascade+ +cascade+) +col-sep+
+                           " title TEXT, "
+                           " \"votes-count\" INTEGER DEFAULT 0"
+                           +make-close+)))
+
+(defun make-poll ()
+  (query-low-level (strcat (prepare-table +table-poll+ :autogenerated-id-p t)
+                           " \"status-id\" TEXT NOT NULL "
+                           ;(make-foreign +table-status+ "status-id" +cascade+ +cascade+)
+                           +col-sep+
+                           ;; date
+                           " \"expire-date\"  TEXT    NOT NULL,"
+                           ;; boolean
+                           " expired          INTEGER DEFAULT 0 ,"
+                           ;; boolean
+                           " multiple         INTEGER DEFAULT 0 ,"
+                           " \"voters-count\" INTEGER DEFAULT 0 ,"
+                           " \"votes-count\"  INTEGER DEFAULT 0 ,"
+                           ;; boolean
+                           " \"voted\"        INTEGER DEFAULT 0 ,"
+                           ;; comma separated values
+                           " \"own-votes\"    TEXT "
+                           +make-close+)))
+
 (defun make-status ()
   (query-low-level (strcat (prepare-table +table-status+ :autogenerated-id-p nil)
                            " \"status-id\"        TEXT    NOT NULL, "
@@ -452,7 +487,10 @@
               +table-subscribed-tag+
               +table-tag-histogram+
               +table-attachment+
-              +table-conversation+))
+              +table-conversation+
+              +table-pagination-status+
+              +table-poll-option+
+              +table-poll+))
 
 (defun build-views ())
 
@@ -478,6 +516,8 @@
     (make-tag-histogram)
     (make-conversation)
     (make-pagination-status)
+    (make-poll-option)
+    (make-poll)
     (build-all-indices)
     (fs:set-file-permissions (db-path) (logior fs:+s-irusr+ fs:+s-iwusr+))))
 
@@ -714,14 +754,98 @@ than (swconf:config-purge-history-days-offset) days in the past"
   (and object
        (tooter:original object)))
 
+(defun find-poll-option (poll-id title)
+  (fetch-single (select :*
+                  (from +table-poll-option+)
+                  (where (:and (:= :title     title)
+                               (:= :poll-id poll-id))))))
+
+(defun poll-option-exists-p (poll-id title)
+  (find-poll-option poll-id title))
+
+(defun all-poll-options (poll-id)
+  (fetch-all-rows (select :*
+                    (from +table-poll-option+)
+                    (where (:= :poll-id poll-id)))))
+
+(defun find-poll (poll-id)
+  (fetch-from-id +table-poll+ poll-id))
+
+(defun find-poll-bound-to-status (status-id)
+  (fetch-single (select :*
+                  (from +table-poll+)
+                  (where (:= :status-id status-id)))))
+
+(defun poll-bound-to-status-exists-p (status-id)
+  (find-poll-bound-to-status status-id))
+
+(defmethod update-db ((object tooter:poll-option) &key (poll-id nil) &allow-other-keys)
+  (assert poll-id)
+  (with-accessors ((title       tooter:title)
+                   (votes-count tooter:votes-count)) object
+    (let ((insert-query (make-insert +table-poll-option+
+                                     (:title :votes-count :poll-id)
+                                     (title  votes-count  poll-id)))
+          (update-query (make-update +table-poll-option+
+                                     (:votes-count)
+                                     (votes-count)
+                                     (:and (:= :title     title)
+                                           (:= :poll-id poll-id)))))
+      (if (poll-option-exists-p poll-id title)
+          (query update-query)
+          (query insert-query)))))
+
+(defmethod update-db ((object tooter:poll) &key (status-id nil) &allow-other-keys)
+  (assert status-id)
+  (with-accessors ((id           tooter:id)
+                   (expires-at   tooter:expires-at)
+                   (expired      tooter:expired)
+                   (multiple     tooter:multiple)
+                   (voters-count tooter:voters-count)
+                   (votes-count  tooter:votes-count)
+                   (voted        tooter:voted)
+                   (own-votes    tooter:own-votes)
+                   (options      tooter:options)) object
+    (let* ((expire-date      (prepare-for-db 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))
+           (actual-own-votes (join-with-strings (if own-votes
+                                                    (mapcar #'to-s own-votes)
+                                                    "")
+                                                +tag-separator+))
+           (insert-query (make-insert +table-poll+
+                                      (:id
+                                       :status-id
+                                       :expire-date
+                                       :expired
+                                       :multiple
+                                       :voters-count
+                                       :votes-count
+                                       :voted
+                                       :own-votes)
+                                      (id
+                                       status-id
+                                       expire-date
+                                       actual-expired
+                                       actual-multiple
+                                       voters-count
+                                       votes-count
+                                       actual-voted
+                                       actual-own-votes))))
+      (when (not (poll-bound-to-status-exists-p status-id))
+        (query insert-query))
+      (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)
   (with-accessors ((id  tooter:id)
-                   (kind tooter:kind)
+                   (kind        tooter:kind)
-                   (url tooter:url)
+                   (url         tooter:url)
                    (preview-url tooter:preview-url)
-                   (remote-url tooter:remote-url)
+                   (remote-url  tooter:remote-url)
-                   (text-url tooter:text-url)
+                   (text-url    tooter:text-url)
-                   (metadata tooter:metadata)
+                   (metadata    tooter:metadata)
                    (description tooter:description)
                    (blurhash    tooter:blurhash)) object
     (assert status-id)
@@ -902,7 +1026,8 @@ than (swconf:config-purge-history-days-offset) days in the past"
                    (account                tooter:account)
                    (tags                   tooter:tags)
                    (application            tooter:application)
-                   (media-attachments      tooter:media-attachments)) object
+                   (media-attachments      tooter:media-attachments)
+                   (poll                   tooter:poll)) object
     (update-db account)
     (let* ((account-id         (tooter:id account))
            (actual-created-at  (decode-datetime-string created-at))
@@ -981,8 +1106,8 @@ than (swconf:config-purge-history-days-offset) days in the past"
                                           folder))))
           (when (not (single-status-exists-p id timeline folder))
             (query insert-query)
-            ;; attachments and tag history latest because of the reference from this table
+            ;; attachments, tag history latest because of the
-            ;; to table status
+            ;; reference from this table to table status
             (map nil
                  (lambda (media-attachment)
                    (update-db media-attachment :status-id id))
@@ -997,7 +1122,10 @@ than (swconf:config-purge-history-days-offset) days in the past"
                        :skip-ignored-p skip-ignored-p
                        :timeline       +default-reblogged-timeline+)
             ;; now try to decrypt message if possible/needed
-            (maybe-decrypt-update-status-text id timeline folder)))))))
+            (maybe-decrypt-update-status-text id timeline folder))
+          ;; add poll or update poll's votes
+          (when poll
+            (update-db poll :status-id id)))))))
 
 (defun maybe-decrypt-update-status-text (status-id timeline folder)
   "Decrypt, if possible, status identified by `status-id', `timeline' and `folder'.
@@ -1329,6 +1457,15 @@ row."
 
 (gen-access-message-row conversation-root-status-id :root-status-id)
 
+(gen-access-message-row poll-expired-p              :expired)
+
+(gen-access-message-row expire-date                 :expire-date)
+
+(gen-access-message-row title                       :title)
+
+(defun row-votes-count (row)
+  (and row (db-getf row :votes-count 0)))
+
 (defun row-message-reply-to-id (row)
   (and row
        (db-getf row :in-reply-to-id)))

src/message-rendering-utils.lisp

@@ -230,3 +230,30 @@
                 (right-padding boosted-label padding-length)
                 boosted-username)))
     text))
+
+(defun poll->text (poll-id width)
+  (when poll-id
+    (when-let* ((poll          (db:find-poll poll-id))
+                (options       (db:all-poll-options poll-id))
+                (all-titles    (loop for option in options collect (db:row-title option)))
+                (vote-sum      (reduce #'+
+                                       (mapcar #'db:row-votes-count options)))
+                (max-title-w   (find-max-line-length all-titles))
+                (max-bar-width (- width max-title-w 6))
+                (bar-char      (swconf:vote-vertical-bar))
+                (expiredp      (db:row-poll-expired-p poll)))
+      (with-output-to-string (stream)
+        (loop for option in options do
+             (let* ((title (left-padding (db:row-title option) max-title-w))
+                    (rate  (handler-case
+                               (/ (db:row-votes-count option)
+                                  vote-sum)
+                             (error () 0)))
+                    (vote  (left-padding (format nil "~a%" (* 100 rate)) 4))
+                    (bar-w (truncate (* rate max-bar-width))))
+               (format stream "~a " title)
+               (loop for i from 0 below bar-w do
+                    (princ bar-char stream))
+               (format stream " ~a~%" (left-padding vote (- max-bar-width bar-w)))))
+        (when expiredp
+          (format stream "~%~a~%" (_ "The poll has expired")))))))

src/package.lisp

@@ -692,6 +692,10 @@
    :next-in-history
    :most-recent-history-id
    :purge-history
+   :all-poll-options
+   :find-poll
+   :find-poll-option
+   :find-poll-bound-to-status
    :update-db
    :message-root
    :message-children
@@ -722,6 +726,10 @@
    :row-conversation-folder
    :row-conversation-root-status-id
    :row-conversation-ignored-p
+   :row-poll-expired-p
+   :row-expire-date
+   :row-title
+   :row-votes-count
    :row-message-reply-to-id
    :next-status-tree
    :previous-status-tree
@@ -866,6 +874,7 @@
    :+key-window+
    :+key-focus+
    :+key-mark+
+   :+key-vote-vertical-bar+
    :+key-info-dialog+
    :+key-help-dialog+
    :+key-error-dialog+
@@ -913,6 +922,7 @@
    :parse
    :load-config-file
    :external-editor
+   :vote-vertical-bar
    :crypted-mark-value
    :quick-help-header-colors
    :window-titles-ends
@@ -1555,7 +1565,8 @@
    :attachment-type->metadata
    :status-attachments->text
    :message-original->text-body
-   :message-original->text-header))
+   :message-original->text-header
+   :poll->text))
 
 (defpackage :thread-window
   (:use

src/software-configuration.lisp

@@ -321,6 +321,7 @@
                    attribute
                    new-message
                    mark
+                   vote-vertical-bar
                    crypted
                    histogram
                    error-dialog
@@ -415,6 +416,11 @@
 
 ;;;; interface
 
+(defun vote-vertical-bar ()
+  (or (access:accesses *software-configuration*
+                       +key-vote-vertical-bar+)
+      "="))
+
 (defun crypted-mark-value ()
   (or (access:accesses *software-configuration*
                        +key-crypted+

src/thread-window.lisp

@@ -775,9 +775,13 @@ db:renumber-timeline-message-index."
                 (original     (db-utils:db-getf fields :content ""))
                 (status-id    (db:row-message-status-id fields))
                 (header       (message-original->text-header fields)))
-      (let* ((body        (db:row-message-rendered-text fields))
+      (let* ((body          (db:row-message-rendered-text fields))
-             (attachments (status-attachments->text status-id))
+             (attachments   (status-attachments->text status-id))
-             (refresh-event (make-instance 'program-events:refresh-conversations-window-event)))
+             (refresh-event (make-instance 'program-events:refresh-conversations-window-event))
+             (poll          (db:find-poll-bound-to-status status-id))
+             (poll-text     (poll->text (db:row-id poll)
+                                        (truncate (/ (win-width-no-border object)
+                                                     2)))))
         (multiple-value-bind (reblogged-status-body reblogged-status-attachments)
             (reblogged-data fields)
           (let ((actual-body        (if (string= body reblogged-status-body)
@@ -789,6 +793,7 @@ db:renumber-timeline-message-index."
             (setf (message-window:source-text *message-window*)
                   (strcat header
                           actual-body
+                          poll-text
                           actual-attachments))
             (db:mark-status-red-p timeline-type timeline-folder status-id)
             (resync-rows-db object :redraw t)