Skip to content

Commit 7a784bf

Browse files
xachxach
committed
Change url structure for feeds.
Also don't publish empty feed files if a feed file is already there. Saves a lot of S3 traffic.
1 parent e68e98f commit 7a784bf

File tree

2 files changed

+168
-53
lines changed

2 files changed

+168
-53
lines changed

‎rss-failure-feeds.lisp‎

Lines changed: 153 additions & 53 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
;;;; rss-failure-feeds.lisp
22
;;;;
3-
;;;; Building on the html failure reports, produces a set of feeds so
4-
;;;; authors and other interested people can subscribe to failures.
3+
;;;; Building on the html failure reports, produces a set of RSS feeds
4+
;;;; so authors and other interested people can subscribe to failures.
55
;;;;
66
;;;; Each failing source becomes an item in a feed. There are many
77
;;;; different feeds - one for each source, one for each author (as
@@ -19,6 +19,46 @@
1919

2020
(in-package #:quicklisp-controller)
2121

22+
;;; Relevant part of the log file to include
23+
24+
(defun remaining-lines (stream)
25+
(coerce
26+
(loop repeat 25
27+
for line = (read-line stream nil)
28+
while line
29+
collect line)
30+
'vector))
31+
32+
(defun best-logfile-info (logfile)
33+
"Return a string with the best available logfile info from LOGFILE."
34+
;;; Search for "^Backtrace for" and return everything after, and 15
35+
;;; lines before. If that line isn't found, just return the last 15
36+
;;; lines of the file.
37+
(let* ((trailing-line-count 25)
38+
(trailing-lines (make-array trailing-line-count :initial-element nil))
39+
(i 0))
40+
(flet ((trail-line (line)
41+
(setf (aref trailing-lines i) line)
42+
(setf i (mod (1+ i) trailing-line-count)))
43+
(trailing-lines ()
44+
(let ((end (position nil trailing-lines)))
45+
(if end
46+
(subseq trailing-lines 0 end)
47+
(concatenate 'vector
48+
(subseq trailing-lines i)
49+
(subseq trailing-lines 0 i))))))
50+
(with-open-file (stream logfile)
51+
(loop
52+
(let ((line (read-line stream nil)))
53+
(unless line
54+
(return (trailing-lines)))
55+
(unless (boring-log-line-p line)
56+
(trail-line line))
57+
(when (ppcre:scan "^Backtrace for" line)
58+
(return (concatenate 'vector
59+
(trailing-lines)
60+
(remaining-lines stream))))))))))
61+
2262
;;; Grouping sources by author (or other criteria)
2363

2464
(defparameter *location-grouping-patterns*
@@ -49,8 +89,8 @@
4989
(let ((location (location source)))
5090
(dolist (pattern *location-grouping-patterns*)
5191
(let ((group (scan-first-register pattern location)))
52-
(when group
53-
(return group))))))
92+
(when group
93+
(return group))))))
5494

5595
;;; Producing feeds
5696

@@ -59,13 +99,29 @@
5999
(let ((failures (failure-data failing-source)))
60100
(format stream "<p>Project <b>~A</b><p>~%" (name failing-source))
61101
(format stream "<p>Taken from <code>~A</code></p>~%"
62-
(first-line-of (source-file (source failing-source))))
102+
(first-line-of (source-file (source failing-source))))
103+
(let ((link (source-link (source failing-source))))
104+
(when link
105+
(format stream "<p> site: <a href='~A'>~A</a></p>~%" link link)))
63106
(format stream "<p>~A</p>~%" (versions-and-such))
64107
(format stream "<p>~D failing system~:*~P: ~{~A~^, ~}</p>~%"
65-
(length failures)
66-
(mapcar 'system-name failures))
108+
(length failures)
109+
(mapcar 'system-name failures))
110+
(dolist (system failures)
111+
(let ((interesting-lines (best-logfile-info
112+
(failure-log-file system))))
113+
(format stream "<h3>~A</h3>~%~%" (system-name system))
114+
(format stream "<pre>~%...~%")
115+
(map nil
116+
(lambda (line)
117+
(if (highlighted-log-line-p line)
118+
(format stream "<strong style='color: red'> ~A</strong>~%"
119+
(escape-html line))
120+
(format stream " ~A~%" (escape-html line))))
121+
interesting-lines)
122+
(format stream "</pre>~%~%")))
67123
(format stream "<p><a href='~A'>Full build log</a></p>~%"
68-
(full-failure-report-url failing-source)))))
124+
(full-failure-report-url failing-source)))))
69125

70126
(defun item-title (failing-source)
71127
(format nil "~A" (name (source failing-source))))
@@ -77,63 +133,107 @@
77133

78134
(defun failing-source-item (failing-source)
79135
(make-instance 'failing-source-item
80-
:failing-source failing-source
81-
:title (item-title failing-source)
82-
:description (item-contents failing-source)
83-
:guid (full-failure-report-url failing-source)
84-
:link (full-failure-report-url failing-source)))
136+
:failing-source failing-source
137+
:title (item-title failing-source)
138+
:description (item-contents failing-source)
139+
:guid (full-failure-report-url failing-source)
140+
:link (full-failure-report-url failing-source)))
85141

86142

87-
(defun feed-link (group)
88-
(format nil "http://report.quicklisp.org/rss/~A.rss" group))
143+
(defun feed-link (type title)
144+
(format nil "http://report.quicklisp.org/feeds/~@[~A/~]~A.rss"
145+
type title))
89146

90-
(defun generate-feeds (failure-report)
91-
"Return a hash-table of feeds, keyed by feed group name. Special key
92-
'all' has all feeds."
147+
(defun feed-key (type title)
148+
(format nil "~@[~A/~]~A" type title))
149+
150+
(defun make-empty-feeds (&key (sources (all-of-type t)))
151+
"Return a hash table keyed on feed structure strings with feeds as
152+
values. There is an \"all\" key, keys starting with \"author/\" for
153+
each grouping of feeds by author, and keys starting with
154+
\"project/\" with one feed per project."
93155
(let ((feeds (make-string-table)))
94-
(labels ((ensure-feed (title link)
95-
(let ((feed (gethash title feeds)))
96-
(or feed
97-
(setf (gethash title feeds)
98-
(make-instance 'feed
99-
:pub-date (get-universal-time)
100-
:last-build-date (get-universal-time)
101-
:title title
102-
:link link
103-
:description
104-
(format nil "Quicklisp build failures for ~S"
105-
title)))))))
106-
;; Generate empty feeds for all sources
107-
(map-sources
108-
(lambda (source)
109-
(let ((group-name (group-name source)))
110-
(when group-name
111-
(ensure-feed group-name (feed-link group-name))))))
112-
;; Populate failing sources
113-
(let ((all (ensure-feed "all" (feed-link "all"))))
114-
(dolist (source (failure-data failure-report) feeds)
115-
(let* ((item (failing-source-item source))
116-
(group-name (group-name (source source))))
117-
(push item (items all))
118-
(when group-name
119-
(push item (items (ensure-feed group-name (feed-link group-name)))))))))))
156+
(flet ((make-feed (type title)
157+
(let ((key (feed-key type title)))
158+
(unless (gethash key feeds)
159+
(setf (gethash key feeds)
160+
(make-instance 'feed
161+
:pub-date (get-universal-time)
162+
:last-build-date (get-universal-time)
163+
:title title
164+
:link (feed-link type title)
165+
:description
166+
(format nil "Quicklisp build failures for ~S"
167+
title)))))))
168+
(make-feed nil "all")
169+
(dolist (source sources feeds)
170+
(make-feed "project" (name source))
171+
(make-feed "author" (group-name source))))))
172+
173+
(defun generate-feeds (failure-report)
174+
"Return a hash-table of feeds. Keys are string that represent feed
175+
output structure, e.g. 'all' has everything, 'author/xach' has my
176+
projects, 'project/vecto' has a single project named vecto."
177+
(let ((feeds (make-empty-feeds)))
178+
(flet ((ensure-feed (type title)
179+
(let ((key (feed-key type title)))
180+
(or (gethash key feeds)
181+
(error "Unknown feed key ~S" key)))))
182+
(let ((all (ensure-feed nil "all")))
183+
(dolist (failing-source (failure-data failure-report) feeds)
184+
(let* ((source (source failing-source))
185+
(item (failing-source-item failing-source))
186+
(project-name (name source))
187+
(group-name (group-name source)))
188+
(push item (items all))
189+
(push item (items (ensure-feed "project" project-name)))
190+
(when group-name
191+
(push item (items (ensure-feed "author" group-name))))))))))
120192

121193
(defun write-feeds (failure-report output-directory)
122194
(let ((feeds (generate-feeds failure-report)))
123195
(let ((*default-pathname-defaults* (truename
124-
(ensure-directories-exist
125-
output-directory))))
196+
(ensure-directories-exist
197+
output-directory))))
126198
(maphash
127-
(lambda (name feed)
128-
(generate-to (make-pathname :type "rss" :name name) feed))
199+
(lambda (key feed)
200+
(let ((output (merge-pathnames key "feed.rss") ))
201+
(ensure-directories-exist output)
202+
(generate-to output feed)))
129203
feeds)
130204
*default-pathname-defaults*)))
131205

206+
;;; There can be thousands of feeds, so don't try to publish empty
207+
;;; feed files if they already exist.
208+
209+
(defun existing-published-keys ()
210+
(let ((keys (zs3:all-keys *failtail-bucket*
211+
:prefix "feeds/"
212+
:credentials *failtail-credentials*))
213+
(table (make-string-table)))
214+
(map nil
215+
(lambda (s3-key)
216+
(setf (gethash (zs3:name s3-key) table) t))
217+
keys)
218+
table))
219+
220+
(defun empty-feed-file-p (file)
221+
(with-open-file (stream file)
222+
(loop for line = (read-line stream nil)
223+
while line
224+
never (ppcre:scan "<item>" line))))
225+
132226
(defun publish-feeds (feed-directory)
133-
(let ((files (directory (make-pathname :name :wild
134-
:type "rss"
135-
:defaults feed-directory))))
227+
;; Truename in advance to avoid issues with the truenaming of
228+
;; DIRECTORY results and the relative nature of ENOUGH-NAMESTRING.
229+
(setf feed-directory (truename feed-directory))
230+
(let ((files (directory (merge-pathnames "**/*.rss" feed-directory)))
231+
(existing-keys (existing-published-keys)))
136232
(dolist (file files)
137-
(let ((key (format nil "feeds/~A.rss" (pathname-name file))))
138-
(upload-report-file file key)))))
233+
(let ((key (format nil "feeds/~A"
234+
(enough-namestring file feed-directory))))
235+
(when (or (not (gethash key existing-keys))
236+
(not (empty-feed-file-p file)))
237+
(upload-report-file file key))))))
238+
139239

‎utils.lisp‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -278,3 +278,18 @@ template pathname."
278278

279279
(defun empty-file-p (file)
280280
(zerop (file-size file)))
281+
282+
(defun escape-html (string)
283+
(with-output-to-string (s)
284+
(loop for char across string
285+
do
286+
(case char
287+
(#\&
288+
(write-string "&amp;" s))
289+
(#\<
290+
(write-string "&lt;" s))
291+
(#\>
292+
(write-string "&gt;" s))
293+
(#\Nul
294+
(write-string "[nul]" s))
295+
(t (write-char char s))))))

0 commit comments

Comments
 (0)