* [PATCH Cuirass v2] cuirass: Fix handling of SPECIFICATION-NAME.
@ 2024-06-17 15:02 Romain GARBAGE
2024-06-17 15:24 ` Ludovic Courtès
0 siblings, 1 reply; 2+ messages in thread
From: Romain GARBAGE @ 2024-06-17 15:02 UTC (permalink / raw)
To: guix-devel; +Cc: ludovic.courtes, Romain GARBAGE
Fixes a regression introduced in
1da873b0e23eceb3c239dd6dc6781debf23bec63, where the NAME field of the
SPECIFICATION record type is forced to be a symbol as stated by the
documentation.
* src/cuirass/base.scm (jobset-registry): Handle SPECIFICATION-NAME as a
symbol.
* src/cuirass/http.scm (body->specification, specification->json-object, url-handler): Handle SPECIFICATION-NAME as a symbol.
* src/cuirass/templates.scm (specifications-table, specification-edit):
Fix template generation.
---
src/cuirass/base.scm | 4 ++--
src/cuirass/http.scm | 28 +++++++++++++++-------------
src/cuirass/templates.scm | 21 +++++++++++----------
3 files changed, 28 insertions(+), 25 deletions(-)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index 86d2f97..507be5f 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -857,7 +857,7 @@ POLLING-PERIOD seconds."
((_ . actor) actor)))
(loop registry))
(`(update ,spec)
- (let ((name (string->symbol (specification-name spec))))
+ (let ((name (specification-name spec)))
(match (vhash-assq name registry)
(#f
(log-error "cannot update non-existent spec '~s'" name))
@@ -877,7 +877,7 @@ POLLING-PERIOD seconds."
#:polling-period period))
(name (specification-name spec)))
(log-info "registering new jobset '~a'" name)
- (loop (vhash-consq (string->symbol name) monitor
+ (loop (vhash-consq name monitor
registry))))
((_ . monitor)
(log-info "jobset '~a' was already registered"
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 48c506c..44d98d4 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -191,7 +191,7 @@ a <checkout> record."
((mastodon? notif)
`((type . mastodon)))))
- `((name . ,(specification-name spec))
+ `((name . ,(symbol->string (specification-name spec)))
(build . ,(match (specification-build spec)
((? symbol? subset)
subset)
@@ -439,7 +439,8 @@ into a specification record and return it."
((key . param)
(and (eq? key field) param)))
params)))
- (name (assq-ref params 'name))
+ (name (string->symbol
+ (assq-ref params 'name)))
(build (string->symbol
(assq-ref params 'build)))
(build-params (or (and (assq-ref params 'param-select)
@@ -458,7 +459,7 @@ into a specification record and return it."
param)))))))
(channels (map (lambda (name url branch)
(channel
- (name (string->symbol name))
+ (name name)
(url url)
(branch branch)))
(filter-field 'channel-name)
@@ -743,7 +744,7 @@ bogus reply is received, return DEFAULT."
(respond-json-with-error 400 "Jobset already exists."))))
;; Accepted or rejected merge requests receive the same treatment.
((or "close" "merge")
- (let ((spec-name (symbol->string (specification-name spec))))
+ (let ((spec-name (specification-name spec)))
(if (db-get-specification spec-name)
(begin
(db-remove-specification spec-name)
@@ -760,7 +761,7 @@ bogus reply is received, return DEFAULT."
;; treated the same way: the jobset is reevaluated.
;; XXX: Copied and adapted from "/jobset/<spec>/hook/evaluate.
("update"
- (let ((spec-name (symbol->string (specification-name spec))))
+ (let ((spec-name (specification-name spec)))
(if (db-get-specification spec-name)
(if (call-bridge `(trigger-jobset ,(specification-name spec))
bridge)
@@ -817,7 +818,7 @@ bogus reply is received, return DEFAULT."
(build-outputs old-outputs)
(notifications old-notifications)))
- (unless (call-bridge `(update-jobset ,(string->symbol name))
+ (unless (call-bridge `(update-jobset ,name)
bridge)
(log-error "cannot notify bridge of modification of jobset '~a'"
name))
@@ -837,7 +838,7 @@ bogus reply is received, return DEFAULT."
#:body ""))
(('GET "admin" "specifications" "activate" name)
- (if (call-bridge `(activate-jobset ,(string->symbol name))
+ (if (call-bridge `(activate-jobset ,name)
bridge)
(let ((location (string-append "/jobset/" name)))
(respond
@@ -1180,7 +1181,8 @@ bogus reply is received, return DEFAULT."
(respond-dashboard-not-found id))))
(('GET "jobset" name)
(respond-html
- (let* ((evaluation-id-max (db-get-evaluations-id-max name))
+ (let* ((name (string->symbol name))
+ (evaluation-id-max (db-get-evaluations-id-max name))
(evaluation-id-min (db-get-evaluations-id-min name))
(params (request-parameters request))
(border-high (assq-ref params 'border-high))
@@ -1192,13 +1194,13 @@ bogus reply is received, return DEFAULT."
(absolute-summary
(db-get-evaluations-absolute-summary evaluations))
(active?
- (call-bridge `(active-jobset? ,(string->symbol name))
+ (call-bridge `(active-jobset? ,name)
bridge #t))
(last-updates
- (call-bridge `(jobset-last-update-times ,(string->symbol name))
+ (call-bridge `(jobset-last-update-times ,name)
bridge)))
(html-page
- (string-append "Jobset " name)
+ (string-append "Jobset " (symbol->string name))
(evaluation-info-table name
evaluations
evaluation-id-min
@@ -1210,7 +1212,7 @@ bogus reply is received, return DEFAULT."
#:last-update-times
last-updates)
`(((#:name . ,name)
- (#:link . ,(string-append "/jobset/" name))))))))
+ (#:link . ,(string-append "/jobset/" (symbol->string name)))))))))
(('GET "eval" "latest")
(let* ((params (request-parameters request))
@@ -1405,7 +1407,7 @@ bogus reply is received, return DEFAULT."
(let* ((spec (db-get-specification spec))
(name (and spec (specification-name spec))))
(if spec
- (if (call-bridge `(trigger-jobset ,(string->symbol name))
+ (if (call-bridge `(trigger-jobset ,name)
bridge)
(respond-json (scm->json-string `((jobset . ,name))))
(begin
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 54a10c1..d49c868 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -378,8 +378,8 @@ system whose names start with " (code "guile-") ":" (br)
(td
(@ (class "column-name"))
(a (@ (href "/jobset/"
- ,(specification-name spec)))
- ,(specification-name spec)))
+ ,(symbol->string (specification-name spec))))
+ ,(symbol->string (specification-name spec))))
(td
(@ (class "column-build"))
,(match (specification-build spec)
@@ -422,11 +422,11 @@ system whose names start with " (code "guile-") ":" (br)
(style "vertical-align: middle"))
,@(let* ((summary
(and=> (spec->latest-eval-ok
- (specification-name spec))
+ (symbol->string (specification-name spec)))
eval-summary))
(last-eval
(spec->latest-eval
- (specification-name spec)))
+ (symbol->string (specification-name spec))))
(last-eval-status-ok?
(and last-eval
(<= (evaluation-current-status last-eval)
@@ -455,7 +455,7 @@ system whose names start with " (code "guile-") ":" (br)
(else '()))))
(td
(@ (class "column-action"))
- ,@(let* ((name (specification-name spec))
+ ,@(let* ((name (symbol->string (specification-name spec)))
(dashboard-name
(string-append "Dashboard " name)))
`((a (@ (href "/eval/latest/dashboard?spec="
@@ -468,10 +468,10 @@ system whose names start with " (code "guile-") ":" (br)
,(let ((id
(string-append
"specDropdown-"
- (specification-name spec)))
+ (symbol->string (specification-name spec))))
(name
(string-append "Options "
- (specification-name spec))))
+ (symbol->string (specification-name spec)))))
`(div
(@ (id ,id)
(title ,name)
@@ -490,12 +490,12 @@ system whose names start with " (code "guile-") ":" (br)
(li (@ (role "menuitem"))
(a (@ (class "dropdown-item")
(href "/specification/edit/"
- ,(specification-name spec)))
+ ,(symbol->string (specification-name spec))))
" Edit"))
(li (@ (role "menuitem"))
(a (@ (class "dropdown-item")
(href "/admin/specifications/deactivate/"
- ,(specification-name spec)))
+ ,(symbol->string (specification-name spec))))
" Deactivate"))))))))
specs)))))))
@@ -569,7 +569,8 @@ the existing SPEC otherwise."
'("")
rest)))))))
- (let ((name (and spec (specification-name spec)))
+ (let ((name (and spec (symbol->string
+ (specification-name spec))))
(build (and spec (match (specification-build spec)
((? symbol? build) build)
((build _ ...) build))))
--
2.45.1
^ permalink raw reply related [flat|nested] 2+ messages in thread
* Re: [PATCH Cuirass v2] cuirass: Fix handling of SPECIFICATION-NAME.
2024-06-17 15:02 [PATCH Cuirass v2] cuirass: Fix handling of SPECIFICATION-NAME Romain GARBAGE
@ 2024-06-17 15:24 ` Ludovic Courtès
0 siblings, 0 replies; 2+ messages in thread
From: Ludovic Courtès @ 2024-06-17 15:24 UTC (permalink / raw)
To: Romain GARBAGE; +Cc: guix-devel
Romain GARBAGE <romain.garbage@inria.fr> skribis:
> Fixes a regression introduced in
> 1da873b0e23eceb3c239dd6dc6781debf23bec63, where the NAME field of the
> SPECIFICATION record type is forced to be a symbol as stated by the
> documentation.
>
> * src/cuirass/base.scm (jobset-registry): Handle SPECIFICATION-NAME as a
> symbol.
> * src/cuirass/http.scm (body->specification, specification->json-object, url-handler): Handle SPECIFICATION-NAME as a symbol.
> * src/cuirass/templates.scm (specifications-table, specification-edit):
> Fix template generation.
Applied with minor tweaks to the commit log. Thank you!
Ludo’.
^ permalink raw reply [flat|nested] 2+ messages in thread
end of thread, other threads:[~2024-06-17 15:25 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-06-17 15:02 [PATCH Cuirass v2] cuirass: Fix handling of SPECIFICATION-NAME Romain GARBAGE
2024-06-17 15:24 ` Ludovic Courtès
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).