diff options
Diffstat (limited to 'server/rss.lisp')
| -rw-r--r-- | server/rss.lisp | 122 |
1 files changed, 122 insertions, 0 deletions
diff --git a/server/rss.lisp b/server/rss.lisp new file mode 100644 index 0000000..aef3013 --- /dev/null +++ b/server/rss.lisp @@ -0,0 +1,122 @@ +(defpackage #:cl-bbs/rss + (:use #:cl) + (:local-nicknames (#:models #:cl-bbs/models) + (#:storage #:cl-bbs/storage)) + (:export #:generate-rss + #:get-all-boards-rss-threads)) + +(in-package #:cl-bbs/rss) + +(defun get-url-scheme (env headers) + (if (string= "https" (gethash "x-forwarded-proto" headers)) + "https" + (let ((url-scheme (getf env :url-scheme))) + (if url-scheme + (string-downcase (string url-scheme)) + "http")))) + +(defun get-request-base-url (env) + "Construct the base URL from the request environment." + (let* ((headers (getf env :headers)) + (scheme (get-url-scheme env headers)) + (host (gethash "host" headers))) + (if host + (format nil "~a://~a" scheme host) + ""))) + +(defun get-tz-offset-string () + "Returns the basic timezone offset of the machine like '-0300' or '+0000'." + (multiple-value-bind (sec min hr date month year day-of-week dst-p tz) + (get-decoded-time) + (declare (ignore sec min hr date month year day-of-week dst-p)) + (let* ((offset-hours (- tz)) + (sign (if (>= offset-hours 0) #\+ #\-)) + (abs-hours (abs offset-hours))) + (format nil "~c~2,'0d00" sign (truncate abs-hours))))) + +(defun convert-to-rfc822 (iso-8601-string) + "Convert simple ISO 8601 string to RFC1123/RFC822 retaining literal parsing and appending manual offset." + (let ((clean-string (cl-ppcre:regex-replace-all " " iso-8601-string "T"))) + (handler-case + (let* ((parsed (local-time:parse-timestring clean-string)) + (utc-str (local-time:format-rfc1123-timestring nil parsed :timezone local-time:+utc-zone+))) + (cl-ppcre:regex-replace "(?:GMT|\\+0000)$" utc-str (get-tz-offset-string))) + (error () + (let ((now-utc (local-time:format-rfc1123-timestring nil (local-time:now) :timezone local-time:+utc-zone+))) + (cl-ppcre:regex-replace "(?:GMT|\\+0000)$" now-utc (get-tz-offset-string))))))) + + + +(defun get-all-boards-rss-threads (limit) + "Fetch latest threads from all boards combining them for RSS." + (let ((all-threads nil) + (sexp-base (merge-pathnames "sexp/" storage:*base-dir*))) + (when (probe-file sexp-base) + (loop for board-dir in (uiop:subdirectories sexp-base) do + (let ((board-name (car (last (pathname-directory board-dir)))) + (list-path (merge-pathnames "list" board-dir))) + (when (probe-file list-path) + (let ((board-threads (storage:read-sexp-file list-path))) + (loop for thread in board-threads do + ;; thread is (ID (models:headline . "...") (models:date . "...")) + (push (cons (car thread) (cons `(models:board . ,board-name) (cdr thread))) all-threads))))))) + ;; Sort by date descending + (setf all-threads (sort all-threads + (lambda (a b) + (string> (cdr (assoc 'models:date (cdr a))) + (cdr (assoc 'models:date (cdr b))))))) + ;; Take top LIMIT + (if (> (length all-threads) limit) + (subseq all-threads 0 limit) + all-threads))) + +(defun generate-rss (board threads env) + "Generate an RSS feed for the given board and threads." + (let* ((now (local-time:now)) + (utc-str (local-time:format-rfc1123-timestring nil now)) + (rfc822-date utc-str) + (base-url (get-request-base-url env)) + (request-url (format nil "~a~a" base-url (getf env :request-uri)))) + (with-output-to-string (s) + (format s "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>~%") + (format s "<rss version=\"2.0\" xmlns:content=\"http://purl.org/rss/1.0/modules/content/\">~%") + (format s " <channel>~%") + (if (string= board "all") + (progn + (format s " <title>cl-bbs - all boards</title>~%") + (format s " <description>Latest threads from all boards on cl-bbs.</description>~%")) + (progn + (format s " <title>cl-bbs - /~a/</title>~%" board) + (format s " <description>Latest threads from /~a/.</description>~%" board))) + (format s " <link>~a</link>~%" request-url) + (format s " <pubDate>~a</pubDate>~%" rfc822-date) + (format s " <generator>cl-bbs RSS generator</generator>~%") + + (loop for t-entry in threads do + (let* ((id (car t-entry)) + (thread-data (cdr t-entry)) + (board-val (if (string= board "all") + (or (cdr (assoc 'models:board thread-data)) board) + board)) + (headline (or (cdr (assoc 'models:headline thread-data)) "Untitled")) + (date (or (cdr (assoc 'models:date thread-data)) rfc822-date)) ; ISO 8601 + (pub-date (if (string= date rfc822-date) rfc822-date (convert-to-rfc822 date))) + (thread-url (if (not (string= base-url "")) + (format nil "~a/~a/~a" base-url board-val id) + (format nil "/~a/~a" board-val id))) + (thread-path (merge-pathnames (format nil "sexp/~a/~a" board-val id) storage:*base-dir*)) + (thread-full-data (when (probe-file thread-path) (storage:read-sexp-file thread-path))) + (posts (cdr (assoc 'models:posts thread-full-data))) + (first-post (when posts (cdar (car posts)))) + (content (if first-post (cdr (assoc 'models:content first-post)) ""))) + (format s " <item>~%") + (format s " <title><![CDATA[~a]]></title>~%" headline) + (format s " <link>~a</link>~%" thread-url) + (format s " <description><![CDATA[~a]]></description>~%" headline) ;; Fallback to headline + (format s " <content:encoded><![CDATA[~a]]></content:encoded>~%" content) + (format s " <pubDate>~a</pubDate>~%" pub-date) + (format s " <guid>~a</guid>~%" thread-url) + (format s " </item>~%"))) + + (format s " </channel>~%") + (format s "</rss>~%")))) |