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


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

(defun process-updates ()
  (handler-case
      (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)))
    (error (e)
      (log:error e))))

(defvar *responses*
  '((:text . "И чё?")
    (:text . "Сам-то понял?")
    (:text . "Ну хуй знает")
    (:text . "Бля...")
    (:text . "В душе не ебу")
    (:text . "Мне похуй")
    (:text . "Eбаный ты нахуй")
    (:text . "Отъебись")
    (:sticker . "BQADAgADFAADOoERAAGoLKS_Vgs6GgI") ;; ЭЭ епта Чо
    (:sticker . "BQADAgADGQADOoERAAFDXJisD4fClgI") ;; Ну чё ты несёшь
    (:sticker . "BQADAgADFwADOoERAAHCw-fBiFjACgI") ;; А у меня собака, я не могу
    (:sticker . "BQADAgADEgADOoERAAFtU3uF9HvtQgI") ;; Бухнём?
    (:sticker . "BQADBAADQAEAAnscSQABqWydSKTnASoC")) ;; Trollface
  "Unknown command respond strings")

(defun random-choice (messages)
  (nth (random (length messages)) messages))

(defun send-response (chat-id response &optional reply-id)
  (case (car response)
    (:text (telegram-send-message chat-id (cdr response) :reply-to reply-id))
    (:sticker (telegram-send-sticker chat-id (cdr response) :reply-to reply-id))))

(defun send-dont-understand (chat-id &optional text reply-id)
  (if (and text (zerop (random 5)))
      ;; Reply to "пидор" with "сам пидор" in 20%
      (telegram-send-message chat-id
                             (format nil "Сам ~A"
                                     (replace-all
                                      (if (equal (char text 0) #\/)
                                          (subseq text 1)
                                          text)
                                      "@chatikbot" ""))
                             :reply-to reply-id)
      ;; Reply with predefined responses
      (send-response chat-id (random-choice *responses*))))

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

(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))
          (let ((cmd (intern (string-upcase
                              (subseq text 1 (position #\Space text)))
                             "KEYWORD"))
                (args (when (position #\Space text)
                        (split-sequence:split-sequence
                         #\Space (subseq text (1+ (position #\Space 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))
              (:help (handle-cmd-help chat-id id args))
              (otherwise (handle-admin-cmd chat-id text cmd args))))
          (send-dont-understand chat-id text)))
    (when location
      (push (cons chat-id location) *chat-locations*)
      (telegram-send-message chat-id "Взял на карандаш"))
    (when sticker
      ;; Save incoming stickers in 20% of the cases if it's not already there
      (if (and (or (find chat-id *admins*)
                   (zerop (random 5)))
               (not (find sticker *responses* :key #'cdr :test #'equal)))
          (progn
            (push (cons :sticker sticker) *responses*)
            (telegram-send-message chat-id "Припомним"))
          (send-dont-understand chat-id)))))

(defun %admin-send-responses (chat-id)
  (telegram-send-message
   chat-id
   (format nil "~{~A~^~%~}"
           (loop for (type . text) in *responses*
              for i = 1 then (1+ i)
              collect (format nil "~D. ~A [~A]" i text type)))))

(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
        (:addresponse
         (push (cons :text (format nil "~{~A~^ ~}" args)) *responses*)
         (%admin-send-responses chat-id))
        (:showresponses
         (%admin-send-responses chat-id))
        (:delresponse
         (setf *responses* (delete (nth (1- (parse-integer (car args))) *responses*) *responses*))
         (%admin-send-responses chat-id))
        (:sendresponse (send-response chat-id (nth (1- (parse-integer (car args))) *responses*)))
        (:eval (telegram-send-message chat-id (rep (format nil "~{~A~^ ~}" args))))
        (otherwise (send-dont-understand chat-id text)))
      (send-dont-understand chat-id text)))

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

(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 ()
  (log:info "Getting latest AKBs")
  (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))))
    (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)
  (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))))))


(defvar *help-responses*
  (list "Сам себе помоги, нахуй!" "Вот заняться мне больше нечем" "Нахуй пошел!"
        "Хэлп, ай нид самбади, хелп нот джаст энибади" "Отъебись"))

(defun handle-cmd-help (chat-id message-id args)
  (log:info "handle-cmd-help" chat-id message-id args)
  (telegram-send-message chat-id (random-choice *help-responses*)))

(defun handle-cmd-rates (chat-id message-id args)
  (log:info "handle-cmd-rates" chat-id message-id args)
  (let (rates (get-rates))
    (telegram-send-message chat-id
			   (format nil "Зеленый ~A, гейро ~A" (cdar rates) (cdadr rates)))))

(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
         (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)))
         "Так а ты чьих будешь?"))))

(defun start ()
  (mapc #'sb-ext: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)))
  (clon:schedule-function
   (lambda () (process-latest-akb))
   (clon:make-scheduler
    (clon:make-typed-cron-schedule :minute '* :hour '*)
    :allow-now-p t)
   :thread t)
  (bordeaux-threads:make-thread
   (lambda ()
     (loop
        do (process-updates)))
   :name "process-updates"))