blob: aef3013e739065a0cbe93b9e35dab0f839458f2a (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
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>~%"))))
|
