chatikbot.lisp 29 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691
  1. (in-package #:chatikbot)
  2. ;; Load config file
  3. (alexandria:when-let (file (probe-file
  4. (merge-pathnames "config.lisp"
  5. (asdf:component-pathname
  6. (asdf:find-system '#:chatikbot)))))
  7. (load file))
  8. ;; Init database
  9. (db-init)
  10. (defvar *telegram-last-update* nil "Telegram last update_id")
  11. (defvar *admins* nil "Admins chat-ids")
  12. (defun process-updates ()
  13. (loop for update in (telegram-get-updates :offset (and *telegram-last-update*
  14. (1+ *telegram-last-update*))
  15. :timeout 300)
  16. do (setf *telegram-last-update*
  17. (max (or *telegram-last-update* 0)
  18. (aget "update_id" update)))
  19. do (handle-message (aget "message" update))))
  20. (defun send-response (chat-id response &optional reply-id)
  21. (if (consp response)
  22. (if (keywordp (car response))
  23. (case (car response)
  24. (:text (telegram-send-message chat-id (cdr response) :reply-to reply-id))
  25. (:voice (telegram-send-voice chat-id (cdr response) :reply-to reply-id))
  26. (:sticker (telegram-send-sticker chat-id (cdr response) :reply-to reply-id)))
  27. (mapc #'(lambda (r) (send-response chat-id r reply-id)) response))
  28. (telegram-send-message chat-id response :reply-to reply-id)))
  29. (defun send-dont-understand (chat-id &optional text reply-id)
  30. (let ((resp (eliza text)))
  31. (log:info text resp)
  32. (when resp
  33. (send-response chat-id resp reply-id))))
  34. (defvar *chat-locations* nil "ALIST of chat->location")
  35. (defun preprocess-input (text)
  36. (when text
  37. (let ((first-word (subseq text 0 (position #\Space text))))
  38. (if (equal first-word "@chatikbot")
  39. (preprocess-input (subseq text 11))
  40. (replace-all text "@chatikbot" "ты")))))
  41. (defun parse-cmd (text)
  42. (let* ((args (split-sequence:split-sequence #\Space (subseq text 1) :remove-empty-subseqs t))
  43. (cmd (subseq (car args) 0 (position #\@ (car args)))))
  44. (values (intern (string-upcase cmd) "KEYWORD") (rest args))))
  45. (defun handle-message (message)
  46. (let ((id (aget "message_id" message))
  47. (from-id (aget "id" (aget "from" message)))
  48. (chat-id (aget "id" (aget "chat" message)))
  49. (text (aget "text" message))
  50. (location (aget "location" message))
  51. (sticker (aget "file_id" (aget "sticker" message))))
  52. (log:info "handle-message" message)
  53. (when text
  54. (if (equal #\/ (char text 0))
  55. (multiple-value-bind (cmd args) (parse-cmd text)
  56. (case cmd
  57. (:postakb (handle-cmd-post-akb chat-id id args))
  58. (:akb (handle-cmd-akb chat-id id args))
  59. (:weather (handle-cmd-weather chat-id id args))
  60. (:hourly (handle-cmd-weather chat-id id '("hourly")))
  61. (:daily (handle-cmd-weather chat-id id '("daily")))
  62. (:rates (handle-cmd-rates chat-id id args))
  63. (:charts (handle-cmd-charts chat-id id args))
  64. (:postcheckins (handle-cmd-post-checkins chat-id id args))
  65. (:friends (handle-cmd-fsq-friends chat-id id args))
  66. (:checkins (handle-cmd-checkins chat-id id args))
  67. (:rss (handle-cmd-rss chat-id id args))
  68. (:feeds (handle-cmd-feeds chat-id id args))
  69. (:lastrss (handle-cmd-last-rss chat-id id args))
  70. (:wall (handle-cmd-wall chat-id id args))
  71. (:nalunch (handle-cmd-nalunch chat-id id args))
  72. (:g (handle-cmd-google chat-id id args))
  73. (:г (handle-cmd-google chat-id id args))
  74. (otherwise (handle-admin-cmd from-id chat-id text cmd args))))
  75. (send-dont-understand chat-id (preprocess-input text))))
  76. (when location
  77. (push (cons chat-id location) *chat-locations*)
  78. (telegram-send-message chat-id "Взял на карандаш")
  79. (save-settings))
  80. (when sticker
  81. (send-dont-understand chat-id))))
  82. (defmacro handling-errors (&body body)
  83. `(handler-case (progn ,@body)
  84. (simple-condition (err)
  85. (format *error-output* "~&~A: ~%" (class-name (class-of err)))
  86. (apply (function format) *error-output*
  87. (simple-condition-format-control err)
  88. (simple-condition-format-arguments err))
  89. (format *error-output* "~&"))
  90. (condition (err)
  91. (format *error-output* "~&~A: ~% ~S~%"
  92. (class-name (class-of err)) err))))
  93. (defun rep (input)
  94. (when input
  95. (with-output-to-string (*standard-output*)
  96. (let ((*package* (find-package 'chatikbot))
  97. (*error-output* *standard-output*))
  98. (handling-errors
  99. (format t "~{~S~^ ;~% ~}~%"
  100. (multiple-value-list (eval (read-from-string input)))))))))
  101. (defun handle-admin-cmd (from-id chat-id text cmd args)
  102. (if (find from-id *admins*)
  103. (case cmd
  104. (:eval (telegram-send-message chat-id (rep (format nil "~{~A~^ ~}" args))))
  105. (otherwise (send-dont-understand chat-id (preprocess-input (subseq text 1)))))
  106. (send-dont-understand chat-id (preprocess-input (subseq text 1)))))
  107. ;; AKB
  108. (defparameter +akb-vk-domain+ "baneks" "VK.com username of 'B-category anekdotes'")
  109. (defvar *akb-send-to* nil "List of chat-id's to send AKBs to")
  110. (defun handle-cmd-post-akb (chat-id message-id args)
  111. (log:info "handle-cmd-post-akb" chat-id message-id args)
  112. (let ((message "Хуярим аники"))
  113. (if (member chat-id *akb-send-to*)
  114. (setf message "Не хуярим больше аники"
  115. *akb-send-to* (set-difference *akb-send-to*
  116. (list chat-id)))
  117. (setf *akb-send-to* (cons chat-id *akb-send-to*)))
  118. (telegram-send-message chat-id message)
  119. (save-settings)))
  120. (defvar *akb-max-count* 5 "Max number of tweets to return per run")
  121. (defvar *akb-last-id* 0 "id of last AKB tweet")
  122. (defun format-akb (post)
  123. (let* ((id (aget "id" post))
  124. (url (format nil "https://vk.com/~A?w=wall~A_~A"
  125. +akb-vk-domain+ (aget "from_id" post) id)))
  126. (format nil "~A~%~A" (aget "text" post) url)))
  127. (defun process-latest-akb ()
  128. (handler-case
  129. (dolist (post (reverse (aget "items" (vk-wall-get :domain +akb-vk-domain+
  130. :count *akb-max-count*))))
  131. (let ((id (aget "id" post)))
  132. (when (> id *akb-last-id*)
  133. (send-akb (format-akb post))
  134. (setf *akb-last-id* id)
  135. (save-settings))))
  136. (error (e) (log:error "~A" e))))
  137. (defun send-akb (text)
  138. (log:info "send-akb: ~A" text)
  139. (dolist (chat-id *akb-send-to*)
  140. (handler-case
  141. (telegram-send-message chat-id text
  142. :disable-web-preview 1)
  143. (error (e) (log:error "~A" e)))))
  144. (defun handle-cmd-akb (chat-id message-id args)
  145. (log:info "handle-cmd-akb" chat-id message-id args)
  146. (handler-case
  147. (progn
  148. (let ((total-aneks
  149. (aget "count" (vk-wall-get :domain +akb-vk-domain+ :count 1 :offset 10000000))))
  150. (dolist (post (aget "items" (vk-wall-get :domain +akb-vk-domain+
  151. :count (or (ignore-errors (parse-integer (car args))) 1)
  152. :offset (random total-aneks))))
  153. (handler-case
  154. (telegram-send-message chat-id
  155. (format-akb post)
  156. :disable-web-preview 1)
  157. (error (e) (log:error e))))))
  158. (error (e)
  159. (log:error "~A" e)
  160. (telegram-send-message chat-id "Ошибочка вышла"))))
  161. ;; Finance
  162. (defun process-rates ()
  163. (handler-case
  164. (let ((ts (local-time:timestamp-to-unix (local-time:now)))
  165. (rates (get-rates))
  166. (brent (get-brent))
  167. (btc (get-btc-e)))
  168. (db-add-finance ts (aget "USD/RUB" rates) (aget "EUR/RUB" rates) (aget "GBP/RUB" rates) brent btc))
  169. (error (e) (log:error "~A" e))))
  170. (defun handle-cmd-rates (chat-id message-id args)
  171. (log:info "handle-cmd-rates" chat-id message-id args)
  172. (multiple-value-bind (ts usd eur gbp brent btc) (db-get-last-finance)
  173. (telegram-send-message chat-id
  174. (format nil "Зеленый *~,2F*, гейро *~,2F*, британец *~,2F*, чёрная *~,2F*, btc *~,2F* @ _~A_"
  175. usd eur gbp brent btc
  176. (format-ts (local-time:unix-to-timestamp ts)))
  177. :parse-mode "Markdown")))
  178. (defparameter +chart-ranges+ (list (cons "day" (* 24 60))
  179. (cons "week" (* 7 24 60))
  180. (cons "month" (* 30 24 60))
  181. (cons "quarter" (* 91 24 60))
  182. (cons "year" (* 365 24 60))))
  183. (defun handle-cmd-charts (chat-id message-id args)
  184. (log:info "handle-cmd-charts" chat-id message-id args)
  185. (telegram-send-chat-action chat-id "upload_photo")
  186. (handler-case
  187. (let* ((args (mapcar 'string-downcase args))
  188. (all-fields (mapcar #'car +db-finance-map+))
  189. (fields (or (intersection args all-fields :test 'equal) all-fields))
  190. (day-range (some #'(lambda (a) (aget a +chart-ranges+)) args))
  191. (number (some #'(lambda (a) (parse-integer a :junk-allowed t)) args))
  192. (avg (* 60 (cond
  193. (day-range (round day-range *chart-points*))
  194. (number)
  195. (:otherwise 1))))
  196. (after-ts (local-time:timestamp- (local-time:now)
  197. (* avg *chart-points*) :sec))
  198. (rates (multiple-value-list (db-get-last-finance)))
  199. (chart (apply #'make-chart (multiple-value-list
  200. (db-get-series after-ts fields avg)))))
  201. (telegram-send-photo chat-id chart
  202. :caption
  203. (format nil "Зеленый ~,2F, гейро ~,2F, британец ~,2F, чёрная ~,2F, btc ~,2F @ ~A"
  204. (elt rates 1) (elt rates 2) (elt rates 3) (elt rates 4) (elt rates 5)
  205. (format-ts (local-time:unix-to-timestamp (elt rates 0))))))
  206. (error (e)
  207. (log:error "~A" e)
  208. (telegram-send-message chat-id "Хуйня какая-то"))))
  209. ;; Weather
  210. (defun handle-cmd-weather (chat-id message-id args)
  211. (log:info "handle-cmd-weather" chat-id message-id args)
  212. (let ((location (cdr (assoc chat-id *chat-locations*))))
  213. (telegram-send-message
  214. chat-id
  215. (if location
  216. (handler-case
  217. (forecast-format (forecast
  218. (aget "latitude" location)
  219. (aget "longitude" location)
  220. :hourly (find "hourly" args :key #'string-downcase :test #'equal)
  221. :daily (find "daily" args :key #'string-downcase :test #'equal)))
  222. (error (e)
  223. (log:error "~A" e)
  224. "Ошибочка вышла"))
  225. "Так а ты чьих будешь?"))))
  226. ;; Foursquare
  227. (defun fsq-user-name (user)
  228. (when user
  229. (format nil "~@[~A~]~@[ ~A~]"
  230. (aget "firstName" user)
  231. (aget "lastName" user))))
  232. (defun handle-cmd-post-checkins (chat-id message-id args)
  233. (log:info "handle-cmd-post-checkins" chat-id message-id args)
  234. (handler-case
  235. (let ((users (db-fsq-get-chat-users chat-id))
  236. (friends (fsq-fetch-friends)))
  237. (if (null args)
  238. (telegram-send-message chat-id
  239. (if (null users)
  240. "Пока никого не палим"
  241. (format nil "Палим ~{~A~^, ~}"
  242. (loop for user in friends
  243. when (member (aget "id" user)
  244. users :test #'equal)
  245. collect (fsq-user-name user)))))
  246. (progn
  247. (dolist (user args)
  248. (let ((username (fsq-user-name
  249. (find user friends
  250. :test #'equal
  251. :key #'(lambda (f) (aget "id" f))))))
  252. (when username
  253. (if (member user users :test #'equal)
  254. (progn
  255. (setf users (remove user users :test #'equal))
  256. (telegram-send-message chat-id
  257. (format nil "Больше не палим ~A" username)))
  258. (progn
  259. (push user users)
  260. (telegram-send-message chat-id (format nil "Теперь палим ~A" username)))))))
  261. (db-fsq-set-chat-users chat-id users))))
  262. (error (e)
  263. (log:error "~A" e)
  264. (telegram-send-message chat-id "Ошибочка вышла"))))
  265. (defun handle-cmd-fsq-friends (chat-id message-id args)
  266. (log:info "handle-cmd-fsq-friends" chat-id message-id args)
  267. (handler-case
  268. (let ((users (db-fsq-get-chat-users chat-id))
  269. (friends (fsq-fetch-friends)))
  270. (telegram-send-message
  271. chat-id
  272. (format
  273. nil "~{~A: ~:[~;📍 ~]~A~^~%~}"
  274. (loop for user in friends
  275. append (list
  276. (aget "id" user)
  277. (member (aget "id" user) users :test #'equal)
  278. (fsq-user-name user))))))
  279. (error (e) (log:error "~A" e))))
  280. (defun handle-cmd-checkins (chat-id message-id args)
  281. (log:info "handle-cmd-checkins" chat-id message-id args)
  282. (handler-case
  283. (let ((users (db-fsq-get-chat-users chat-id)))
  284. (when users
  285. (telegram-send-message
  286. chat-id
  287. (format nil "~{~A~^~%~}"
  288. (loop for checkin in (fsq-fetch-checkins)
  289. if (member (aget "id" (aget "user" checkin)) users :test #'equal)
  290. collect (fsq-format-checkin checkin t))))))
  291. (error (e) (log:error "~A" e))))
  292. (defun process-latest-checkins ()
  293. (handler-case
  294. (let ((checkins (make-hash-table))
  295. (ts (princ-to-string (1+ (or (db-fsq-last-created) -1)))))
  296. (dolist (checkin (fsq-fetch-checkins ts))
  297. (let ((id (aget "id" checkin))
  298. (created-at (aget "createdAt" checkin))
  299. (user (aget "id" (aget "user" checkin))))
  300. (unless (db-fsq-has-seen id)
  301. (dolist (chat-id (db-fsq-get-user-chats user))
  302. (push (fsq-format-checkin checkin)
  303. (gethash chat-id checkins)))
  304. (db-fsq-add-seen id created-at))))
  305. (loop for chat-id being the hash-keys in checkins using (hash-value texts)
  306. do (log:info "Sending checkins" chat-id texts)
  307. (telegram-send-message chat-id (format nil "~{~A~^~%~}" texts))))
  308. (error (e) (log:error "~A" e))))
  309. ;; RSS
  310. (defun handle-cmd-feeds (chat-id message-id args)
  311. (log:info "handle-cmd-feeds" chat-id message-id args)
  312. (handler-case
  313. (telegram-send-message
  314. chat-id
  315. (if (null args)
  316. "URL давай"
  317. (format nil "~:[Не нашел RSS там~;~:*~{~{~A - ~A~}~^~%~}~]"
  318. (find-rss-links (car args))))
  319. :disable-web-preview 1)
  320. (condition (e)
  321. (log:error "~A" e)
  322. (telegram-send-message chat-id "Ошибочка вышла"))))
  323. (defun %send-feeds (chat-id feeds)
  324. (telegram-send-message
  325. chat-id
  326. (if (null feeds)
  327. "Пока ничего не постим"
  328. (format nil "Постим~%~{~A) ~A: ~A~^~%~}"
  329. (loop for feed in feeds
  330. for index from 1
  331. append (list index (feed-title feed) (feed-url feed)))))
  332. :disable-web-preview 1))
  333. (defun %fetch-new-items (feed)
  334. (loop for item in (refresh-feed feed #'db-rss-item-exists)
  335. do (db-rss-add-item item)
  336. collect item))
  337. (defun %get-feed (url)
  338. (when url
  339. (or (db-rss-get-feed-by-url url)
  340. (alexandria:when-let (feed (build-feed url))
  341. (log:info "Added feed" feed)
  342. (db-rss-add-feed feed)
  343. (%fetch-new-items feed)
  344. feed))))
  345. (defun handle-cmd-rss (chat-id message-id args)
  346. (log:info "handle-cmd-rss" chat-id message-id args)
  347. (handler-case
  348. (let ((feeds (db-rss-get-chat-feeds chat-id)))
  349. (if (null args)
  350. (%send-feeds chat-id feeds)
  351. (progn
  352. (dolist (url args)
  353. (handler-case
  354. (let ((idx (parse-integer url)))
  355. (when (<= idx (length feeds))
  356. (setf feeds (remove (nth (1- idx) feeds) feeds))))
  357. (parse-error ()
  358. (alexandria:when-let (feed (%get-feed
  359. (or (cadar (find-rss-links url))
  360. url)))
  361. (let ((existing (find (feed-url feed) feeds :key #'feed-url :test #'equal)))
  362. (if existing
  363. (setf feeds (remove existing feeds))
  364. (push feed feeds)))))
  365. (error (e) (log:error "~A" e))))
  366. (db-rss-set-chat-feeds chat-id feeds)
  367. (%send-feeds chat-id (db-rss-get-chat-feeds chat-id)))))
  368. (condition (e)
  369. (log:error "~A" e)
  370. (telegram-send-message chat-id (format nil "Ошибочка вышла: ~A" e)))))
  371. (defun handle-cmd-last-rss (chat-id message-id args)
  372. (log:info "handle-cmd-last-rss" chat-id message-id args)
  373. (handler-case
  374. (let ((feeds (db-rss-get-chat-feeds chat-id)))
  375. (if (null args)
  376. (%send-feeds chat-id feeds)
  377. (let* ((idx (1- (parse-integer (car args))))
  378. (limit (min 20 (if (> (length args) 1) (parse-integer (second args)) 5)))
  379. (items (db-rss-last-feed-items (nth idx feeds) limit)))
  380. (telegram-send-message chat-id
  381. (format nil "~{~A~^~%~%~}"
  382. (mapcar #'format-feed-item items))
  383. :parse-mode "Markdown"
  384. :disable-web-preview 1))))
  385. (error (e)
  386. (log:error "~A" e)
  387. (telegram-send-message chat-id "Ошибочка вышла"))))
  388. (defun process-feeds ()
  389. (handler-case
  390. (dolist (feed (remove-if-not #'need-fetch-p (db-rss-get-active-feeds)))
  391. (log:info "Fetching new items" (feed-url feed))
  392. (dolist (item (%fetch-new-items feed))
  393. (dolist (chat-id (db-rss-get-feed-chats feed))
  394. (telegram-send-message chat-id
  395. (format-feed-item item)
  396. :parse-mode "Markdown"
  397. :disable-web-preview 1)))
  398. (db-rss-update-feed feed)) ;; Update next fetch and period
  399. (error (e) (log:error "~A" e))))
  400. ;; VK walls
  401. (defun %send-domains (chat-id domains)
  402. (telegram-send-message
  403. chat-id
  404. (if (null domains)
  405. "Пока ничего не постим"
  406. (format nil "Постим~%~{~A) https://vk.com/~A~^~%~}"
  407. (loop for d in domains for i from 1 append (list i d))))
  408. :disable-web-preview 1))
  409. (defun %find-vk-domain (url)
  410. (let ((path (puri:uri-path (puri:parse-uri url))))
  411. (if (equal #\/ (elt path 0))
  412. (subseq path 1)
  413. path)))
  414. (defun %ensure-domain (domain)
  415. (let* ((res (vk-wall-get :domain domain :count 1))
  416. (last-id (aget "id" (first (aget "items" res)))))
  417. (db-vk-ensure-domain domain last-id)
  418. domain))
  419. (defun %vk-find-best-photo (attach)
  420. (when attach
  421. (let* ((photo (aget "photo" attach))
  422. (sizes (loop for (k . v) in photo
  423. when (equal "photo_" (subseq k 0 (min 6 (length k))))
  424. collect (cons (parse-integer (subseq k 6)) v))))
  425. (cdr (assoc (apply #'max (mapcar #'car sizes)) sizes)))))
  426. (defun %vk-find-video (attach)
  427. (when attach
  428. (let ((video (aget "video" attach)))
  429. (format nil "https://vk.com/video~A_~A"
  430. (aget "owner_id" video)
  431. (aget "id" video)))))
  432. (defun %vk-find-preview (attachments)
  433. (labels ((find-type (type)
  434. (find type attachments :key #'(lambda (a) (aget "type" a)) :test #'equal)))
  435. (or
  436. (%vk-find-best-photo (find-type "photo"))
  437. (%vk-find-video (find-type "video")))))
  438. (defparameter +vk-link-scanner+ (cl-ppcre:create-scanner "\\[((id|club)\\d+)\\|([^\\]]*?)\\]") "vk linking regex")
  439. (defun %vk-post-text (post)
  440. (let* ((history (aget "copy_history" post))
  441. (reposts (loop for p in history
  442. collect (let* ((owner (aget "owner_id" p))
  443. (type (if (> owner 0) "id" "club"))
  444. (id (abs owner)))
  445. (format nil "[~A](https://vk.com/~A~A)"
  446. (vk-get-name owner) type id)))))
  447. (when history
  448. (setf post (car (last history))))
  449. (values
  450. (cl-ppcre:regex-replace-all +vk-link-scanner+
  451. (aget "text" post)
  452. "[\\3](https://vk.com/\\1)")
  453. (%vk-find-preview (aget "attachments" post))
  454. reposts)))
  455. (defun %format-wall-post (domain name post)
  456. (multiple-value-bind (text preview reposts) (%vk-post-text post)
  457. (values
  458. (format nil "~@[[✅](~A) ~][~A](https://vk.com/~A?w=wall~A_~A)~@[ ~{↩ ~A~}~]~@[ @ ~A~]~%~A"
  459. preview name domain (aget "from_id" post) (aget "id" post)
  460. reposts (format-ts (local-time:unix-to-timestamp (aget "date" post)))
  461. text)
  462. (if preview 0 1))))
  463. (defun handle-cmd-wall (chat-id message-id args)
  464. (log:info "handle-cmd-wall" chat-id message-id args)
  465. (handler-case
  466. (let ((domains (db-vk-get-chat-domains chat-id)))
  467. (if (null args)
  468. (%send-domains chat-id domains)
  469. (progn
  470. (dolist (url args)
  471. (handler-case
  472. (let ((idx (parse-integer url)))
  473. (db-vk-remove-chat-domain chat-id (nth (1- idx) domains)))
  474. (parse-error ()
  475. (let* ((domain (%ensure-domain (%find-vk-domain url)))
  476. (existing (find domain domains :test #'equal)))
  477. (if existing
  478. (db-vk-remove-chat-domain chat-id domain)
  479. (db-vk-add-chat-domain chat-id domain))))
  480. (error (e) (log:error "~A" e))))
  481. (%send-domains chat-id (db-vk-get-chat-domains chat-id)))))
  482. (error (e)
  483. (log:error "~A" e)
  484. (telegram-send-message chat-id (format nil "Ошибочка вышла: ~A" e)))))
  485. (defun process-walls ()
  486. (handler-case
  487. (loop for (domain last-id next-fetch period) in (db-vk-get-active-walls)
  488. when (or (null next-fetch)
  489. (local-time:timestamp> (local-time:now) (local-time:unix-to-timestamp next-fetch)))
  490. do (progn
  491. (log:info "Fetching wall" domain)
  492. (handler-case
  493. (let ((new-posts
  494. (remove last-id (reverse (aget "items" (vk-wall-get :domain domain)))
  495. :test #'>= :key (lambda (p) (aget "id" p))))
  496. name)
  497. (setf period (adjust-period period (length new-posts)))
  498. (when new-posts
  499. (setf name (vk-get-name domain)))
  500. (dolist (post new-posts)
  501. (multiple-value-bind (text disable)
  502. (%format-wall-post domain name post)
  503. (dolist (chat-id (db-vk-get-domain-chats domain))
  504. (ignore-errors
  505. (telegram-send-message chat-id text
  506. :parse-mode "Markdown"
  507. :disable-web-preview disable))))
  508. (setf last-id (max last-id (aget "id" post)))))
  509. (error (e) (log:error "~A" e)))
  510. (db-vk-update-wall domain last-id
  511. (local-time:timestamp-to-unix
  512. (local-time:timestamp+ (local-time:now) period :sec))
  513. period))) ;; Update last-id, next-fetch and period
  514. (error (e) (log:error "~A" e))))
  515. (defun handle-cmd-nalunch (chat-id message-id args)
  516. (log:info "handle-cmd-nalunch" chat-id message-id args)
  517. (handler-case
  518. (if (member chat-id *admins*)
  519. (send-response chat-id (nalunch-format
  520. (or *nalunch-last-result*
  521. (setf *nalunch-last-result*
  522. (nalunch-recent)))))
  523. (send-dont-understand chat-id))
  524. (error (e)
  525. (log:error "~A" e)
  526. (telegram-send-message chat-id (format nil "~A" e)))))
  527. (defvar *nalunch-last-result* nil "Last check result")
  528. (defun process-nalunch ()
  529. (handler-case
  530. (let ((result (nalunch-recent)))
  531. (unless (equal (aget :balance *nalunch-last-result*)
  532. (aget :balance result))
  533. (send-response (car *admins*) (nalunch-format result t))
  534. (setf *nalunch-last-result* result)))
  535. (error (e) (log:error "~A" e))))
  536. (defun handle-cmd-google (chat-id message-id args)
  537. (log:info "handle-cmd-google" chat-id message-id args)
  538. (handler-case
  539. (telegram-send-message chat-id
  540. (google-format-search-results
  541. (subseq
  542. (google-search (format nil "~{~A~^ ~}" args))
  543. 0 3))
  544. :parse-mode "markdown"
  545. :disable-web-preview 1)
  546. (error (e)
  547. (log:error "~A" e)
  548. (telegram-send-message chat-id (format nil "~A" e)))))
  549. (defun process-watchdog ()
  550. (ignore-errors
  551. (close
  552. (open (merge-pathnames ".watchdog"
  553. (asdf:component-pathname
  554. (asdf:find-system '#:chatikbot)))
  555. :direction :output
  556. :if-exists :supersede
  557. :if-does-not-exist :create))))
  558. (defvar *save-settings-lock* (bordeaux-threads:make-lock "save-settings-lock")
  559. "Lock for multithreading access to write settings file")
  560. (defun save-settings()
  561. (bordeaux-threads:with-lock-held (*save-settings-lock*)
  562. (with-open-file (s (merge-pathnames "settings.lisp"
  563. (asdf:component-pathname
  564. (asdf:find-system '#:chatikbot)))
  565. :direction :output
  566. :if-exists :supersede
  567. :if-does-not-exist :create)
  568. (write '(in-package #:chatikbot) :stream s)
  569. (write
  570. `(setf *chat-locations* ',*chat-locations*
  571. *akb-send-to* ',*akb-send-to*
  572. *akb-last-id* ,*akb-last-id*)
  573. :stream s)
  574. (values))))
  575. (defvar *schedules* '(process-latest-akb
  576. process-latest-checkins
  577. process-rates
  578. process-feeds
  579. process-walls
  580. process-watchdog) "Enabled schedules")
  581. (defun start ()
  582. ;; Clear prev threads
  583. (mapc #'trivial-timers:unschedule-timer (trivial-timers:list-all-timers))
  584. (let ((old-updates (find "process-updates"
  585. (bordeaux-threads:all-threads)
  586. :key #'bordeaux-threads:thread-name
  587. :test #'equal)))
  588. (when old-updates
  589. (bordeaux-threads:destroy-thread old-updates)))
  590. ;; Load settings file
  591. (alexandria:when-let (file (probe-file
  592. (merge-pathnames "settings.lisp"
  593. (asdf:component-pathname
  594. (asdf:find-system '#:chatikbot)))))
  595. (load file))
  596. ;; Start timers
  597. (dolist (func *schedules*)
  598. (clon:schedule-function func
  599. (clon:make-scheduler
  600. (clon:make-typed-cron-schedule :minute '* :hour '*)
  601. :allow-now-p t)
  602. :name func
  603. :thread t))
  604. ;; YIT
  605. (let ((last-yit-info))
  606. (clon:schedule-function
  607. #'(lambda() (let ((info (yit-info)))
  608. (when (not (equal info last-yit-info))
  609. (send-response (car *admins*) info)
  610. (setf last-yit-info info))))
  611. (clon:make-scheduler
  612. (clon:make-typed-cron-schedule :minute 0 :hour '*)
  613. :allow-now-p t)
  614. :name "YIT" :thread t))
  615. ;; Nalunch
  616. (clon:schedule-function
  617. #'process-nalunch (clon:make-scheduler (clon:make-typed-cron-schedule
  618. :minute '(member 0 15 30 45))
  619. :allow-now-p t)
  620. :name "Nalunch" :thread t)
  621. ;; Start getUpdates thread
  622. (bordeaux-threads:make-thread
  623. (lambda () (loop-with-error-backoff #'process-updates))
  624. :name "process-updates")
  625. ;; Notify admins
  626. (dolist (admin *admins*)
  627. (telegram-send-message admin (format nil "chatikbot started at ~A" (format-ts (local-time:now))))))