(in-package #:chatikbot) (defstruct feed id url title next-fetch (period 300)) (defstruct feed-item feed guid link title description published) (defparameter *rss-min-period* 60 "Min rss refresh period in seconds") (defparameter *rss-max-period* 1800 "Max rss refresh period in seconds") (defparameter *rss-change-rate* 0.1 "Refresh period adjustment rate") (defun find-rss-links (url) (handler-case (multiple-value-bind (root uri encoding) (xml-request url) (declare (ignore encoding)) (loop for link in (get-by-tag root "link") when (string= "application/rss+xml" (plump:attribute link "type")) collect (list (plump:attribute link "title") (puri:render-uri (puri:merge-uris (puri:uri (plump:attribute link "href")) uri) nil)))) (error (e) (log:error e)))) (defun build-feed (url) (let ((root (xml-request url))) (alexandria:when-let (rss (car (get-by-tag root "rss"))) (make-feed :url url :title (child-text rss "title"))))) (defun adjust-period (period new-items) "Adjust the period of feed based on whenever there were new items. With clamping" (let ((diff (round (* period *rss-change-rate*)))) (min *rss-max-period* (max *rss-min-period* (- period (* diff (if (zerop new-items) -1 new-items))))))) (defun need-fetch-p (feed) (or (null (feed-next-fetch feed)) (local-time:timestamp> (local-time:now) (feed-next-fetch feed)))) (defun refresh-feed (feed &optional (skip-p #'not)) (let* ((items (loop for item in (ignore-errors (fetch-feed-items feed)) unless (funcall skip-p item) collect item)) (new-period (adjust-period (feed-period feed) (length items)))) (setf (feed-period feed) new-period (feed-next-fetch feed) (local-time:timestamp+ (local-time:now) new-period :sec)) items)) (defun trim-nil (text) (when text (let ((text (string-trim " " text))) (unless (zerop (length text)) text)))) (defun text-with-cdata (node) "Compiles all text nodes within the nesting-node into one string." (with-output-to-string (stream) (labels ((r (node) (loop for child across (plump:children node) do (typecase child (plump:text-node (write-string (plump:text child) stream)) (plump:cdata (write-string (plump:text child) stream)) (plump:nesting-node (r child)))))) (r node)))) (defun child-text (node tag) (alexandria:when-let (child (car (get-by-tag node tag))) (trim-nil (text-with-cdata child)))) (defun clean-text (text) (when text (trim-nil (plump:text (plump:parse text))))) (defun %send-feeds (chat-id feeds) (bot-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 fetch-feed-items (feed) (let ((plump:*tag-dispatchers* plump:*xml-tags*)) (loop for item in (get-by-tag (xml-request (feed-url feed)) "item") collect (make-feed-item :feed feed :guid (or (child-text item "guid") (child-text item "link")) :link (child-text item "link") :title (clean-text (child-text item "title")) :description (clean-text (child-text item "description")) :published (ignore-errors (alexandria:when-let (pub (or (child-text item "pubDate") (child-text item "published"))) (local-time:universal-to-timestamp (date-time-parser:parse-date-time pub)))))))) (defun format-feed-item (item) (format nil "[~A](~A)~@[ @ ~A~]~%~A~%" (feed-title (feed-item-feed item)) (feed-item-link item) (alexandria:when-let (ts (feed-item-published item)) (local-time:format-timestring nil ts :format '((:year 2) "-" (:month 2) "-" (:day 2) " " (:hour 2) ":" (:min 2)))) (feed-item-title item))) (defun feed-next-fetch-unix (feed) (alexandria:when-let (ts (feed-next-fetch feed)) (local-time:timestamp-to-unix ts))) (defun feed-item-published-unix (item) (alexandria:when-let (ts (feed-item-published item)) (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)))) ;; Hooks (def-message-cmd-handler handler-cmd-feeds (:feeds) (bot-send-message chat-id (if (null args) "URL давай" (format nil "~:[Не нашел RSS там~;~:*~{~{~A - ~A~}~^~%~}~]" (find-rss-links (car args)))) :disable-web-preview 1)) (def-message-cmd-handler handler-cmd-rss (:rss) (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 "~A" e)))) (db-rss-set-chat-feeds chat-id feeds) (%send-feeds chat-id (db-rss-get-chat-feeds chat-id)))))) (def-message-cmd-handler handler-cmd-last-rss (:lastrss) (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)))))