[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[no subject]
|
From: |
Mathieu Othacehe |
|
Date: |
Thu, 11 Mar 2021 13:32:03 -0500 (EST) |
branch: master
commit b24d55e368002fe34e74d6b53858e023e9ee3ddb
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Thu Mar 11 19:31:35 2021 +0100
Add specification creation and edition pages.
---
Makefile.am | 3 +-
src/cuirass/http.scm | 128 +++++++++++++++++++------
src/cuirass/templates.scm | 196 ++++++++++++++++++++++++++++++++++++--
src/static/js/jquery-3.6.0.min.js | 2 +
4 files changed, 295 insertions(+), 34 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index bf3b99d..545d49e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -102,7 +102,8 @@ dist_images_DATA = \
src/static/images/guix.png \
src/static/images/icon.png
dist_js_DATA = \
- src/static/js/chart.js
+ src/static/js/chart.js \
+ src/static/js/jquery-3.6.0.min.js
TEST_EXTENSIONS = .scm .sh
AM_TESTS_ENVIRONMENT = \
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 07f92ad..13ecd45 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -50,6 +50,7 @@
#:use-module (sxml simple)
#:use-module (cuirass templates)
#:use-module (guix channels)
+ #:use-module (guix packages)
#:use-module (guix progress)
#:use-module (guix utils)
#:use-module ((guix store) #:select (%store-prefix))
@@ -82,7 +83,8 @@
"fonts/open-iconic.woff"
"images/icon.png"
"images/guix.png"
- "js/chart.js"))
+ "js/chart.js"
+ "js/jquery-3.6.0.min.js"))
(define (build->hydra-build build)
"Convert BUILD to an assoc list matching hydra API format."
@@ -342,6 +344,50 @@ Hydra format."
zabbix-info)
'())))
+(define (body->specification body)
+ "Turn BODY containing the input parameters of an HTML specification form
+into a specification record and return it."
+ (let* ((query (utf8->string body))
+ (params (fold-right
+ (lambda (param params)
+ (match (string-split param #\=)
+ ((key param)
+ (cons (cons (string->symbol key) param)
+ params))))
+ '()
+ (string-split query #\&)))
+ (filter-field (lambda (field)
+ (filter-map (match-lambda
+ ((key . param)
+ (and (eq? key field) param)))
+ params)))
+ (name (assq-ref params 'name))
+ (build (string->symbol
+ (assq-ref params 'build)))
+ (channels (map (lambda (name url branch)
+ (channel
+ (name name)
+ (url (uri-decode url))
+ (branch branch)))
+ (filter-field 'channel-name)
+ (filter-field 'channel-url)
+ (filter-field 'channel-branch)))
+ (priority (string->number
+ (assq-ref params 'priority)))
+ (systems (fold
+ (lambda (system systems)
+ (if (assoc (string->symbol system) params)
+ (cons system systems)
+ systems))
+ '()
+ %cuirass-supported-systems)))
+ (specification
+ (name name)
+ (build build)
+ (channels channels)
+ (priority priority)
+ (systems systems))))
+
;;;
;;; Web server.
@@ -413,11 +459,11 @@ Hydra format."
;; PATH is a list of path components
(let ((file-name (string-join path "/"))
(file-path (string-join (cons* (%static-directory) path) "/")))
- (if (and (member file-name %file-white-list)
+ (if (and (member file-name %file-white-list)
(file-exists? file-path)
(not (file-is-directory? file-path)))
- (respond-file file-path)
- (respond-not-found file-name))))
+ (respond-file file-path)
+ (respond-not-found file-name))))
(define (respond-gzipped-file file)
;; Return FILE with 'gzip' content-encoding.
@@ -459,30 +505,42 @@ Hydra format."
(match (cons (request-method request)
(request-path-components request))
- (('POST "admin" "specifications" "add")
- (match (string-split (utf8->string body) #\=)
- (("spec-name" name)
- (db-add-specification
- (specification
- (name name)
- (build 'all)
- (channels
- (list (channel
- (inherit %default-guix-channel)
- (branch name))))
- (systems '("x86_64-linux" "i686-linux" "aarch64-linux"))))
- (respond (build-response #:code 302
- #:headers
- `((location . ,(string->uri-reference
- "/admin/specifications"))))
- #:body ""))))
+ (('POST "admin" "specification" "add")
+ (let* ((spec (body->specification body))
+ (name (specification-name spec)))
+ (if (db-get-specification name)
+ (respond-html
+ (html-page
+ "Creation error"
+ `(div (@ (class "alert alert-danger"))
+ ,(format #f "Specification ~a already exists" name))
+ '())
+ #:code 400)
+ (begin
+ (db-add-or-update-specification spec)
+ (respond
+ (build-response #:code 302
+ #:headers
+ `((location . ,(string->uri-reference "/"))))
+ #:body "")))))
+
+ (('POST "admin" "specification" "edit")
+ (let* ((spec (body->specification body))
+ (name (specification-name spec)))
+ (db-add-or-update-specification spec)
+ (respond
+ (build-response #:code 302
+ #:headers
+ `((location . ,(string->uri-reference "/"))))
+ #:body "")))
+
(('GET "admin" "specifications" "delete" name)
(db-remove-specification name)
- (respond (build-response #:code 302
- #:headers
- `((location . ,(string->uri-reference
- "/admin/specifications"))))
- #:body ""))
+ (respond
+ (build-response #:code 302
+ #:headers
+ `((location . ,(string->uri-reference "/"))))
+ #:body ""))
(('GET "admin" "build" id "restart")
(db-restart-build! (string->number id))
(respond
@@ -533,6 +591,22 @@ Hydra format."
(list->vector
(map specification->json-object
(db-get-specifications))))))
+
+ (('GET "specification" "add")
+ (respond-html
+ (html-page
+ "Add specification"
+ (specification-edit)
+ '())))
+
+ (('GET "specification" "edit" name)
+ (let ((spec (db-get-specification name)))
+ (respond-html
+ (html-page
+ "Edit specification"
+ (specification-edit spec)
+ '()))))
+
(('GET "build" id)
(let* ((build (if (string-suffix? ".drv" id)
(string-append (%store-prefix) "/" id)
@@ -768,7 +842,7 @@ Hydra format."
(('GET "events" "rss")
(let* ((params (request-parameters request))
(specification (and params
- (assq-ref params 'specification))))
+ (assq-ref params 'specification))))
(respond-xml
(rss-feed
(db-get-builds `((weather . new)
diff --git a/src/cuirass/templates.scm b/src/cuirass/templates.scm
index 32448cd..80f506c 100644
--- a/src/cuirass/templates.scm
+++ b/src/cuirass/templates.scm
@@ -30,6 +30,7 @@
#:use-module (web uri)
#:use-module (guix channels)
#:use-module (guix derivations)
+ #:use-module (guix packages)
#:use-module (guix progress)
#:use-module (guix store)
#:use-module ((guix utils) #:select (string-replace-substring
@@ -41,6 +42,7 @@
#:use-module (cuirass specification)
#:export (html-page
specifications-table
+ specification-edit
evaluation-info-table
build-eval-table
build-search-results-table
@@ -213,13 +215,23 @@ system whose names start with " (code "guile-") ":" (br)
(span (@(class "oi oi-rss text-warning align-right")
(title "RSS")
(aria-hidden "true"))
- ""))))
+ "")))
+ (a (@ (class "btn btn-outline-primary mr-1 float-right")
+ (href "/specification/add/")
+ (role "button"))
+ (span (@(class "oi oi-plus text-primary align-right")
+ (title "Add")
+ (aria-hidden "true"))
+ "")))
(table
(@ (class "table table-sm table-hover"))
,@(if (null? specs)
`((th (@ (scope "col")) "No elements here."))
`((thead (tr (th (@ (scope "col")) Name)
+ (th (@ (scope "col")) Build)
(th (@ (scope "col")) Channels)
+ (th (@ (scope "col")) Priority)
+ (th (@ (scope "col")) Systems)
(th (@ (scope "col")) Action)))
(tbody
,@(map
@@ -227,12 +239,20 @@ system whose names start with " (code "guile-") ":" (br)
`(tr (td (a (@ (href "/jobset/"
,(specification-name spec)))
,(specification-name spec)))
+ (td ,(symbol->string
+ (specification-build spec)))
(td ,(string-join
(map (lambda (channel)
(format #f "~a (on ~a)"
(channel-name channel)
(channel-branch channel)))
(specification-channels spec)) ", "))
+ (td ,(number->string
+ (specification-priority spec)))
+ (td ,(string-join
+ (sort (specification-systems spec)
+ string<?)
+ ", "))
(td
(div
(@ (class "dropdown"))
@@ -244,12 +264,176 @@ system whose names start with " (code "guile-") ":" (br)
(aria-expanded "false"))
" ")
(div (@ (class "dropdown-menu"))
- (a (@ (class "oi oi-lock-locked dropdown-item")
+ (a (@ (class "dropdown-item")
+ (href "/specification/edit/"
+ ,(specification-name spec)))
+ " Edit")
+ (a (@ (class "dropdown-item")
(href "/admin/specifications/delete/"
,(specification-name spec)))
" Delete"))))))
specs)))))))
+(define* (specification-edit #:optional spec)
+ "Return HTML to add a new specification if no argument is passed, or to edit
+the existing SPEC otherwise."
+ (define (channels->html channels)
+ (let ((html
+ (fold
+ (lambda (channel html)
+ (let ((first-row? (null? html))
+ (name (channel-name channel))
+ (url (channel-url channel))
+ (branch (channel-branch channel)))
+ (cons
+ `(div (@ (class ,(if first-row?
+ "form-group row channel"
+ "form-group row channel-new")))
+ (label (@ (for "name")
+ (class "col-sm-2 col-form-label"))
+ ,(if first-row? "Channels" ""))
+ (div (@ (class "col-sm-2"))
+ (input
+ (@ (type "text")
+ (class "form-control")
+ (id "channel-name")
+ (name "channel-name")
+ (placeholder "name")
+ (value ,name))))
+ (div (@ (class "col-sm-4"))
+ (input
+ (@ (type "text")
+ (class "form-control")
+ (id "channel-url")
+ (name "channel-url")
+ (placeholder "url")
+ (value ,url))))
+ (div (@ (class "col-sm-2"))
+ (input
+ (@ (type "text")
+ (class "form-control")
+ (id "channel-branch")
+ (name "channel-branch")
+ (placeholder "branch")
+ (value ,branch))))
+ ,@(if first-row?
+ '((a (@ (class "btn btn-success add-channel")
+ (href "#")
+ (role "button"))
+ "Add"))
+ '((a (@ (class "btn btn-danger remove-channel")
+ (href "#")
+ (role "button"))
+ "Remove"))))
+ html)))
+ '()
+ channels)))
+ (match (reverse html)
+ ((first . rest)
+ (list first `(div (@ (class "channels")) ,@rest))))))
+
+ (let ((name (and spec (specification-name spec)))
+ (build (and spec (specification-build spec)))
+ (channels (and spec (specification-channels spec)))
+ (priority (and spec (specification-priority spec)))
+ (systems (and spec (specification-systems spec))))
+ `(span
+ (p (@ (class "lead"))
+ ,(if spec
+ (format #f "Edit ~a specification" name)
+ "Create a new specification"))
+ (script (@ (src "/static/js/jquery-3.6.0.min.js")))
+ (script "
+$(document).ready(function() {
+var counter = 0;
+$('.remove-channel').click(function() {
+ $(this).parent().remove();
+});
+$('.add-channel').click(function() {
+ var clone = $('.channel').clone();
+ clone.attr('class', 'form-group row channel-new');
+ clone.find('.col-form-label').text('');
+
+ var new_button = clone.find('.add-channel');
+ new_button.attr('class', 'btn btn-danger remove-channel');
+ new_button.text('Remove');
+ new_button.click(function() {
+ $(this).parent().remove();
+ });
+ clone.appendTo('.channels');
+});
+})")
+ (form (@ (id "add-specification")
+ ,@(if spec
+ '((action "/admin/specification/edit"))
+ '((action "/admin/specification/add")))
+ (method "POST"))
+ (div (@ (class "form-group row"))
+ (label (@ (for "name")
+ (class "col-sm-2 col-form-label"))
+ "Name")
+ (div (@ (class "col-sm-4"))
+ (input (@ (type "text")
+ (class "form-control")
+ (id "name")
+ (name "name")
+ (value ,(or name ""))
+ ,@(if spec
+ '((readonly))
+ '())))))
+ (div (@ (class "form-group row"))
+ (label (@ (for "build")
+ (class "col-sm-2 col-form-label"))
+ "Build")
+ (div (@ (class "col-sm-4"))
+ (select
+ (@ (class "form-control")
+ (id "build")
+ (name "build"))
+ ,@(map (lambda (type)
+ `(option (@ ,@(if (eq? type build)
+ '((selected))
+ '()))
+ ,(symbol->string type)))
+ %build-types))))
+ ,@(channels->html
+ (if spec channels (list %default-guix-channel)))
+ (div (@ (class "form-group row"))
+ (label (@ (for "priority")
+ (class "col-sm-2 col-form-label"))
+ "Priority")
+ (div (@ (class "col-sm-4"))
+ (input
+ (@ (type "number")
+ (class "form-control")
+ (id "priority")
+ (name "priority")
+ (value ,(or priority 9))))))
+ (div (@ (class "form-group row"))
+ (label (@ (for "systems")
+ (class "col-sm-2 col-form-label"))
+ "Systems")
+ ,@(map (lambda (system)
+ `(div (@ (class "form-check form-check-inline"))
+ (input (@ (class "form-check-input")
+ (type "checkbox")
+ (id ,system)
+ (name ,system)
+ ,@(if (and systems
+ (member system systems))
+ '((checked))
+ '())))
+ (label (@ (class "form-check-label")
+ (for ,system))
+ ,system)))
+ %cuirass-supported-systems))
+ (div (@ (class "form-group row"))
+ (div (@ (class "col-sm-4"))
+ (button
+ (@ (type "submit")
+ (class "btn btn-primary"))
+ " Submit")))))))
+
(define (build-details build products history)
"Return HTML showing details for the BUILD."
(define status (assq-ref build #:status))
@@ -303,7 +487,7 @@ system whose names start with " (code "guile-") ":" (br)
(aria-expanded "false"))
"Action")
(div (@ (class "dropdown-menu"))
- (a (@ (class "oi oi-lock-locked dropdown-item")
+ (a (@ (class "dropdown-item")
(href "/admin/build/"
,(assq-ref build #:id) "/restart"))
" Restart"))))
@@ -517,17 +701,17 @@ system whose names start with " (code "guile-") ":" (br)
(aria-expanded "false"))
" ")
(div (@ (class "dropdown-menu"))
- (a (@ (class "oi oi-lock-locked dropdown-item")
+ (a (@ (class "dropdown-item")
(href "/admin/evaluation/"
,(assq-ref row #:id)
"/cancel"))
" Cancel pending builds")
- (a (@ (class "oi oi-lock-locked dropdown-item")
+ (a (@ (class "dropdown-item")
(href "/admin/evaluation/"
,(assq-ref row #:id)
"/restart"))
" Restart all builds")
- (a (@ (class "oi oi-lock-locked dropdown-item")
+ (a (@ (class "dropdown-item")
(href "/admin/evaluation/"
,(assq-ref row #:id)
"/retry"))
diff --git a/src/static/js/jquery-3.6.0.min.js
b/src/static/js/jquery-3.6.0.min.js
new file mode 100644
index 0000000..c4c6022
--- /dev/null
+++ b/src/static/js/jquery-3.6.0.min.js
@@ -0,0 +1,2 @@
+/*! jQuery v3.6.0 | (c) OpenJS Foundation and other contributors |
jquery.org/license */
+!function(e,t){"use strict";"object"==typeof module&&"object"==typeof
module.exports?module.exports=e.document?t(e,!0):function(e){if(!e.document)throw
new Error("jQuery requires a window with a document");return
t(e)}:t(e)}("undefined"!=typeof window?window:this,function(C,e){"use
strict";var t=[],r=Object.getPrototypeOf,s=t.slice,g=t.flat?function(e){return
t.flat.call(e)}:function(e){return
t.concat.apply([],e)},u=t.push,i=t.indexOf,n={},o=n.toString,v=n.hasOwnProperty,a=v.toString,l=
[...]