Browse Source

cron, db settings

Innocenty Enikeew 9 năm trước cách đây
mục cha
commit
5faf93d463
14 tập tin đã thay đổi với 214 bổ sung247 xóa
  1. 3 10
      chatikbot.asd
  2. 44 89
      chatikbot.lisp
  3. 1 7
      config.lisp.example
  4. 15 0
      db.lisp
  5. 0 14
      eliza.lisp
  6. 6 8
      finance.lisp
  7. 4 5
      forecast.lisp
  8. 19 21
      foursquare.lisp
  9. 14 39
      hooks.lisp
  10. 10 11
      nalunch.lisp
  11. 10 12
      rss.lisp
  12. 20 0
      telegram.lisp
  13. 35 0
      utils.lisp
  14. 33 31
      vk.lisp

+ 3 - 10
chatikbot.asd

@@ -21,18 +21,11 @@
                #:yason)
   :serial t
   :components ((:file "package")
-               (:file "utils")
                (:file "hooks")
-               (:file "db")
+               (:file "utils")
                (:file "telegram")
-               (:file "forecast")
-               (:file "vk")
-               (:file "finance")
-               (:file "tumblr")
+               (:file "db")
+               (:file "settings")
                (:file "patmatch")
                (:file "eliza")
-               (:file "foursquare")
-               (:file "rss")
-               (:file "nalunch")
-               (:file "google")
                (:file "chatikbot")))

+ 44 - 89
chatikbot.lisp

@@ -1,5 +1,7 @@
 (in-package #:chatikbot)
 
+(defvar *admins* nil "Admins chat-ids")
+
 ;; Load config file
 (alexandria:when-let (file (probe-file
                             (merge-pathnames "config.lisp"
@@ -9,10 +11,10 @@
 
 ;; Init database
 (db-init)
+;; Load settings
+(load-settings)
 
 (defvar *telegram-last-update* nil "Telegram last update_id")
-(defvar *admins* nil "Admins chat-ids")
-
 
 ;; getUpdates handling
 (defun process-updates ()
@@ -28,25 +30,7 @@
   (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))))
+     do (run-hooks (string-to-event (format nil "update-~A" key)) value)))
 
 (defun send-dont-understand (chat-id &optional text reply-id)
   (let ((resp (eliza text)))
@@ -60,42 +44,34 @@
     (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")
+(add-hook :update-message 'handle-unknown-message t)
+
+;; Schedule
+(defmacro defcron (name (&rest schedule) &body body)
+  (let ((schedule (or schedule '(:minute '* :hour '*))))
+    `(progn
+       (defun ,name ()
+         (handler-case (progn ,@body)
+           (error (e) (log:error e))))
+       (add-hook :starting #'(lambda ()
+                               (clon:schedule-function
+                                ',name (clon:make-scheduler
+                                        (clon:make-typed-cron-schedule
+                                         ,@schedule)
+                                        :allow-now-p t)
+                                :name ',name :thread t)
+                               (values))))))
+
+(defcron process-watchdog ()
+  (close
+   (open (merge-pathnames ".watchdog"
+                          (asdf:component-pathname
+                           (asdf:find-system '#:chatikbot)))
+         :direction :output
+         :if-exists :supersede
+         :if-does-not-exist :create)))
+
+(defsetting *plugins* nil "List of enabled plugins")
 
 (defun start ()
   ;; Clear prev threads
@@ -106,38 +82,17 @@
                             :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)
+
+  ;; Load plugins
+  (dolist (plugin *plugins*)
+    (handler-case
+        (load (merge-pathnames (format nil "~A.lisp" plugin)
+                               (asdf:component-pathname
+                                (asdf:find-system '#:chatikbot))))
+      (error (e) (log:error e))))
+
+  ;; Run 'starting' hooks to set up schedules
+  (run-hooks :starting)
 
   ;; Start getUpdates thread
   (bordeaux-threads:make-thread

+ 1 - 7
config.lisp.example

@@ -3,11 +3,5 @@
 ;; Telegram
 (setf *telegram-token* "123456789:YourTokenHere")
 
-;; Forecast.io
-(setf *forecast-api-key* "<forecast-key>")
-
-;; Foursquare
-(setf *fsq-access-token* "<foursquare-token>")
-
 ;; Admins
-(setf *admins* '(<user-id> <user-id>))
+(setf *admins* '(<chat-id> <chat-id>))

+ 15 - 0
db.lisp

@@ -12,8 +12,23 @@
      (sqlite:execute-non-query ,db "PRAGMA foreign_keys = ON")
      ,@body))
 
+(defun db-execute (sql &rest parameters)
+  (with-db (db)
+    (apply #'sqlite:execute-non-query db sql parameters)))
+
+(defun db-select (sql &rest parameters)
+  (with-db (db)
+    (apply #'sqlite:execute-to-list db sql parameters)))
+
+(defmacro def-db-init (() &body body)
+  `(add-hook :db-init #'(lambda ()
+                          (handler-case (progn ,@body)
+                            (error (e) (log:error e)))
+                          (values))))
+
 (defun db-init ()
   (with-db (db)
+    (run-hooks :db-init)
     ;; Finance
     (sqlite:execute-non-query db "create table if not exists finance (ts, usd, eur, gbp, brent, btc)")
     (sqlite:execute-non-query db "create index if not exists fin_ts_ids on finance (ts)")

+ 0 - 14
eliza.lisp

@@ -28,18 +28,6 @@
      (в жопу себе его засунь) (хуюровень) ,@*fuck-off*)
     (((?* ?a) (?is ?x ,(lambda (i) (and (symbolp i) (search "ХАХА" (symbol-name i))))) (?* ?b))
      (очень смешно) (клоунов тут нашел?) (посмейся мне еще) ,@*fuck-off*)
-    (((?* ?a) (?or сиськи сисяндры титьки буфера boobs tits) (?is ?n numberp))
-     (#'tumblr-random-photo ,*boobs-roll* ?n))
-    (((?* ?a) (?or сиськи сисяндры титьки буфера boobs tits) (?* ?b))
-     (#'tumblr-random-photo ,*boobs-roll*))
-    (((?* ?a) (?or жопа жопы ягодицы зад зады ass asses) (?is ?n numberp))
-     (#'tumblr-random-photo ,*ass-roll* ?n))
-    (((?* ?a) (?or жопа жопы ягодицы зад зады ass asses) (?* ?b))
-     (#'tumblr-random-photo ,*ass-roll*))
-    (((?* ?a) (?or тёлка телка телку тёлку баба бабу сука суку сучка сучку babe bitch) (?* ?b))
-     (#'tumblr-random-photo ,*ass-roll*) (#'tumblr-random-photo ,*boobs-roll*))
-    ((yit)
-     (#'yit-info))
     (((?* x))
      (:text . "И чё?")
      (:text . "Сам-то понял?")
@@ -90,5 +78,3 @@
        (apply (cadar r) (cdr r)))
       ((keywordp (car r)) r)
       (t (print-with-spaces (flatten r))))))
-
-

+ 6 - 8
finance.lisp

@@ -76,14 +76,12 @@
       (adw-charting:save-file "chart.png"))))
 
 ;; Cron
-(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 "~A" e))))
+(defcron process-rates ()
+  (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)))
 
 ;;; Hooks
 (def-message-cmd-handler handler-rates (:rates)

+ 4 - 5
forecast.lisp

@@ -1,6 +1,6 @@
 (in-package #:chatikbot)
 
-(defvar *forecast-api-key* nil "forecast.io APIKEY")
+(defsetting *forecast-api-key* nil "forecast.io APIKEY")
 (defparameter +forecast-api-url+ "https://api.forecast.io/forecast" "forecast.io API endpoint")
 
 (defun forecast (lat lon &key time (currently t) minutely hourly daily alerts)
@@ -73,17 +73,16 @@
 ;;; Hooks
 (defvar *chat-locations* nil "ALIST of chat->location")
 
-(def-message-handler handler-location (message)
+(def-message-handler handle-location (message)
   (let ((chat-id (aget "id" (aget "chat" message)))
         (location (aget "location" message)))
     (when location
       (log:info "handler-location" chat-id location)
-      (push (cons chat-id location) *chat-locations*)
+      (set-setting '*chat-locations* (cons (cons chat-id location) *chat-locations*))
       (bot-send-message chat-id "Взял на карандаш")
-      (save-settings)
       t)))
 
-(def-message-cmd-handler handler-cmd-weather (:weather :hourly :daily)
+(def-message-cmd-handler handle-cmd-weather (:weather :hourly :daily)
   (let* ((location (cdr (assoc chat-id *chat-locations*)))
          (response (if location
                        (forecast-format

+ 19 - 21
foursquare.lisp

@@ -5,7 +5,7 @@
 (defparameter *fsq-api-url* "https://api.foursquare.com/v2/~A"
   "Foursquare API URL")
 
-(defvar *fsq-access-token* nil "Access token for a user under which the process is run")
+(defsetting *fsq-access-token* nil "Access token for a user under which the process is run")
 
 (defun %fsq-api-call (method &optional params)
   (let* ((resp
@@ -60,26 +60,24 @@
                :format '(:year "-" (:month 2) "-" (:day 2) " " (:hour 2) ":" (:min 2)))))))
 
 ;; Cron
-(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 "~A" e))))
+(defcron process-latest-checkins ()
+  (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)))))
 
 ;; Hooks
-(def-message-cmd-handler handler-post-checkins (:postcheckins)
+(def-message-cmd-handler handle-cmd-post-checkins (:postcheckins)
   (let ((users (db-fsq-get-chat-users chat-id))
         (friends (fsq-fetch-friends)))
     (if (null args)
@@ -108,7 +106,7 @@
                       (bot-send-message chat-id (format nil "Теперь палим ~A" username)))))))
           (db-fsq-set-chat-users chat-id users)))))
 
-(def-message-cmd-handler handler-friends (:friends)
+(def-message-cmd-handler handle-cmd-friends (:friends)
   (let ((users (db-fsq-get-chat-users chat-id))
         (friends (fsq-fetch-friends)))
     (bot-send-message chat-id
@@ -121,7 +119,7 @@
                                   (fsq-user-name user)))))))
 
 
-(def-message-cmd-handler handle-checkins (:checkins)
+(def-message-cmd-handler handle-cmd-checkins (:checkins)
   (let ((users (db-fsq-get-chat-users chat-id)))
     (when users
       (bot-send-message chat-id

+ 14 - 39
hooks.lisp

@@ -1,51 +1,26 @@
 (in-package #:chatikbot)
 
-(defvar *update-hooks* (make-hash-table) "Update hooks storage")
+(defvar *hooks* (make-hash-table) "Hooks storage")
 
-(defun run-update-hooks (hook-name update)
-  (let ((hooks (gethash hook-name *update-hooks*)))
+(defun run-hooks (event &rest arguments)
+  (let ((hooks (gethash event *hooks*)))
     (labels ((try-handle (func)
-               (funcall func update)))
+               (apply func arguments)))
       (unless (some #'try-handle hooks)
-        (log:info "unhandled" update)))))
+        (log:info "unhandled" event arguments)))))
 
-(defun add-update-hook (hook-name handler &optional append)
-  (let ((existing (gethash hook-name *update-hooks*))
-        (func (if (functionp handler) handler (symbol-function handler))))
+(defun add-hook (event hook &optional append)
+  (let ((existing (gethash event *hooks*))
+        (func (if (functionp hook) hook (symbol-function hook))))
     (unless (member func existing)
-      (setf (gethash hook-name *update-hooks*)
+      (setf (gethash event *hooks*)
             (if append (append existing (list func))
                 (cons func existing))))))
 
-(defun delete-update-hook (hook-name handler)
-  (setf (gethash hook-name *update-hooks*)
-        (remove (if (functionp handler) handler (symbol-function handler))
-                (gethash hook-name *update-hooks*))))
+(defun remove-hook (event hook)
+  (setf (gethash event *hooks*)
+        (remove (if (functionp hook) hook (symbol-function hook))
+                (gethash event *hooks*))))
 
-(defun key-to-hook-name (key)
+(defun string-to-event (key)
   (intern (string-upcase (substitute #\- #\_ key)) :keyword))
-
-(defmacro def-message-handler (name (message) &body body)
-  `(progn
-     (defun ,name (,message)
-       (let ((message-id (aget "message_id" ,message))
-             (from-id (aget "id" (aget "from" ,message)))
-             (chat-id (aget "id" (aget "chat" ,message)))
-             (text (aget "text" ,message)))
-         (declare (ignorable message-id from-id chat-id text))
-         (handler-case (progn ,@body)
-           (error (e)
-             (log:error "~A" e)
-             (bot-send-message chat-id
-                               (format nil "Ошибочка вышла~@[: ~A~]"
-                                       (when (member chat-id *admins*) e)))))))
-     (add-update-hook :message ',name)))
-
-(defmacro def-message-cmd-handler (name (&rest commands) &body body)
-  `(def-message-handler ,name (message)
-     (when (and text (equal #\/ (char text 0)))
-       (multiple-value-bind (cmd args) (parse-cmd text)
-         (when (member cmd (list ,@commands))
-           (log:info cmd message-id chat-id from-id args)
-           ,@body
-           t)))))

+ 10 - 11
nalunch.lisp

@@ -1,7 +1,8 @@
 (in-package #:chatikbot)
 
-(defvar *nalunch-username* nil "Username")
-(defvar *nalunch-password* nil "Password")
+(defsetting *nalunch-username* nil "Username")
+(defsetting *nalunch-password* nil "Password")
+
 (defvar *nalunch-cookie-jar* (make-instance 'drakma:cookie-jar) "Cookie storage")
 (defvar *nalunch-calend* nil "Working calendar exceptions")
 
@@ -90,17 +91,15 @@
 
 ;; Cron
 (defvar *nalunch-last-result* nil "Last check result")
-(defun process-nalunch ()
-  (handler-case
-      (let ((result (nalunch-recent)))
-        (unless (equal (aget :balance *nalunch-last-result*)
-                       (aget :balance result))
-          (send-response (car *admins*) (nalunch-format result t))
-          (setf *nalunch-last-result* result)))
-    (error (e) (log:error "~A" e))))
+(defcron process-nalunch (:minute '(member 0 15 30 45))
+  (let ((result (nalunch-recent)))
+    (unless (equal (aget :balance *nalunch-last-result*)
+                   (aget :balance result))
+      (send-response (car *admins*) (nalunch-format result t))
+      (setf *nalunch-last-result* result))))
 
 ;; Hooks
-(def-message-cmd-handler handler-cmd-nalunch (:nalunch)
+(def-message-cmd-handler handle-cmd-nalunch (:nalunch)
   (if (member chat-id *admins*)
       (send-response chat-id (nalunch-format
                               (or *nalunch-last-result*

+ 10 - 12
rss.lisp

@@ -130,18 +130,16 @@
     (local-time:timestamp-to-unix ts)))
 
 ;; Cron
-(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 "~A" e))))
+(defcron process-feeds ()
+  (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
 
 ;; Hooks
 (def-message-cmd-handler handler-cmd-feeds (:feeds)

+ 20 - 0
telegram.lisp

@@ -125,3 +125,23 @@
 
 (defun telegram-get-file (file-id)
   (%telegram-api-call "getFile" `(("file_id" . ,file-id))))
+
+;; Simplified interface
+;;
+(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))))

+ 35 - 0
utils.lisp

@@ -1,5 +1,40 @@
 (in-package #:chatikbot)
 
+(defmacro def-message-handler (name (message) &body body)
+  `(progn
+     (defun ,name (,message)
+       (let ((message-id (aget "message_id" ,message))
+             (from-id (aget "id" (aget "from" ,message)))
+             (chat-id (aget "id" (aget "chat" ,message)))
+             (text (aget "text" ,message)))
+         (declare (ignorable message-id from-id chat-id text))
+         (handler-case (progn ,@body)
+           (error (e)
+             (log:error "~A" e)
+             (bot-send-message chat-id
+                               (format nil "Ошибочка вышла~@[: ~A~]"
+                                       (when (member chat-id *admins*) e)))))))
+     (add-hook :update-message ',name)))
+
+(defmacro def-message-cmd-handler (name (&rest commands) &body body)
+  `(def-message-handler ,name (message)
+     (when (and text (equal #\/ (char text 0)))
+       (multiple-value-bind (cmd args) (parse-cmd text)
+         (when (member cmd (list ,@commands))
+           (log:info cmd message-id chat-id from-id args)
+           ,@body
+           t)))))
+
+(defmacro def-message-admin-cmd-handler (name (&rest commands) &body body)
+  `(def-message-handler ,name (message)
+     (when (and (member chat-id *admins*)
+                text (equal #\/ (char text 0)))
+       (multiple-value-bind (cmd args) (parse-cmd text)
+         (when (member cmd (list ,@commands))
+           (log:info cmd message-id chat-id from-id args)
+           ,@body
+           t)))))
+
 (defvar *backoff-start* 1 "Initial back-off")
 (defvar *backoff-max* 64 "Maximum back-off delay")
 

+ 33 - 31
vk.lisp

@@ -46,39 +46,39 @@
       (vk-get-group-name id)))
 
 ;; Cron
-(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 "~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
-    (error (e) (log:error "~A" e))))
+(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 (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))
@@ -90,7 +90,9 @@
   (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)
+                                             :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))))