[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Ludovic Courtès |
|
Date: |
Thu, 11 Jan 2024 17:44:36 -0500 (EST) |
branch: master
commit 7bcd3d079f0ec45ac50f0dbc14eb4ec68c6a6b53
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Jan 11 23:24:40 2024 +0100
Display last repository update time on /jobset/NAME pages.
* src/cuirass/base.scm (jobset-monitor): Wrap communication with
UPDATE-SERVICE in ‘spawn-fiber’. Handle ‘last-update-times’ messages.
* src/cuirass/http.scm (url-handler): For /jobset/NAME requests, send
BRIDGE a ‘jobset-last-update-times’ request and pass the result to
‘evaluate-info-table’.
* src/cuirass/scripts/register.scm (bridge): Handle
‘jobset-last-update-times’ requests.
* src/cuirass/templates.scm (evaluation-info-table): Add #:last-update-times
and honor it.
---
src/cuirass/base.scm | 35 +++++++++++++++++++++++------------
src/cuirass/http.scm | 18 +++++++++++++++---
src/cuirass/scripts/register.scm | 13 ++++++++++++-
src/cuirass/templates.scm | 16 ++++++++++++++--
4 files changed, 64 insertions(+), 18 deletions(-)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 92c67d0..638565f 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -750,18 +750,23 @@ concurrently; it sends derivation build requests to
BUILDER."
name)
(loop spec last-updates))
(begin
- (match (let ((reply (make-channel)))
- (log-info "fetching channels for spec '~a'" name)
- (put-message update-service
- `(fetch ,channels ,reply))
- (get-message reply))
- (#f
- (log-warning "failed to fetch channels for '~a'" name))
- (instances
- (log-info "fetched channels for '~a':~{ ~a~}"
- name (map channel-name channels))
- (put-message evaluator
- `(evaluate ,spec ,instances ,timestamp))))
+ ;; Fetch concurrently so the monitor can keep responding.
+ (spawn-fiber
+ (lambda ()
+ (match (let ((reply (make-channel)))
+ (log-info "fetching channels for spec '~a'" name)
+ (put-message update-service
+ `(fetch ,channels ,reply))
+ (get-message reply))
+ (#f
+ ;; TODO: Send the error to CHANNEL so the web interface
+ ;; can query it and display it.
+ (log-warning "failed to fetch channels for '~a'" name))
+ (instances
+ (log-info "fetched channels for '~a':~{ ~a~}"
+ name (map channel-name channels))
+ (put-message evaluator
+ `(evaluate ,spec ,instances ,timestamp))))))
(loop spec
(cons timestamp (take-while recent? last-updates)))))))
@@ -780,6 +785,9 @@ concurrently; it sends derivation build requests to
BUILDER."
(`(update-spec ,spec)
(log-info "updating spec of jobset '~a'" name)
(loop spec last-updates))
+ (`(last-update-times ,reply)
+ (put-message reply last-updates)
+ (loop spec last-updates))
(message
(log-warning "jobset '~a' got bogus message: ~s"
name message)
@@ -788,6 +796,9 @@ concurrently; it sends derivation build requests to
BUILDER."
(`(update-spec ,spec)
(log-info "updating spec of inactive jobset '~a'" name)
(loop spec last-updates))
+ (`(last-update-times ,reply)
+ (put-message reply last-updates)
+ (loop spec last-updates))
(message
(log-warning "inactive jobset '~a' got unexpected message: ~s"
name message)
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index b4fc574..1c92ae2 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -1,7 +1,7 @@
;;;; http.scm -- HTTP API
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017, 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
-;;; Copyright © 2018, 2019, 2020, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2020, 2023-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
;;; Copyright © 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
@@ -1045,13 +1045,25 @@ passed, only display JOBS targeting this SYSTEM."
border-low
border-high))
(absolute-summary
- (db-get-evaluations-absolute-summary evaluations)))
+ (db-get-evaluations-absolute-summary evaluations))
+ (last-updates
+ (if bridge
+ (begin
+ (write `(jobset-last-update-times ,(string->symbol name))
+ bridge)
+ (newline bridge)
+ (match (read bridge)
+ (`(reply ,times) times)
+ (_ #f)))
+ #f)))
(html-page name (evaluation-info-table name
evaluations
evaluation-id-min
evaluation-id-max
#:absolute-summary
- absolute-summary)
+ absolute-summary
+ #:last-update-times
+ last-updates)
`(((#:name . ,name)
(#:link . ,(string-append "/jobset/" name))))))))
diff --git a/src/cuirass/scripts/register.scm b/src/cuirass/scripts/register.scm
index 80de26b..b1b77fd 100644
--- a/src/cuirass/scripts/register.scm
+++ b/src/cuirass/scripts/register.scm
@@ -1,7 +1,7 @@
;;;; cuirass -- continuous integration tool
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <othacehe@gnu.org>
-;;; Copyright © 2018, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2023-2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of Cuirass.
@@ -140,6 +140,17 @@
(lambda ()
(log-info "triggering jobset '~a'" name)
(put-message jobset 'trigger))))))
+ (`(jobset-last-update-times ,name)
+ (match (lookup-jobset registry name)
+ (#f
+ (log-warning "requested jobset '~a' not found" name)
+ (write `(reply #f) socket))
+ (jobset
+ (log-debug "requesting update times of jobset '~a'" name)
+ (let ((reply (make-channel)))
+ (put-message jobset `(last-update-times ,reply))
+ (write `(reply ,(get-message reply)) socket))))
+ (newline socket))
(_
#f))
(loop (+ 1 count))))))
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 8624603..2ade912 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -1006,9 +1006,12 @@ the existing SPEC otherwise."
status))))))
(define* (evaluation-info-table name evaluations id-min id-max
- #:key absolute-summary)
+ #:key absolute-summary last-update-times)
"Return HTML for the EVALUATION table NAME. ID-MIN and ID-MAX are
- global minimal and maximal id."
+global minimal and maximal id.
+
+Optionally, LAST-UPDATE-TIMES is a list of times at which the repositories of
+NAME have been checked; it is #f when that information is unavailable."
(define (eval-absolute-summary eval)
(find (lambda (e)
(= (evaluation-summary-id e)
@@ -1018,6 +1021,7 @@ the existing SPEC otherwise."
`((div (@ (class "d-flex flex-row mb-3"))
(div (@ (class "lead mr-auto"))
"Evaluations of " ,name)
+
,(let ((name "Toggle between build changes and build overview"))
`(div
(button (@ (class "btn btn-outline-primary job-toggle mr-1")
@@ -1036,6 +1040,14 @@ the existing SPEC otherwise."
(i (@ (class "oi oi-rss text-warning py-1")
(aria-hidden "true"))
"")))))
+
+ ,(match last-update-times
+ ((time _ ...)
+ `(div (@ (class "alert alert-info"))
+ "Last repository check: "
+ ,(time->string time) "."))
+ (_ ""))
+
(table
(@ (class "table table-sm table-hover table-striped"))
,@(if (null? evaluations)