VK walls posting

chatikbot.lisp

@@ -77,6 +77,7 @@
               (:rss (handle-cmd-rss chat-id id args))
               (:feeds (handle-cmd-feeds chat-id id args))
               (:lastrss (handle-cmd-last-rss chat-id id args))
+              (:wall (handle-cmd-wall chat-id id args))
               (otherwise (handle-admin-cmd chat-id text cmd args))))
           (send-dont-understand chat-id (preprocess-input text))))
     (when location
@@ -437,6 +438,88 @@
         (db-rss-update-feed feed)) ;; Update next fetch and period
     (error (e) (log:error e))))
 
+;; VK walls
+(defun %send-domains (chat-id domains)
+  (telegram-send-message
+   chat-id
+   (if (null domains)
+       "Пока ничего не постим"
+       (format nil "Постим~%~{~A) https://vk.com/~A~^~%~}"
+               (loop for d in domains for i from 1 append (list i d))))
+   :disable-web-preview 1))
+
+(defun %find-vk-domain (url)
+  (let ((path (puri:uri-path (puri:parse-uri url))))
+    (if (equal #\/ (elt path 0))
+        (subseq path 1)
+        path)))
+
+(defun %ensure-domain (domain)
+  (let* ((res (vk-wall-get :domain domain :count 1))
+         (last-id (aget "id" (first (aget "items" res)))))
+    (db-vk-ensure-domain domain last-id)
+    domain))
+
+(defun %format-wall-post (domain post)
+  (format nil "[~A](https://vk.com/~A?w=wall~A_~A)~@[ @ _~A_~]~%~A~%"
+          domain domain (aget "from_id" post) (aget "id" post)
+          (alexandria:when-let (ts (local-time:unix-to-timestamp (aget "date" post)))
+            (local-time:format-timestring
+             nil ts
+             :format '((:year 2) "-" (:month 2) "-" (:day 2)
+                       " " (:hour 2) ":" (:min 2))))
+          (aget "text" post)))
+
+(defun handle-cmd-wall (chat-id message-id args)
+  (log:info "handle-cmd-wall" chat-id message-id args)
+  (handler-case
+      (let ((domains (db-vk-get-chat-domains chat-id)))
+        (if (null args)
+            (%send-domains chat-id domains)
+            (progn
+              (dolist (url args)
+                (handler-case
+                    (let ((idx (parse-integer url)))
+                      (db-vk-remove-chat-wall chat-id (nth (1- idx) domains)))
+                  (parse-error ()
+                    (let* ((domain (%ensure-domain (%find-vk-domain url)))
+                           (existing (find domain domains :test #'equal)))
+                      (if existing
+                          (db-vk-remove-chat-domain chat-id domain)
+                          (db-vk-add-chat-domain chat-id domain))))
+                  (error (e) (log:error e))))
+              (%send-domains chat-id (db-vk-get-chat-domains chat-id)))))
+    (error (e)
+      (log:error e)
+      (telegram-send-message chat-id "Ошибочка вышла"))))
+
+(defun process-walls ()
+  (handler-case
+      (loop for (domain last-id next-fetch period) in (db-vk-get-active-walls)
+         when (or (null next-fetch)
+                  (local-time:timestamp> (local-time:now) (local-time:unix-to-timestamp next-fetch)))
+         do (progn
+              (log:info "Fetching wall" domain)
+              (handler-case
+                  (let ((new-posts
+                         (remove last-id (reverse (aget "items" (vk-wall-get :domain domain)))
+                                 :test #'>= :key (lambda (p) (aget "id" p)))))
+                    (setf period (adjust-period period (length new-posts)))
+                    (dolist (post new-posts)
+                      (dolist (chat-id (db-vk-get-domain-chats domain))
+                        (ignore-errors
+                          (telegram-send-message chat-id
+                                                 (%format-wall-post domain post)
+                                                 :parse-mode "Markdown"
+                                                 :disable-web-preview 1)))
+                      (setf last-id (max last-id (aget "id" post)))))
+                (error (e) (log:error e)))
+              (db-vk-update-wall domain last-id
+                                 (local-time:timestamp-to-unix
+                                  (local-time:timestamp+ (local-time:now) period :sec))
+                                 period))) ;; Update last-id, next-fetch and period
+    (error (e) (log:error e))))
+
 
 (defvar *save-settings-lock* (bordeaux-threads:make-lock "save-settings-lock")
   "Lock for multithreading access to write settings file")
@@ -459,7 +542,8 @@
 (defvar *schedules* '(process-latest-akb
                       process-latest-checkins
                       process-rates
-                      process-feeds) "Enabled schedules")
+                      process-feeds
+                      process-walls) "Enabled schedules")
 
 (defun start ()
   ;; Clear prev threads

db.lisp

@@ -33,7 +33,15 @@
 
     (sqlite:execute-non-query db "create table if not exists rss_chat_feeds (chat_id, feed_id REFERENCES rss_feeds)")
     (sqlite:execute-non-query db "create index if not exists rss_chat_feeds_chat_idx on rss_chat_feeds (chat_id)")
-    (sqlite:execute-non-query db "create index if not exists rss_chat_feeds_feed_idx on rss_chat_feeds (feed_id)")))
+    (sqlite:execute-non-query db "create index if not exists rss_chat_feeds_feed_idx on rss_chat_feeds (feed_id)")
+
+    ;; VK
+    (sqlite:execute-non-query db "create table if not exists vk_walls (domain, last_id, next_fetch, period)")
+    (sqlite:execute-non-query db "create unique index if not exists vk_walls_domain_idx on vk_walls (domain)")
+
+    (sqlite:execute-non-query db "create table if not exists vk_chat_walls (chat_id, domain)")
+    (sqlite:execute-non-query db "create index if not exists vk_chat_walls_chat_idx on vk_chat_walls (chat_id)")
+    (sqlite:execute-non-query db "create index if not exists vk_chat_walls_domain_idx on vk_chat_walls (domain)")))
 
 ;; Finance
 (defun db-add-finance (ts usd eur gbp brent btc)
@@ -171,3 +179,34 @@
     (with-db (db)
       (mapcar #'(lambda (row) (%make-feed-item feed row))
               (sqlite:execute-to-list db "select guid, link, title, published from rss_items where feed_id = ? order by published desc, id desc limit ?" id limit)))))
+
+
+;; VK
+(defun db-vk-ensure-domain (domain last-id)
+  (with-db (db)
+    (unless (sqlite:execute-single db "select domain from vk_walls where domain = ?" domain)
+      (sqlite:execute-non-query db "insert into vk_walls (domain, last_id, period) values (?, ?, 300)" domain last-id))))
+
+(defun db-vk-get-domain-chats (domain)
+  (with-db (db)
+    (flatten (sqlite:execute-to-list db "select chat_id from vk_chat_walls where domain = ?" domain))))
+
+(defun db-vk-get-chat-domains (chat-id)
+  (with-db (db)
+    (flatten (sqlite:execute-to-list db "select domain from vk_chat_walls where chat_id  = ?" chat-id))))
+
+(defun db-vk-add-chat-domain (chat-id domain)
+  (with-db (db)
+    (sqlite:execute-non-query db "insert into vk_chat_walls (chat_id, domain) values (?, ?)" chat-id domain)))
+
+(defun db-vk-remove-chat-domain (chat-id domain)
+  (with-db (db)
+    (sqlite:execute-non-query db "delete from vk_chat_walls where chat_id = ? and domain = ?" chat-id domain)))
+
+(defun db-vk-get-active-walls ()
+  (with-db (db)
+    (sqlite:execute-to-list db "select domain, last_id, next_fetch, period from vk_walls w where exists (select 1 from vk_chat_walls where domain=w.domain)")))
+
+(defun db-vk-update-wall (domain last-id next-fetch period)
+  (with-db (db)
+    (sqlite:execute-to-list db "update vk_walls set last_id = ?, next_fetch = ?, period = ? where domain = ?" last-id next-fetch period domain)))