chatikbot/chatikbot.lisp

(in-package #:chatikbot)

;; Load config file
(alexandria:when-let (file (probe-file
                            (merge-pathnames "config.lisp"
                                             (asdf:component-pathname
                                              (asdf:find-system '#:chatikbot)))))
  (load file))

;; Init database
(db-init)

(defvar *telegram-last-update* nil "Telegram last update_id")
(defvar *admins* nil "Admins chat-ids")

(defun process-updates ()
  (loop for update in (telegram-get-updates :offset (and *telegram-last-update*
                                                         (1+ *telegram-last-update*))
                                            :timeout 300)
     do (setf *telegram-last-update*
              (max (or *telegram-last-update* 0)
                   (aget "update_id" update)))
     do (handle-message (aget "message" update))))


(defun send-response (chat-id response &optional reply-id)
  (if (consp response)
      (if (keywordp (car response))
          (case (car response)
            (:text (telegram-send-message chat-id (cdr response) :reply-to reply-id))
            (:voice (telegram-send-voice chat-id (cdr response) :reply-to reply-id))
            (:sticker (telegram-send-sticker chat-id (cdr response) :reply-to reply-id)))
          (mapc #'(lambda (r) (send-response chat-id r reply-id)) response))
      (telegram-send-message chat-id response :reply-to reply-id)))

(defun send-dont-understand (chat-id &optional text reply-id)
  (let ((resp (eliza text)))
    (log:info text resp)
    (when resp
      (send-response chat-id resp reply-id))))

(defvar *chat-locations* nil "ALIST of chat->location")

(defun preprocess-input (text)
  (when text
    (let ((first-word (subseq text 0 (position #\Space text))))
      (if (equal first-word "@chatikbot")
          (preprocess-input (subseq text 11))
          (replace-all text "@chatikbot" "ты")))))

(defun parse-cmd (text)
  (let* ((args (split-sequence:split-sequence #\Space (subseq text 1) :remove-empty-subseqs t))
         (cmd (subseq (car args) 0 (position #\@ (car args)))))
    (values (intern (string-upcase cmd) "KEYWORD") (rest args))))

(defun handle-message (message)
  (let ((id (aget "message_id" message))
        (chat-id (aget "id" (aget "chat" message)))
        (text (aget "text" message))
        (location (aget "location" message))
        (sticker (aget "file_id" (aget "sticker" message))))
    (log:info "handle-message" message)
    (when text
      (if (equal #\/ (char text 0))
          (multiple-value-bind (cmd args) (parse-cmd text)
            (case cmd
              (:postakb (handle-cmd-post-akb chat-id id args))
              (:akb (handle-cmd-akb chat-id id args))
              (:weather (handle-cmd-weather chat-id id args))
              (:hourly (handle-cmd-weather chat-id id '("hourly")))
              (:daily (handle-cmd-weather chat-id id '("daily")))
              (:rates (handle-cmd-rates chat-id id args))
              (:charts (handle-cmd-charts chat-id id args))
              (:postcheckins (handle-cmd-post-checkins chat-id id args))
              (:friends (handle-cmd-fsq-friends chat-id id args))
              (:checkins (handle-cmd-checkins chat-id id args))
              (: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
      (push (cons chat-id location) *chat-locations*)
      (telegram-send-message chat-id "Взял на карандаш")
      (save-settings))
    (when sticker
      (send-dont-understand chat-id))))

(defmacro handling-errors (&body body)
  `(handler-case (progn ,@body)
     (simple-condition (err)
       (format *error-output* "~&~A: ~%" (class-name (class-of err)))
       (apply (function format) *error-output*
              (simple-condition-format-control   err)
              (simple-condition-format-arguments err))
       (format *error-output* "~&"))
     (condition (err)
       (format *error-output* "~&~A: ~%  ~S~%"
               (class-name (class-of err)) err))))

(defun rep (input)
  (when input
    (with-output-to-string (*standard-output*)
      (let ((*package* (find-package 'chatikbot))
            (*error-output* *standard-output*))
        (handling-errors
          (format t "~{~S~^ ;~%     ~}~%"
                  (multiple-value-list (eval (read-from-string input)))))))))

(defun handle-admin-cmd (chat-id text cmd args)
  (if (find chat-id *admins*)
      (case cmd
        (:eval (telegram-send-message chat-id (rep (format nil "~{~A~^ ~}" args))))
        (otherwise (send-dont-understand chat-id (preprocess-input (subseq text 1)))))
      (send-dont-understand chat-id (preprocess-input (subseq text 1)))))


;; AKB
(defparameter +akb-vk-domain+ "baneks" "VK.com username of 'B-category anekdotes'")
(defvar *akb-send-to* nil "List of chat-id's to send AKBs to")

(defun handle-cmd-post-akb (chat-id message-id args)
  (log:info "handle-cmd-post-akb" chat-id message-id args)
  (let ((message "Хуярим аники"))
    (if (member chat-id *akb-send-to*)
        (setf message "Не хуярим больше аники"
              *akb-send-to* (set-difference *akb-send-to*
                                            (list chat-id)))
        (setf *akb-send-to* (cons chat-id *akb-send-to*)))
    (telegram-send-message chat-id message)
    (save-settings)))

(defvar *akb-max-count* 5 "Max number of tweets to return per run")
(defvar *akb-last-id* 0 "id of last AKB tweet")

(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)))

(defun process-latest-akb ()
  (handler-case
      (dolist (post (reverse (aget "items" (vk-wall-get :domain +akb-vk-domain+
                                                        :count *akb-max-count*))))
        (let ((id (aget "id" post)))
          (when (> id *akb-last-id*)
            (send-akb (format-akb post))
            (setf *akb-last-id* id)
            (save-settings))))
    (error (e) (log:error e))))

(defun send-akb (text)
  (log:info "send-akb: ~A" text)
  (dolist (chat-id *akb-send-to*)
    (handler-case
        (telegram-send-message chat-id text
                               :disable-web-preview 1)
      (error (e) (log:error e)))))

(defun handle-cmd-akb (chat-id message-id args)
  (log:info "handle-cmd-akb" chat-id message-id args)
  (handler-case
      (progn
	(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 (or (ignore-errors (parse-integer (car args))) 1)
						   :offset (random total-aneks))))
	    (handler-case
		(telegram-send-message chat-id
				       (format-akb post)
				       :disable-web-preview 1)
	      (error (e) (log:error e))))))
    (error (e)
      (log:error e)
      (telegram-send-message chat-id "Ошибочка вышла"))))

;; Finance
(defun process-rates ()
  (handler-case
      (let ((ts (local-time:timestamp-to-unix (local-time:now)))
            (rates (get-rates))
            (brent (get-brent))
            (btc (get-btc-e)))
        (db-add-finance ts (aget "USD/RUB" rates) (aget "EUR/RUB" rates) (aget "GBP/RUB" rates) brent btc))
    (error (e) (log:error e))))

(defun handle-cmd-rates (chat-id message-id args)
  (log:info "handle-cmd-rates" chat-id message-id args)
  (multiple-value-bind (ts usd eur gbp brent btc) (db-get-last-finance)
    (telegram-send-message chat-id
                           (format nil "Зеленый *~,2F*, гейро *~,2F*, британец *~,2F*, чёрная *~,2F*, btc *~,2F* @ _~A_"
                                   usd eur gbp brent btc
                                   (format-ts (local-time:unix-to-timestamp ts)))
                           :parse-mode "Markdown")))

(defparameter +chart-ranges+ (list (cons "day" (* 24 60))
                                   (cons "week" (* 7 24 60))
                                   (cons "month" (* 30 24 60))
                                   (cons "quarter" (* 91 24 60))
                                   (cons "year" (* 365 24 60))))

(defun handle-cmd-charts (chat-id message-id args)
  (log:info "handle-cmd-charts" chat-id message-id args)
  (telegram-send-chat-action chat-id "upload_photo")
  (handler-case
      (let* ((args (mapcar 'string-downcase args))
             (all-fields (mapcar #'car +db-finance-map+))
             (fields (or (intersection args all-fields :test 'equal) all-fields))
             (day-range (some #'(lambda (a) (aget a +chart-ranges+)) args))
             (number (some #'(lambda (a) (parse-integer a :junk-allowed t)) args))
             (avg (* 60 (cond
                          (day-range (round day-range *chart-points*))
                          (number)
                          (:otherwise 1))))
             (after-ts (local-time:timestamp- (local-time:now)
                                              (* avg *chart-points*) :sec))
             (rates (multiple-value-list (db-get-last-finance)))
             (chart (apply #'make-chart (multiple-value-list
                                         (db-get-series after-ts fields avg)))))
        (telegram-send-photo chat-id chart
                             :caption
                             (format nil "Зеленый ~,2F, гейро ~,2F, британец ~,2F, чёрная ~,2F, btc ~,2F @ ~A"
                                     (elt rates 1) (elt rates 2) (elt rates 3) (elt rates 4) (elt rates 5)
                                     (format-ts (local-time:unix-to-timestamp (elt rates 0))))))
    (error (e)
      (log:error e)
      (telegram-send-message chat-id "Хуйня какая-то"))))

;; Weather
(defun handle-cmd-weather (chat-id message-id args)
  (log:info "handle-cmd-weather" chat-id message-id args)
  (let ((location (cdr (assoc chat-id *chat-locations*))))
    (telegram-send-message
     chat-id
     (if location
	 (handler-case
	     (forecast-format (forecast
			       (aget "latitude" location)
			       (aget "longitude" location)
			       :hourly (find "hourly" args :key #'string-downcase :test #'equal)
			       :daily (find "daily" args :key #'string-downcase :test #'equal)))
	   (error (e)
	     (log:error e)
	     "Ошибочка вышла"))
     "Так а ты чьих будешь?"))))


;; Foursquare
(defun fsq-user-name (user)
  (when user
    (format nil "~@[~A~]~@[ ~A~]"
            (aget "firstName" user)
            (aget "lastName" user))))

(defun handle-cmd-post-checkins (chat-id message-id args)
  (log:info "handle-cmd-post-checkins" chat-id message-id args)
  (handler-case
      (let ((users (db-fsq-get-chat-users chat-id))
            (friends (fsq-fetch-friends)))
        (if (null args)
            (telegram-send-message chat-id
                                   (if (null users)
                                       "Пока никого не палим"
                                       (format nil "Палим ~{~A~^, ~}"
                                               (loop for user in friends
                                                  when (member (aget "id" user)
                                                               users :test #'equal)
                                                  collect (fsq-user-name user)))))
            (progn
              (dolist (user args)
                (let ((username (fsq-user-name
                                 (find user friends
                                       :test #'equal
                                       :key #'(lambda (f) (aget "id" f))))))
                  (when username
                    (if (member user users :test #'equal)
                        (progn
                          (setf users (remove user users :test #'equal))
                          (telegram-send-message chat-id
                                                 (format nil "Больше не палим ~A" username)))
                        (progn
                          (push user users)
                          (telegram-send-message chat-id (format nil "Теперь палим ~A" username)))))))
              (db-fsq-set-chat-users chat-id users))))
    (error (e)
      (log:error e)
      (telegram-send-message chat-id "Ошибочка вышла"))))

(defun handle-cmd-fsq-friends (chat-id message-id args)
  (log:info "handle-cmd-fsq-friends" chat-id message-id args)
  (handler-case
      (let ((users (db-fsq-get-chat-users chat-id))
            (friends (fsq-fetch-friends)))
        (telegram-send-message
         chat-id
         (format
          nil "~{~A: ~:[~;📍 ~]~A~^~%~}"
          (loop for user in friends
             append (list
                     (aget "id" user)
                     (member (aget "id" user) users :test #'equal)
                     (fsq-user-name user))))))
    (error (e) (log:error e))))


(defun handle-cmd-checkins (chat-id message-id args)
  (log:info "handle-cmd-checkins" chat-id message-id args)
  (handler-case
      (let ((users (db-fsq-get-chat-users chat-id)))
        (when users
          (telegram-send-message
           chat-id
           (format nil "~{~A~^~%~}"
                   (loop for checkin in (fsq-fetch-checkins)
                      if (member (aget "id" (aget "user" checkin)) users :test #'equal)
                      collect (fsq-format-checkin checkin t))))))
    (error (e) (log:error e))))


(defun process-latest-checkins ()
  (handler-case
      (let ((checkins (make-hash-table))
            (ts (princ-to-string (1+ (or (db-fsq-last-created) -1)))))
        (dolist (checkin (fsq-fetch-checkins ts))
          (let ((id (aget "id" checkin))
                (created-at (aget "createdAt" checkin))
                (user (aget "id" (aget "user" checkin))))
            (unless (db-fsq-has-seen id)
              (dolist (chat-id (db-fsq-get-user-chats user))
                (push (fsq-format-checkin checkin)
                      (gethash chat-id checkins)))
              (db-fsq-add-seen id created-at))))
        (loop for chat-id being the hash-keys in checkins using (hash-value texts)
           do (log:info "Sending checkins" chat-id texts)
             (telegram-send-message chat-id (format nil "~{~A~^~%~}" texts))))
    (error (e) (log:error e))))


;; RSS
(defun handle-cmd-feeds (chat-id message-id args)
  (log:info "handle-cmd-feeds" chat-id message-id args)
  (handler-case
      (telegram-send-message
       chat-id
       (if (null args)
           "URL давай"
           (format nil "~:[Не нашел RSS там~;~:*~{~{~A - ~A~}~^~%~}~]"
                   (find-rss-links (car args))))
       :disable-web-preview 1)
    (error (e)
      (log:error e)
      (telegram-send-message chat-id "Ошибочка вышла"))))

(defun %send-feeds (chat-id feeds)
  (telegram-send-message
   chat-id
   (if (null feeds)
       "Пока ничего не постим"
       (format nil "Постим~%~{~A) ~A: ~A~^~%~}"
               (loop for feed in feeds
                  for index from 1
                  append (list index (feed-title feed) (feed-url feed)))))
   :disable-web-preview 1))

(defun %fetch-new-items (feed)
  (loop for item in (refresh-feed feed #'db-rss-item-exists)
     do (db-rss-add-item item)
     collect item))

(defun %get-feed (url)
  (when url
    (or (db-rss-get-feed-by-url url)
        (alexandria:when-let (feed (build-feed url))
          (log:info "Added feed" feed)
          (db-rss-add-feed feed)
          (%fetch-new-items feed)
          feed))))

(defun handle-cmd-rss (chat-id message-id args)
  (log:info "handle-cmd-rss" chat-id message-id args)
  (handler-case
      (let ((feeds (db-rss-get-chat-feeds chat-id)))
        (if (null args)
            (%send-feeds chat-id feeds)
            (progn
              (dolist (url args)
                (handler-case
                    (let ((idx (parse-integer url)))
                      (when (<= idx (length feeds))
                        (setf feeds (remove (nth (1- idx) feeds) feeds))))
                  (parse-error ()
                    (alexandria:when-let (feed (%get-feed
                                                (or (cadar (find-rss-links url))
                                                    url)))
                      (let ((existing (find (feed-url feed) feeds :key #'feed-url :test #'equal)))
                        (if existing
                            (setf feeds (remove existing feeds))
                            (push feed feeds)))))
                  (error (e) (log:error e))))
              (log:info feeds)
              (db-rss-set-chat-feeds chat-id feeds)
              (%send-feeds chat-id (db-rss-get-chat-feeds chat-id)))))
    (error (e)
      (log:error e)
      (telegram-send-message chat-id "Ошибочка вышла"))))

(defun handle-cmd-last-rss (chat-id message-id args)
  (log:info "handle-cmd-last-rss" chat-id message-id args)
  (handler-case
      (let ((feeds (db-rss-get-chat-feeds chat-id)))
        (if (null args)
            (%send-feeds chat-id feeds)
            (let* ((idx (1- (parse-integer (car args))))
                   (limit (min 20 (if (> (length args) 1) (parse-integer (second args)) 5)))
                   (items (db-rss-last-feed-items (nth idx feeds) limit)))
              (telegram-send-message chat-id
                                     (format nil "~{~A~^~%~%~}"
                                             (mapcar #'format-feed-item items))
                                     :parse-mode "Markdown"
                                     :disable-web-preview 1))))
    (error (e)
      (log:error e)
      (telegram-send-message chat-id "Ошибочка вышла"))))

(defun process-feeds ()
  (handler-case
      (dolist (feed (remove-if-not #'need-fetch-p (db-rss-get-active-feeds)))
        (log:info "Fetching new items" (feed-url feed))
        (dolist (item (%fetch-new-items feed))
          (dolist (chat-id (db-rss-get-feed-chats feed))
            (telegram-send-message chat-id
                                   (format-feed-item item)
                                   :parse-mode "Markdown"
                                   :disable-web-preview 1)))
        (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 %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-picture (attachments)
  (%vk-find-best-photo (find "photo" attachments :key #'(lambda (a) (aget "type" a)) :test #'equal)))

(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-picture (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))))

(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-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 e))))
              (%send-domains chat-id (db-vk-get-chat-domains chat-id)))))
    (error (e)
      (log:error e)
      (telegram-send-message chat-id (format nil "Ошибочка вышла: ~A" e)))))

(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))))
                        name)
                    (setf period (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 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")
(defun save-settings()
  (bordeaux-threads:with-lock-held (*save-settings-lock*)
    (with-open-file (s (merge-pathnames "settings.lisp"
                                        (asdf:component-pathname
                                         (asdf:find-system '#:chatikbot)))
                       :direction :output
                       :if-exists :supersede
                       :if-does-not-exist :create)
      (write '(in-package #:chatikbot) :stream s)
      (write
       `(setf *chat-locations* ',*chat-locations*
              *akb-send-to* ',*akb-send-to*
              *akb-last-id* ,*akb-last-id*)
       :stream s)
      (values))))

(defvar *schedules* '(process-latest-akb
                      process-latest-checkins
                      process-rates
                      process-feeds
                      process-walls) "Enabled schedules")

(defun start ()
  ;; Clear prev threads
  (mapc #'trivial-timers:unschedule-timer (trivial-timers:list-all-timers))
  (let ((old-updates (find "process-updates"
                            (bordeaux-threads:all-threads)
                            :key #'bordeaux-threads:thread-name
                            :test #'equal)))
    (when old-updates
      (bordeaux-threads:destroy-thread old-updates)))
  ;; Load settings file
  (alexandria:when-let (file (probe-file
                              (merge-pathnames "settings.lisp"
                                               (asdf:component-pathname
                                                (asdf:find-system '#:chatikbot)))))
    (load file))
  ;; Start timers
  (dolist (func *schedules*)
    (clon:schedule-function func
                            (clon:make-scheduler
                             (clon:make-typed-cron-schedule :minute '* :hour '*)
                             :allow-now-p t)
                            :name func
                            :thread t))
  ;; Start getUpdates thread
  (bordeaux-threads:make-thread
   (lambda () (loop-with-error-backoff #'process-updates))
   :name "process-updates"))