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