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


;; getUpdates handling
(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-update update)))

(defun handle-update (update)
  (log:info update)
  (loop for (key . value) in update
     unless (equal "update_id" key)
     do (run-update-hooks (key-to-hook-name key) value)))
;;
(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 bot-send-message (chat-id text &key parse-mode disable-web-preview reply-to reply-markup)
  (handler-case (telegram-send-message chat-id text :parse-mode parse-mode
                                       :disable-web-preview disable-web-preview
                                       :reply-to reply-to
                                       :reply-markup reply-markup)
    (error (e)
      (log:error e))))

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

(defun handle-unknown-message (message)
  (let ((chat-id (aget "id" (aget "chat" message)))
        (text (aget "text" message)))
    (log:info "handle-unknown-message" message)
    (send-dont-understand chat-id (preprocess-input text))
    t))
(add-update-hook :message 'handle-unknown-message t)

(defun process-watchdog ()
  (ignore-errors
    (close
     (open (merge-pathnames ".watchdog"
                            (asdf:component-pathname
                             (asdf:find-system '#:chatikbot)))
           :direction :output
           :if-exists :supersede
           :if-does-not-exist :create))))

(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
                      process-watchdog) "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))
  ;; YIT
  (let ((last-yit-info))
    (clon:schedule-function
     #'(lambda() (let ((info (yit-info)))
                   (when (not (equal info last-yit-info))
                     (send-response (car *admins*) info)
                     (setf last-yit-info info))))
     (clon:make-scheduler
      (clon:make-typed-cron-schedule :minute 0 :hour '*)
      :allow-now-p t)
     :name "YIT" :thread t))

  ;; Nalunch
  (clon:schedule-function
   #'process-nalunch (clon:make-scheduler (clon:make-typed-cron-schedule
                                           :minute '(member 0 15 30 45))
                                          :allow-now-p t)
   :name "Nalunch" :thread t)

  ;; Start getUpdates thread
  (bordeaux-threads:make-thread
   (lambda () (loop-with-error-backoff #'process-updates))
   :name "process-updates")

  ;; Notify admins
  (dolist (admin *admins*)
    (telegram-send-message admin (format nil "chatikbot started at ~A" (format-ts (local-time:now))))))