chatikbot/rss.lisp

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

;; Databaase
(def-db-init (db)
  (%db-execute db "create table if not exists rss_feeds (id INTEGER PRIMARY KEY, url, title, next_fetch, period)")
  (%db-execute db "create unique index if not exists rss_feeds_url_idx on rss_feeds (url)")
  (%db-execute db "create table if not exists rss_items (id INTEGER PRIMARY KEY, feed_id REFERENCES rss_feeds, guid, link, title, published)")
  (%db-execute db "create index if not exists rss_items_idx on rss_items (feed_id, guid)")

  (%db-execute db "create table if not exists rss_chat_feeds (chat_id, feed_id REFERENCES rss_feeds)")
  (%db-execute db "create index if not exists rss_chat_feeds_chat_idx on rss_chat_feeds (chat_id)")
  (%db-execute db "create index if not exists rss_chat_feeds_feed_idx on rss_chat_feeds (feed_id)"))

(defun %db/make-feed (row)
  (when row
    (make-feed :id (nth 0 row)
               :url (nth 1 row)
               :title (nth 2 row)
               :next-fetch (when (nth 3 row) (local-time:unix-to-timestamp (nth 3 row)))
               :period (nth 4 row))))


(defun db/rss-get-feed-by-url (url)
  (%db/make-feed (car (db-select "select id, url, title, next_fetch, period from rss_feeds where url = ?" url))))

(defun db/rss-add-feed (feed)
  (with-slots (url title period) feed
    (let ((next-fetch (feed-next-fetch-unix feed)))
      (setf (feed-id feed) (db-execute "insert into rss_feeds (url, title, next_fetch, period) values (?, ?, ?, ?)"
                                       url title next-fetch period))
      feed)))

(defun db/rss-update-feed (feed)
  (with-slots (id title period) feed
    (let ((next-fetch (feed-next-fetch-unix feed)))
      (db-execute "update rss_feeds set title = ?, next_fetch = ?, period = ? where id = ?"
                  title next-fetch period id))))

(defun db/rss-get-active-feeds ()
  (mapcar #'%db/make-feed
          (db-select "select id, url, title, next_fetch, period from rss_feeds where exists (select 1 from rss_chat_feeds where feed_id=id)")))

(defun db/rss-get-chat-feeds (chat-id)
  (mapcar #'%db/make-feed
          (db-select "select id, url, title, next_fetch, period from rss_feeds where id in (select feed_id from rss_chat_feeds where chat_id = ?)" chat-id)))

(defun db/rss-get-feed-chats (feed)
  (with-slots (id) feed
    (flatten (db-select "select chat_id from rss_chat_feeds where feed_id = ?" id))))

(defun db/rss-set-chat-feeds (chat-id feeds)
  (db-transaction (db)
    (%db-execute db "delete from rss_chat_feeds where chat_id = ?" chat-id)
    (dolist (feed feeds)
      (with-slots (id) feed
        (%db-execute db "insert into rss_chat_feeds (chat_id, feed_id) values (?, ?)" chat-id id)))))

(defun db/rss-item-exists (item)
  (let ((feed-id (feed-id (feed-item-feed item)))
        (guid (feed-item-guid item)))
    (db-single "select id from rss_items where feed_id = ? and guid = ? limit 1"
               feed-id guid)))

(defun db/rss-add-item (item)
  (let ((feed-id (feed-id (feed-item-feed item)))
        (published (feed-item-published-unix item)))
    (with-slots (guid link title) item
      (db-execute "insert into rss_items (feed_id, guid, link, title, published) values (?, ?, ?, ?, ?)"
                  feed-id guid link title published))))

(defun %db/make-feed-item (feed row)
  (when row
    (make-feed-item :feed feed
                    :guid (nth 0 row)
                    :link (nth 1 row)
                    :title (nth 2 row)
                    :published (when (nth 3 row) (local-time:unix-to-timestamp (nth 3 row))))))

(defun db/rss-last-feed-items (feed &optional (limit 10))
  (with-slots (id) feed
    (mapcar #'(lambda (row) (%db/make-feed-item feed row))
            (db-select "select guid, link, title, published from rss_items where feed_id = ? order by published desc, id desc limit ?" id limit))))


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