branch: main
commit 2702b5c68cdca94085240d0fc2e45afe81219589
Author: Ludovic Courtès <[email protected]>
AuthorDate: Fri Mar 21 11:50:19 2025 +0100
http: Add /pull-requests and don’t show PRs on the home page.
* src/cuirass/http.scm (url-handler): In “GET /” clause, filter out
‘pull-request-specification?’. Pass #:heading to
‘specifications-table’.
Add handlers for “GET /pull-requests” and “GET /merge-requests”.
* src/cuirass/templates.scm (specifications-table): Add #:title
and #:heading and honor them. Remove ‘pull-request?’ and its user. Use
‘pull-request-specification-short-name’ for the first column where
appropriate.
---
src/cuirass/http.scm | 40 +++++++++++++++++++++++++++++++++++++---
src/cuirass/templates.scm | 21 +++++++++++----------
2 files changed, 48 insertions(+), 13 deletions(-)
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index cfb72e4..f976816 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -1225,16 +1225,50 @@ return DEFAULT."
(('GET)
(respond-html (html-page
"Cuirass — Your friendly Guix continuous integration
service."
- (let ((evals (db-get-latest-evaluations)))
+ (let* ((evals (db-get-latest-evaluations))
+ (specs (db-get-specifications))
+ (pulls? (find pull-request-specification? specs)))
(specifications-table
- (db-get-specifications)
+ (remove pull-request-specification? specs)
evals
(db-get-evaluations-absolute-summary
(map evaluation-id evals))
;; Get all the latest evaluations, regardless of their
;; status.
- (db-get-latest-evaluations #:status #f)))
+ (db-get-latest-evaluations #:status #f)
+
+ #:heading (if pulls?
+ `(div (@ (class "alert alert-info"))
+ "This page lists permanent
+jobsets. Pull requests are "
+ (a (@ (href "/pull-requests"))
+ "listed separately")
+ ".")
+ "")))
'())))
+ (('GET "pull-requests")
+ (respond-html (html-page
+ "Pull requests"
+ (let ((evals (db-get-latest-evaluations))
+ (specs (filter pull-request-specification?
+ (db-get-specifications))))
+ (specifications-table
+ specs
+ evals
+ (db-get-evaluations-absolute-summary
+ (map evaluation-id evals))
+ ;; Get all the latest evaluations, regardless of their
+ ;; status.
+ (db-get-latest-evaluations #:status #f)
+
+ #:title "Pull requests"
+ #:heading `(div (@ (class "alert alert-info"))
+ ,(number->string (length specs))
+ " pull requests are being built.")))
+ '())))
+ (('GET "merge-requests")
+ (redirect "/pull-requests"))
+
(('GET "dashboard" id)
(let ((dashboard (db-get-dashboard id)))
(if dashboard
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 67dee32..eb481c7 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -279,7 +279,8 @@ system whose names start with " (code "guile-") ":" (br)
(span (@ (class "text-dark"))
,percentage "%"))))))
-(define (specifications-table specs evaluations summaries latest-evaluations)
+(define* (specifications-table specs evaluations summaries latest-evaluations
+ #:key (title "Specifications") (heading ""))
"Return HTML for the SPECS table."
(define (spec->latest-eval-ok name)
(find (lambda (e)
@@ -304,12 +305,9 @@ system whose names start with " (code "guile-") ":" (br)
0
(nearest-exact-integer (* 100 (/ succeeded total))))))
- (define (pull-request? spec)
- (assq-ref (specification-properties spec) 'pull-request-url))
-
`((div (@ (class "d-flex flex-row mb-3"))
- (div (@ (class "lead mr-auto"))
- "Specifications")
+ (div (@ (class "lead mr-auto")) ,title)
+
,(let ((name "Toggle between success rate and job count"))
`(div
(button (@ (class "btn btn-outline-primary job-toggle mr-1")
@@ -336,6 +334,9 @@ system whose names start with " (code "guile-") ":" (br)
(role "button"))
(i (@ (class "oi oi-rss text-warning py-1"))
"")))))
+
+ ,heading
+
(table
(@ (id "spec-table")
(class "table table-sm table-hover"))
@@ -385,10 +386,10 @@ system whose names start with " (code "guile-") ":" (br)
(a (@ (href "/jobset/"
,(uri-encode (symbol->string
(specification-name spec))))
- (class ,(if (pull-request? spec)
- "text-secondary"
- "text-primary")))
- ,(symbol->string (specification-name spec))))
+ (class "text-primary"))
+ ,(if (pull-request-specification? spec)
+ (pull-request-specification-short-name spec)
+ (symbol->string (specification-name spec)))))
(td
(@ (class "column-build"))
,(match (specification-build spec)
