unofficial mirror of guix-devel@gnu.org 
 help / color / mirror / code / Atom feed
* [PATCH Cuirass] cuirass: Fix handling of SPECIFICATION-NAME.
@ 2024-06-17 12:44 Romain GARBAGE
  2024-06-17 13:42 ` Ludovic Courtès
  0 siblings, 1 reply; 3+ messages in thread
From: Romain GARBAGE @ 2024-06-17 12:44 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: Handle SPECIFICATION-NAME as a symbol.
* src/cuirass/http.scm: Handle SPECIFICATION-NAME as a symbol.
* src/cuirass/templates.scm: Fix template generation.
---
 src/cuirass/base.scm      |  4 ++--
 src/cuirass/http.scm      |  6 +++---
 src/cuirass/templates.scm | 21 +++++++++++----------
 3 files changed, 16 insertions(+), 15 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..092eca1 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)
@@ -743,7 +743,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 +760,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)
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] 3+ messages in thread

end of thread, other threads:[~2024-06-17 15:03 UTC | newest]

Thread overview: 3+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-06-17 12:44 [PATCH Cuirass] cuirass: Fix handling of SPECIFICATION-NAME Romain GARBAGE
2024-06-17 13:42 ` Ludovic Courtès
2024-06-17 15:02   ` Romain GARBAGE

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).