Update cl-bbsHEADmaster

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>~%"))))