chatikbot/plugins/vk.lisp

(in-package :cl-user)
(defpackage chatikbot.plugins.vk
  (:use :cl :chatikbot.common :alexandria))
(in-package :chatikbot.plugins.vk)

(defparameter +vk-api-ver+ "5.53" "vk api version to use")
(defparameter +vk-api-url+ "https://api.vk.com/method/~A?v=~A" "vk.com API endpoint")
(defparameter +vk-oauth-authorize+ "https://oauth.vk.com/authorize" "vk.com OAuth authrization endpoint")
(defsetting *vk-app-client-id* nil "vk app to authenticate against")
(defsetting *vk-app-client-secret* nil "vk app secret")

(defparameter +vk-scope-mapping+
  '((:notify . 1) (:friends . 2) (:photos . 4) (:audio . 8) (:video . 16) (:docs . 131072) (:notes . 2048)
    (:pages . 128) (:pages-left . 256) (:status . 1024) (:offers . 32) (:questions . 64) (:wall . 8192)
    (:groups . 262144) (:messages . 4096) (:email . 4194304) (:notifications . 524288) (:stats . 1048576)
    (:ads . 32768) (:market . 134217728) (:offline . 65536)))

(defun vk-get-authorization-url (&optional state &rest scopes)
  (let ((scope (apply #'+ (mapcar #'(lambda (k) (cdr (assoc k +vk-scope-mapping+))) scopes))))
    (format nil "~A?v=~A&client_id=~A&redirect_uri=~A~@[&scope=~A~]~@[&state=~A~]"
            +vk-oauth-authorize+ +vk-api-ver+ *vk-app-client-id* (get-oauth-url) (unless (zerop scope) scope) state)))

(defun %vk-api-call (method &optional args)
  (let* ((params (loop for (k . v) in args
                    when v
                    collect (cons
                             (princ-to-string k)
                             (princ-to-string v))))
         (response (json-request (format nil +vk-api-url+ method +vk-api-ver+)
                                 :method :post
                                 :content params
                                 :timeout 5)))
    (when (aget "error" response)
      (error (aget "error_msg" (aget "error" response))))
    (aget "response" response)))

;; Database
(def-db-init
  (db-execute "create table if not exists vk_walls (domain, last_id, next_fetch, period)")
  (db-execute "create unique index if not exists vk_walls_domain_idx on vk_walls (domain)")

  (db-execute "create table if not exists vk_chat_walls (chat_id, domain)")
  (db-execute "create index if not exists vk_chat_walls_chat_idx on vk_chat_walls (chat_id)")
  (db-execute "create index if not exists vk_chat_walls_domain_idx on vk_chat_walls (domain)"))

(defun db/vk-ensure-domain (domain last-id)
  (db-transaction
    (unless (db-single "select domain from vk_walls where domain = ?" domain)
      (db-execute "insert into vk_walls (domain, last_id, period) values (?, ?, 300)" domain last-id))))

(defun db/vk-get-domain-chats (domain)
  (flatten (db-select "select chat_id from vk_chat_walls where domain = ?" domain)))

(defun db/vk-get-chat-domains (chat-id)
  (flatten (db-select "select domain from vk_chat_walls where chat_id  = ?" chat-id)))

(defun db/vk-add-chat-domain (chat-id domain)
  (db-execute "insert into vk_chat_walls (chat_id, domain) values (?, ?)" chat-id domain))

(defun db/vk-remove-chat-domain (chat-id domain)
  (db-execute "delete from vk_chat_walls where chat_id = ? and domain = ?" chat-id domain))

(defun db/vk-get-active-walls ()
  (db-select "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)
  (db-execute "update vk_walls set last_id = ?, next_fetch = ?, period = ? where domain = ?" last-id next-fetch period domain))

(defun vk-wall-get (&key owner-id domain offset count filter extended fields)
  (%vk-api-call "wall.get"
                `(("owner_id" . ,owner-id)
                  ("domain" . ,domain)
                  ("offset" . ,offset)
                  ("count" . ,count)
                  ("filter" . ,filter)
                  ("extended" . ,extended)
                  ("fields" . ,fields))))

(defun vk-wall-get-by-id (post-ids &key extended fields copy-history-depth)
  (%vk-api-call "wall.getById"
                `(("posts" . ,(if (consp post-ids)
                                  (format nil "~{~A~^,~}" post-ids) post-ids))
                  ("extended" . ,extended)
                  ("copy_history_depth" . ,copy-history-depth)
                  ("fields" . ,fields))))

(defun vk-get-user-name (id)
  (let ((r (first (%vk-api-call "users.get" `(("user_ids" . ,id))))))
    (format nil "~A ~A" (aget "first_name" r) (aget "last_name" r))))

(defun vk-get-group-name (id)
  (aget "name" (first (%vk-api-call "groups.getById"
                                    `(("group_id" . ,(if (numberp id)
                                                         (- id)
                                                         id)))))))

(defun vk-get-name (id)
  (if (and (numberp id) (> id 0))
      (vk-get-user-name id)
      (vk-get-group-name id)))

;; VK walls
(defun %send-domains (chat-id domains)
  (bot-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 (quri:uri-path (quri: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 %vk-find-best-photo (attach)
  (when attach
    (let* ((photo (aget "photo" attach))
           (sizes (loop for (k . v) in photo
                    when (equal "photo_" (subseq k 0 (min 6 (length k))))
                    collect (cons (parse-integer (subseq k 6)) v))))
      (cdr (assoc (apply #'max (mapcar #'car sizes)) sizes)))))

(defun %vk-find-video (attach)
  (when attach
    (let ((video (aget "video" attach)))
      (format nil "https://vk.com/video~A_~A"
              (aget "owner_id" video)
              (aget "id" video)))))

(defun %vk-find-preview (attachments)
  (labels ((find-type (type)
             (find type attachments :key #'(lambda (a) (aget "type" a)) :test #'equal)))
    (or
     (%vk-find-best-photo (find-type "photo"))
     (%vk-find-video (find-type "video")))))

(defparameter +vk-link-scanner+ (cl-ppcre:create-scanner "\\[((id|club)\\d+)\\|([^\\]]*?)\\]") "vk linking regex")

(defun %vk-post-text (post)
  (let* ((history (aget "copy_history" post))
         (reposts (loop for p in history
                     collect (let* ((owner (aget "owner_id" p))
                                    (type (if (> owner 0) "id" "club"))
                                    (id (abs owner)))
                               (format nil "[~A](https://vk.com/~A~A)"
                                       (vk-get-name owner) type id)))))
    (when history
      (setf post (car (last history))))
    (values
     (cl-ppcre:regex-replace-all +vk-link-scanner+
                                 (aget "text" post)
                                 "[\\3](https://vk.com/\\1)")
     (%vk-find-preview (aget "attachments" post))
     reposts)))

(defun %format-wall-post (domain name post)
  (multiple-value-bind (text preview reposts) (%vk-post-text post)
    (values
     (format nil "~@[[✅](~A) ~][~A](https://vk.com/~A?w=wall~A_~A)~@[ ~{↩ ~A~}~]~@[ @ ~A~]~%~A"
             preview name domain (aget "from_id" post) (aget "id" post)
             reposts (format-ts (local-time:unix-to-timestamp (aget "date" post)))
             text)
     (if preview 0 1))))

;; Cron
(defcron process-walls ()
  (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))))
                    name)
                (setf period (chatikbot.plugins.rss::adjust-period period (length new-posts)))
                (when new-posts
                  (setf name (vk-get-name domain)))
                (dolist (post new-posts)
                  (multiple-value-bind (text disable)
                      (%format-wall-post domain name post)
                    (dolist (chat-id (db/vk-get-domain-chats domain))
                      (ignore-errors
                        (telegram-send-message chat-id text
                                               :parse-mode "Markdown"
                                               :disable-web-preview disable))))
                  (setf last-id (max last-id (aget "id" post)))))
            (error (e) (log:error "~A" 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
  )

;; Hooks
(defparameter +akb-vk-domain+ "baneks" "VK.com username of 'B-category anekdotes'")
(defvar *akb-max-posts* 10 "Maximum number of AKB posts to send at once")

(defun format-akb (post)
  (let* ((id (aget "id" post))
         (url (format nil "https://vk.com/~A?w=wall~A_~A"
                      +akb-vk-domain+ (aget "from_id" post) id)))
    (format nil "~A~%~A" (aget "text" post) url)))

(def-message-cmd-handler handler-akb (:akb)
  (let ((total-aneks
         (aget "count" (vk-wall-get :domain +akb-vk-domain+ :count 1 :offset 10000000))))
    (dolist (post (aget "items" (vk-wall-get :domain +akb-vk-domain+
                                             :count (min *akb-max-posts*
                                                         (or (ignore-errors (parse-integer (car args)))
                                                             1))
                                             :offset (random total-aneks))))
      (bot-send-message chat-id (format-akb post) :disable-web-preview 1))))

(def-message-cmd-handler handler-cmd-wall (:wall)
  (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-domain 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 "~A" e))))
          (%send-domains chat-id (db/vk-get-chat-domains chat-id))))))