feat: add global and specific board RSS feed endpoints

cl-bbs.asd

@@ -68,6 +68,7 @@
                 :depends-on ("package")
                 :components ((:file "models")
                              (:file "storage" :depends-on ("models"))
+                             (:file "rss" :depends-on ("models" "storage"))
                              (:file "views" :depends-on ("models"))
                              (:file "handlers" :depends-on ("storage" "views"))
                              (:file "main" :depends-on ("handlers" "storage"))
@@ -97,6 +98,7 @@
                 :components ((:file "models")
                              (:file "storage")
                              (:file "views")
+                             (:file "rss")
                              (:file "handlers")
                              (:file "admin")))
                (:module "integration"

src/server/handlers.lisp

@@ -4,11 +4,14 @@
                 #:*base-dir*
                 #:read-sexp-file
                 #:write-sexp-file
-                #:ensure-board-dirs
-                #:is-board-locked)
-  (:import-from :cl-bbs/views
-                #:render-moderation
-                #:render-index
+                #:is-board-locked
+                #:ensure-board-dirs)
+                (:import-from :cl-bbs/rss
+                 #:generate-rss
+                 #:get-all-boards-rss-threads)
+                (:import-from :cl-bbs/views
+                 #:render-moderation
+                 #:render-index
                 #:render-list
                 #:render-preferences
                 #:render-error-page
@@ -693,6 +696,25 @@ hyphens, and underscores. Otherwise returns nil to prevent injection/directory t
                  :set-cookie ,(format nil "search_position=~a; Path=/; Max-Age=31536000" search-position))
                 ("Redirecting...")))))
 
+;; RSS Feed (All boards)
+(setf (ningle:route *app* "/rss" :method :GET)
+      (lambda (params)
+        (declare (ignore params))
+        (let ((env (lack.request:request-env ningle:*request*))
+              (all-threads (cl-bbs/rss:get-all-boards-rss-threads 20)))
+          (list 200 '(:content-type "application/rss+xml; charset=utf-8")
+                (list (cl-bbs/rss:generate-rss "all" all-threads env))))))
+
+;; RSS Feed (Specific board)
+(setf (ningle:route *app* "/:board/rss" :method :GET)
+      (lambda (params)
+        (let* ((board (cdr (assoc :board params)))
+               (env (lack.request:request-env ningle:*request*))
+               (list-path (merge-pathnames (format nil "sexp/~a/list" board) *base-dir*))
+               (threads (when (probe-file list-path) (read-sexp-file list-path))))
+          (list 200 '(:content-type "application/rss+xml; charset=utf-8")
+                (list (cl-bbs/rss:generate-rss board threads env))))))
+
 ;; 10. POST /:board/post (New Thread)
 (setf (ningle:route *app* "/:board/post" :method :POST)
       (lambda (params)

src/server/rss.lisp

@@ -0,0 +1,116 @@
+(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\">~%")
+      (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))))
+          (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 "      <pubDate>~a</pubDate>~%" pub-date)
+          (format s "      <guid>~a</guid>~%" thread-url)
+          (format s "    </item>~%")))
+
+      (format s "  </channel>~%")
+      (format s "</rss>~%"))))

src/server/views.lisp

@@ -50,15 +50,19 @@
               (error () nil))
             "unknown"))))
 
-(defun render-footer-html ()
+(defun render-footer-html (&optional board)
   "Renders the common footer HTML with cl-bbs version hash and a GitHub link."
   (let ((hash (get-git-commit-hash)))
     (cl-who:with-html-output-to-string (s nil :indent t)
       (:p :class "footer"
           "cl-bbs version:"
           (:a :href (format nil "https://github.com/ryukinix/cl-bbs/commit/~a" hash)
               :target "_blank"
-              (cl-who:esc hash))))))
+              (cl-who:esc hash))
+          " - "
+          (:a :href (if board (format nil "/~a/rss" board) "/rss")
+              :target "_blank"
+              "RSS Feed")))))
 
 (defun render-board-name (board)
   (cl-who:with-html-output-to-string (s nil :indent t)
@@ -519,7 +523,7 @@ and the new thread form, using layout PREFS."
       (unless (is-board-locked board)
         (cl-who:htm (cl-who:str (render-thread-form board))))
       (:hr)
-      (cl-who:str (render-footer-html)))))
+      (cl-who:str (render-footer-html board)))))
 
 (defun render-list (board threads &optional (prefs *preferences*))
   "Renders the board thread-list HTML page, showing all THREADS in tabular format, using layout PREFS."
@@ -544,7 +548,7 @@ and the new thread form, using layout PREFS."
                                 (:td (cl-who:str (format nil "~a" messages)))
                                 (:td (:samp (cl-who:esc date)))))))))
       (:hr)
-      (cl-who:str (render-footer-html)))))
+      (cl-who:str (render-footer-html board)))))
 
 (defun render-thread (board thread-id thread-data &optional range-string (prefs *preferences*))
   "Renders a single thread page HTML for THREAD-ID under BOARD with THREAD-DATA (comments),
@@ -622,7 +626,7 @@ optionally filtered by RANGE-STRING, using layout PREFS."
                      (cl-who:str (format nil "~a" next-post-number))))
             (:dd (cl-who:str (render-post-form board thread-id))))))
         (:hr)
-        (cl-who:str (render-footer-html))))))
+        (cl-who:str (render-footer-html board))))))
 
 (defun render-preferences (board &optional (prefs *preferences*))
   "Renders the board preferences HTML page, allowing users to choose a custom

src/static/index.html

@@ -59,6 +59,6 @@ <H2>Software Stack</H2>
 <P><A href="https://sbcl.org"><IMG src="/static/img/mit-scheme.png" alt="SBCL Common Lisp" style="height:42px; width:auto; margin-right:10px;"></A><A href="https://www.gnu.org/software/mit-scheme/"><IMG src="/static/img/gnu.png" alt="GNU logo" style="height:42px; width:auto; margin-right:10px;"></A><A href="https://www.cloudflare.com"><IMG src="/static/img/cloudflare.png" alt="Cloudflare logo" style="height:42px; width:auto; margin-right:10px;"></A><A href="https://www.linux.org"><IMG src="/static/img/tux.png" alt="Linux logo" style="height:42px; width:auto;"></A></P>
 
 <HR>
-<P style="font-size: 0.9em; text-align: center; margin-top: 3em; padding-top: 1.5em; border-top: 1px dashed #aaa;"><A href="/about" style="text-decoration: none; font-weight: bold; color: #882200;">About cl-bbs</A></P>
+<P style="font-size: 0.9em; text-align: center; margin-top: 3em; padding-top: 1.5em; border-top: 1px dashed #aaa;"><A href="/about" style="text-decoration: none; font-weight: bold; color: #882200;">About cl-bbs</A> | <A href="/rss" style="text-decoration: none; font-weight: bold; color: #882200;">RSS Feed</A></P>
 </BODY>
 </HTML>

tests/main.lisp

@@ -2,6 +2,7 @@
 
 (defun run-tests (&optional (level 'cl-bbs/tests))
   "Runs all test cases within the cl-bbs/tests package."
+  (setf colorize:*debug* nil)
   (let ((report (test level)))
     (when (eq (status report) :failed)
       (uiop:quit 1))))

tests/unit/rss.lisp

@@ -0,0 +1,33 @@
+(in-package :cl-bbs/tests)
+
+(define-test test-get-request-base-url
+  :parent unit
+  ;; Test with string url-scheme
+  (let* ((headers (make-hash-table :test #'equal))
+         (env (list :headers headers :url-scheme "http" :request-uri "/rss")))
+    (setf (gethash "host" headers) "127.0.0.1:8222")
+    (is equal "http://127.0.0.1:8222" (cl-bbs/rss::get-request-base-url env)))
+
+  ;; Test with symbol url-scheme
+  (let* ((headers (make-hash-table :test #'equal))
+         (env (list :headers headers :url-scheme :https :request-uri "/rss")))
+    (setf (gethash "host" headers) "example.com")
+    (is equal "https://example.com" (cl-bbs/rss::get-request-base-url env)))
+
+  ;; Test with x-forwarded-proto
+  (let* ((headers (make-hash-table :test #'equal))
+         (env (list :headers headers :url-scheme :http :request-uri "/rss")))
+    (setf (gethash "host" headers) "proxy.example.com")
+    (setf (gethash "x-forwarded-proto" headers) "https")
+    (is equal "https://proxy.example.com" (cl-bbs/rss::get-request-base-url env)))
+
+  ;; Test with missing host
+  (let* ((headers (make-hash-table :test #'equal))
+         (env (list :headers headers :url-scheme :http :request-uri "/rss")))
+    (is equal "" (cl-bbs/rss::get-request-base-url env))))
+
+(define-test test-convert-to-rfc822
+  :parent unit
+  (let ((rfc822 (cl-bbs/rss::convert-to-rfc822 "2026-06-25 16:50:57")))
+    (true (not (null (search "2026" rfc822))))
+    (true (not (null (search "Jun" rfc822))))))