From f8ddf8ca096ae099828b4fb916326fbac12d3a26 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Tue, 2 Feb 2021 11:58:29 +0100
Subject: [PATCH] Add basic RSS support.
* src/cuirass/rss.scm: New file.
* Makefile.am (dist_pkgmodule_DATA): Add it.
* src/cuirass/http.scm (url-handler): Add "/events/rss" route.
---
Makefile.am | 1 +
src/cuirass/http.scm | 9 +++
src/cuirass/rss.scm | 178 +++++++++++++++++++++++++++++++++++++++++++
3 files changed, 188 insertions(+)
create mode 100644 src/cuirass/rss.scm
diff --git a/Makefile.am b/Makefile.am
index 2a4ed30d..9cc0bb23 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -57,6 +57,7 @@ dist_pkgmodule_DATA = \
src/cuirass/remote.scm \
src/cuirass/remote-server.scm \
src/cuirass/remote-worker.scm \
+ src/cuirass/rss.scm \
src/cuirass/send-events.scm \
src/cuirass/ui.scm \
src/cuirass/utils.scm \
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index fd63c7df..743756d6 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -29,6 +29,7 @@
#:use-module (cuirass utils)
#:use-module (cuirass logging)
#:use-module (cuirass remote)
+ #:use-module (cuirass rss)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
@@ -660,6 +661,14 @@ Hydra format."
(respond-json-with-error 500 "No build found.")))
(respond-json-with-error 500 "Query parameter not provided."))))
+ (('GET "events" "rss")
+ (let* ((params (request-parameters request)))
+ (respond-html (rss-feed (db-get-builds `((weather . new)
+ (nr . 100)
+ (order . evaluation)
+ ,@params))
+ #:params params))))
+
(('GET "workers")
(respond-html
(html-page
diff --git a/src/cuirass/rss.scm b/src/cuirass/rss.scm
new file mode 100644
index 00000000..b5e8797a
--- /dev/null
+++ b/src/cuirass/rss.scm
@@ -0,0 +1,178 @@
+;;; rss.scm -- RSS feed builder.
+;;; Copyright 漏 2021 Mathieu Othacehe <othacehe@gnu.org>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass rss)
+ #:use-module (cuirass database)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:use-module (sxml simple)
+ #:use-module (ice-9 hash-table)
+ #:use-module (ice-9 match)
+ #:export (rss-feed))
+
+;; This module is inspired by the (haunt builder rss) module that is part of
+;; the Haunt static site generator and writen by Christopher Lemmer Webber.
+
+(define %void-elements
+ '(area
+ base
+ br
+ col
+ command
+ embed
+ hr
+ img
+ input
+ keygen
+ link
+ meta
+ param
+ source
+ track
+ wbr))
+
+(define (void-element? tag)
+ "Return #t if TAG is a void element."
+ (pair? (memq tag %void-elements)))
+
+(define %escape-chars
+ (alist->hash-table
+ '((#\" . "quot")
+ (#\& . "amp")
+ (#\< . "lt")
+ (#\> . "gt"))))
+
+(define (string->escaped-html s port)
+ "Write the HTML escaped form of S to PORT."
+ (define (escape c)
+ (let ((escaped (hash-ref %escape-chars c)))
+ (if escaped
+ (format port "&~a;" escaped)
+ (display c port))))
+ (string-for-each escape s))
+
+(define (object->escaped-html obj port)
+ "Write the HTML escaped form of OBJ to PORT."
+ (string->escaped-html
+ (call-with-output-string (cut display obj <>))
+ port))
+
+(define (attribute-value->html value port)
+ "Write the HTML escaped form of VALUE to PORT."
+ (if (string? value)
+ (string->escaped-html value port)
+ (object->escaped-html value port)))
+
+(define (attribute->html attr value port)
+ "Write ATTR and VALUE to PORT."
+ (format port "~a=\"" attr)
+ (attribute-value->html value port)
+ (display #\" port))
+
+(define (element->html tag attrs body port)
+ "Write the HTML TAG to PORT, where TAG has the attributes in the
+list ATTRS and the child nodes in BODY."
+ (format port "<~a" tag)
+ (for-each (match-lambda
+ ((attr value)
+ (display #\space port)
+ (attribute->html attr value port)))
+ attrs)
+ (if (and (null? body) (void-element? tag))
+ (display " />" port)
+ (begin
+ (display #\> port)
+ (for-each (cut sxml->html <> port) body)
+ (format port "</~a>" tag))))
+
+(define (doctype->html doctype port)
+ (format port "<!DOCTYPE ~a>" doctype))
+
+(define* (sxml->html tree #:optional (port (current-output-port)))
+ "Write the serialized HTML form of TREE to PORT."
+ (match tree
+ (() *unspecified*)
+ (('doctype type)
+ (doctype->html type port))
+ (((? symbol? tag) ('@ attrs ...) body ...)
+ (element->html tag attrs body port))
+ (((? symbol? tag) body ...)
+ (element->html tag '() body port))
+ ((nodes ...)
+ (for-each (cut sxml->html <> port) nodes))
+ ((? string? text)
+ (string->escaped-html text port))
+ ;; Render arbitrary Scheme objects, too.
+ (obj (object->escaped-html obj port))))
+
+(define (sxml->html-string sxml)
+ "Render SXML as an HTML string."
+ (call-with-output-string
+ (lambda (port)
+ (sxml->html sxml port))))
+
+(define (date->rfc822-str date)
+ (date->string date "~a, ~d ~b ~Y ~T ~z"))
+
+(define* (build->rss-item build)
+ "Convert BUILD into an RSS <item> node."
+ (let* ((id (assq-ref build #:id))
+ (job-name (assq-ref build #:job-name))
+ (specification (assq-ref build #:specification))
+ (weather (assq-ref build #:weather))
+ (weather-text (cond
+ ((= weather (build-weather new-success))
+ "fixed")
+ ((= weather (build-weather new-failure))
+ "broken")))
+ (stoptime (assq-ref build #:stoptime)))
+ `(item
+ (title
+ ,(format #f "Build ~a on ~a is ~a."
+ job-name specification weather-text))
+ (author "Cuirass")
+ (pubDate ,(date->rfc822-str
+ (time-utc->date
+ (make-time time-utc 0 stoptime))))
+ (link "../../build/" ,id "/details")
+ (description
+ ,(sxml->html-string
+ `(p "The build " (b ,job-name) " for specification "
+ (b ,specification) " is " ,weather-text ".
+You can find the detailed information about this build "
+ (a (@ (href ,(string-append "../../build/"
+ (number->string id)
+ "/details")))
+ "here")
+ "."))))))
+
+(define* (rss-feed builds #:key base-url params)
+ (let ((specification (and params
+ (assq-ref params 'specification))))
+ `(rss (@ (version "2.0"))
+ (channel
+ (title "GNU Guix continuous integration system build events.")
+ (description
+ ,(string-append
+ "Build events for "
+ (if specification
+ (string-append "specification " specification ".")
+ "all specifications.")))
+ (pubDate ,(date->rfc822-str (current-date)))
+ (link (@ (href "/")))
+ ,@(map build->rss-item builds)))))
--
GitLab