Publish failure report RSS feeds.

Also, clean up failure report to hide a bunch of noise by default.

Author: xach

dist-cache.lisp

@@ -346,6 +346,9 @@ their name does not match the system file name."
   directory component, pathname-name, or pathname-type."
   (substitute #\_ #\/ string))
 
+(defun decode-string-from-filesystem (string)
+  (substitute #\/ #\_ string))
+
 (defun winfail-file (winfail source system-file system)
   (let ((name (format nil "~A_~A_~A_~A"
                       winfail
@@ -386,6 +389,8 @@ are loadable for SOURCE and return a list of lists. Each list has the
 structure \(SYSTEM-FILE-NAME SYSTEM-NAME &REST DEPENDENCIES). "
   (ensure-system-file-index)
   (setf source (source-designator source))
+  (when (fresh-cache-p source)
+    (clear-fasl-cache))
   (let ((winners '())
 	(timing-file (timing-file source))
 	(start-time (get-universal-time)))

failure-report.css

@@ -26,6 +26,10 @@ span.source-location {
     color: #999;
 }
 
+span.boring {
+    display: none;
+}
+
 a.source-link:hover {
     text-decoration: underline;
     color: black;

html-failure-report.lisp

@@ -90,6 +90,8 @@ the string is returned unchanged."
 (defun content-type (file)
   (cond ((equalp (pathname-type file) "css")
          "text/css")
+	((equalp (pathname-type file) "rss")
+	 "application/rss+xml")
         (t
          "text/html")))
 
@@ -119,6 +121,12 @@ the string is returned unchanged."
 (defgeneric system-name (object))
 (defgeneric system-file-name (object))
 (defgeneric failure-report-url (object))
+(defgeneric full-failure-report-url (object)
+  (:method (object)
+    (format nil "http://~A/~A~A"
+	    *failtail-bucket*
+	    (report-prefix)
+	    (failure-report-url object))))
 (defgeneric failure-report-html-file (base object))
 
 (defgeneric stylesheet-path (object))
@@ -186,7 +194,7 @@ the string is returned unchanged."
 (defclass failing-source ()
   ((failure-data
     :initarg :failure-data
-    :reader failure-data)
+    :accessor failure-data)
    (source
     :initarg :source
     :reader source)
@@ -223,7 +231,7 @@ the string is returned unchanged."
 (defclass failure-report ()
   ((failure-data
     :initarg :failure-data
-    :reader failure-data)
+    :accessor failure-data)
    (stylesheet-path
     :initform "failure-report.css"
     :reader stylesheet-path)))
@@ -239,23 +247,70 @@ the string is returned unchanged."
 (defmethod name ((object failure-report))
   "Failure report")
 
+(defun parse-failure-file-name (failure-file)
+  "Parse FAILURE-FILE's namestring into a FAILING-SYSTEM object; if no
+source is found that matches the filename, return nil."
+  ;; Syntax is:
+  ;;   fail_<project>_<system-file-name>_<failing-system-escaped-name>.txt
+  (ppcre:register-groups-bind (source-name system-file-name failing-system)
+      ("^fail_(.*?)_(.*?)_(.*?)\\.txt"
+       (file-namestring failure-file))
+    ;; It's possible that the logfile belongs to a source that is no
+    ;; longer part of Quicklisp (due to renaming, removal, or whatever
+    ;; reason), so don't try to make a failing-source in that case.
+    (let ((source (find-source source-name)))
+      (when source
+	(make-instance 'failing-system
+		       :source (find-source source-name)
+		       :failure-log-file failure-file
+		       :system-file-name system-file-name
+		       :system-name (decode-string-from-filesystem
+				     failing-system))))))
+
+(defun failing-source-log-files ()
+  (let* ((base (translate-logical-pathname "quicklisp-controller:dist;build-cache;"))
+	 (fail-wild (merge-pathnames "**/fail_*_*_*.txt" base)))
+    (directory fail-wild)))
+
+(defun failing-systems ()
+  (remove nil
+	  (mapcar #'parse-failure-file-name
+		  (failing-source-log-files))))
+
+(defun failure-log-failure-report ()
+  "Scan the failure log files of all projects to produce a failure report."
+  (let ((systems (make-hash-table :test 'equal)))
+    (flet ((fsource (source)
+	     (or (gethash (name source) systems)
+		 (setf (gethash (name source) systems)
+		       (make-instance 'failing-source
+				      :failure-data nil
+				      :source source)))))
+      (let ((table (make-hash-table :test 'eq))
+	    (systems (failing-systems))
+	    (report (make-instance 'failure-report
+				   :failure-data '())))
+	(dolist (system systems)
+	  (let ((key (fsource (source system))))
+	    (push system (gethash key table))))
+	(maphash (lambda (failing-source failing-systems)
+		   (setf (failure-data failing-source) failing-systems)
+		   (push failing-source (failure-data report)))
+		 table)
+	report))))
+
 (defmethod failure-data ((object (eql t)))
-  (let ((sources
-         (mapcan (lambda (source)
-                   (let ((failing-source
-                          (find-failing-source source)))
-                     (when failing-source
-                       (list failing-source))))
-                 (all-of-type t))))
-    (make-instance 'failure-report
-                   :failure-data (sort sources
-                                       #'string<
-                                       :key #'name))))
+  (failure-log-failure-report))
+
+(defparameter *log-lines-that-are-boring*
+  (mapcar 'ppcre:create-scanner
+	  '("^WARNING:")))
 
 (defparameter *log-lines-to-highlight*
   (mapcar 'ppcre:create-scanner
           '("^; caught (WARNING|ERROR):"
             " READ error during"
+	    "^Backtrace for"
             "^Unhandled")))
 
 (defparameter *failure-log-reconstitution-patterns*
@@ -267,21 +322,12 @@ the string is returned unchanged."
 
 (defun highlighted-log-line-p (line)
   (loop for scanner in *log-lines-to-highlight*
-        thereis (ppcre:scan scanner line)))
+     thereis (ppcre:scan scanner line)))
+
+(defun boring-log-line-p (line)
+  (loop for scanner in *log-lines-that-are-boring*
+       thereis (ppcre:scan scanner line)))
 
-(defun highlight-log-lines (input-stream output-stream)
-  (loop for line = (read-line input-stream nil)
-        while line
-        do
-        (setf line (cl-who:escape-string line))
-        (setf line (failure-log-reconstitute-line line))
-        (if (highlighted-log-line-p line)
-            (progn
-              (write-string "<strong>" output-stream)
-              (write-string line output-stream)
-              (write-string "</strong>" output-stream))
-            (write-string line output-stream))
-        (terpri output-stream)))
 
 (defmethod write-html-failure-report-header (object stream)
   (format stream "<html><head><title>~A</title>~
@@ -317,14 +363,16 @@ the string is returned unchanged."
     (loop for line = (read-line log-stream nil)
         while line
         do
-        (setf line (cl-who:escape-string line))
-        (if (highlighted-log-line-p line)
-            (progn
-              (write-string "<strong>" stream)
-              (write-string line stream)
-              (write-string "</strong>" stream))
-            (write-string line stream))
-        (terpri stream)))
+	 (setf line (cl-who:escape-string line))
+	 (cond ((highlighted-log-line-p line)
+		(write-string "<strong>" stream)
+		(write-string line stream)
+		(write-string "</strong>" stream)
+		(terpri stream))
+	       ((boring-log-line-p line)
+		(format stream "<span class='boring'>~A~%</span>" line))
+	       (t
+		(write-line line stream)))))
   (format stream "</pre>")
   (format stream "</div>~%"))
 

package.lisp

@@ -1,7 +1,8 @@
 ;;;; package.lisp
 
 (defpackage #:quicklisp-controller
-  (:use #:cl)
+  (:use #:cl
+	#:westbrook)
   (:export #:setup-directories)
   (:shadowing-import-from #:sb-ext
                           #:run-program

quicklisp-controller.asd

@@ -18,7 +18,8 @@
 	       #:cl-who
                #:ubiquitous
                #:githappy
-               #:project-info)
+               #:project-info
+	       #:westbrook)
   :serial t
   :components ((:file "tarhash")
 	       (:file "github-issues")
@@ -28,6 +29,7 @@
                (:file "commands")
                (:file "utils")
                (:file "setup")
+	       (:file "provenance")
                (:file "upstream")
 	       (:file "system-file-magic-cache")
                (:file "dist-cache")
@@ -53,6 +55,7 @@
                (:file "ng-indexes")
 	       (:file "git")
 	       (:file "html-failure-report")
+	       (:file "rss-failure-feeds")
                (:file "recrank")
                (:file "irepl")))
 

recrank.lisp

@@ -2,7 +2,8 @@
 
 (in-package #:quicklisp-controller)
 
-(defun recrank (&key (update t) (report t) (publish-failure-report t)
+(defun recrank (&key (update t) (report t) (feeds t)
+		  (publish-failure-report t)
                   parallel
                 (file #p"quicklisp:tmp;update-failures.txt"))
   (clear-fasl-cache)
@@ -23,7 +24,12 @@
     (with-skipping
       (mock-report :mail t))
     (when (and publish-failure-report (report-publishing-enabled-p))
-      (let ((url (publish-failure-report)))
+      (let* ((report (failure-data t))
+	     (url (publish-failure-report :failure-report report)))
+	(when feeds
+	  (in-anonymous-directory
+	    (write-feeds report "feeds/")
+	    (publish-feeds "feeds/")))
         (write-line url)))))
 
 (defun recrank-to-file (file &rest args &key &allow-other-keys )

rss-failure-feeds.lisp

@@ -0,0 +1,129 @@
+;;;; rss-failure-feeds.lisp
+;;;;
+;;;; Building on the html failure reports, produces a set of feeds so
+;;;; authors and other interested people can subscribe to failures.
+;;;;
+;;;; Each failing source becomes an item in a feed. There are many
+;;;; different feeds - one for each source, one for each author (as
+;;;; far as that can be determined from e.g. github username
+;;;; patterns), and one for everything.
+;;;;
+;;;; The feeds don't have any state. They don't preserve old
+;;;; items. They are created fresh for every run. (This will change if
+;;;; it works poorly in feed readers.)
+;;;;
+;;;; Feeds are written into a directory based on a failure report
+;;;; generated from a (failure-data t) call, then uploaded to the
+;;;; failure report bucket all at once.
+;;;;
+
+(in-package #:quicklisp-controller)
+
+;;; Grouping sources by author (or other criteria)
+
+(defparameter *location-grouping-patterns*
+  '("://github.com/(.*?)/"
+    "://bitbucket.org/(.*?)/"
+    "(kpe.io)"
+    "(xach)"
+    "(wcp).sdf-eu.org"
+    "(nklein)"
+    "gitlab.com/(.*?)/"
+    "(hexstreamsoft)"
+    "(marijnh)averbeke"
+    "(maraist)"
+    "(lichteblau)"
+    "gitlab.common-lisp.net/(.*?)/"))
+
+(defun scan-first-register (pattern target)
+  "Scan TARGET with the regex PATTERN. If there is a match, return the
+  first register grouping."
+  (multiple-value-bind (start end starts ends)
+      (ppcre:scan pattern target)
+    (declare (ignore end))
+    (when (and start (plusp (length starts)))
+      (subseq target (aref starts 0) (aref ends 0)))))
+
+(defun group-name (failing-source)
+  (let ((location (location (source failing-source))))
+    (dolist (pattern *location-grouping-patterns*)
+      (let ((group (scan-first-register pattern location)))
+	(when group
+	  (return group))))))
+
+;;; Producing feeds
+
+(defun item-contents (failing-source)
+  (with-output-to-string (stream)
+    (let ((failures (failure-data failing-source)))
+      (format stream "<p>Project <b>~A</b><p>~%" (name failing-source))
+      (format stream "<p>Taken from <code>~A</code></p>~%"
+	      (first-line-of (source-file (source failing-source))))
+      (format stream "<p>~A</p>~%" (versions-and-such))
+      (format stream "<p>~D failing system~:*~P: ~{~A~^, ~}</p>~%"
+	      (length failures)
+	      (mapcar 'system-name failures))
+      (format stream "<p><a href='~A'>Full build log</a></p>~%"
+	      (full-failure-report-url failing-source)))))
+
+(defun item-title (failing-source)
+  (format nil "~A" (name (source failing-source))))
+
+(defclass failing-source-item (item)
+  ((failing-source
+    :reader failing-source
+    :initarg :failing-source)))
+
+(defun failing-source-item (failing-source)
+  (make-instance 'failing-source-item
+		 :failing-source failing-source
+		 :title (item-title failing-source)
+		 :description (item-contents failing-source)
+		 :guid (full-failure-report-url failing-source)
+		 :link (full-failure-report-url failing-source)))
+
+
+(defun feed-link (group)
+  (format nil "http://report.quicklisp.org/rss/~A.rss" group))
+
+(defun generate-feeds (failure-report)
+  (let ((feeds (make-string-table)))
+    (labels ((ensure-feed (title link)
+	       (let ((feed (gethash title feeds)))
+		 (or feed
+		     (setf (gethash title feeds)
+			   (make-instance 'feed
+					  :pub-date (get-universal-time)
+					  :last-build-date (get-universal-time)
+					  :title title
+					  :link link
+					  :description
+					  (format nil "Quicklisp build failures for ~S"
+						  title)))))))
+      (let ((all (ensure-feed "all" (feed-link "all"))))
+	(dolist (source (failure-data failure-report) feeds)
+	  (let* ((item (failing-source-item source))
+		 (group-name (group-name source)))
+	    (push item (items all))
+	    (when group-name
+	      (push item (items (ensure-feed group-name (feed-link group-name)))))))))))
+
+(defun write-feeds (failure-report output-directory)
+  (let ((feeds (generate-feeds failure-report)))
+    (let ((*default-pathname-defaults* (truename
+					(ensure-directories-exist
+					 output-directory))))
+      (maphash
+       (lambda (name feed)
+	 (generate-to (make-pathname :type "rss" :name name) feed))
+       feeds)
+      *default-pathname-defaults*)))
+
+(defun publish-feeds (feed-directory)
+  (let ((files (directory (make-pathname :name :wild
+					 :type "rss"
+					 :defaults feed-directory))))
+    (dolist (file files)
+      (let ((key (format nil "feeds/~A.rss" (pathname-name file))))
+	(upload-report-file file key)))))
+