guix
/
guix-cuirass
mirror of git://git.savannah.gnu.org/guix/guix-cuirass.git
2
0
Fork 0
Code Issues Releases Wiki Activity

http: Handle specification deletion and addition. 

* src/cuirass/http.scm (url-handler): Handle /admin/specifications/add,
/admin/specifications/delete/*, and /admin/specifications.
This commit is contained in:
Ricardo Wurmus 2019-10-30 09:21:37 +01:00
parent 53fe4996be
commit 918601d966
No known key found for this signature in database
GPG Key ID: 197A5888235FACAC
1 changed files with 36 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
src/cuirass/http.scm
View File

@ -40,6 +40,7 @@
#:use-module (web uri)
#:use-module (fibers)
#:use-module (fibers channels)
#:use-module ((rnrs bytevectors) #:select (utf8->string))
#:use-module (sxml simple)
#:use-module (cuirass templates)
#:use-module (guix utils)
@ -248,6 +249,41 @@ 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
`((#:name . ,name)
(#:load-path-inputs . ())
(#:package-path-inputs . ())
(#:proc . cuirass-jobs)
(#:proc-input . ,name)
(#:proc-file . "build-aux/cuirass/gnu-system.scm")
(#:proc-args . (systems "x86_64-linux"
"i686-linux"
"armhf-linux"
"aarch64-linux"))
(#:inputs .
'((#:name . ,name)
(#:url . "https://git.savannah.gnu.org/git/guix.git")
(#:load-path . ".")
(#:branch . ,name)
(#:no-compile? . #t)))))
(respond (build-response #:code 302
#:headers `((location . ,(string->uri-reference
"/admin/specifications"))))
#:body ""))))
(('POST "admin" "specifications" "delete" name)
(db-remove-specification name)
(respond (build-response #:code 302
#:headers `((location . ,(string->uri-reference
"/admin/specifications"))))
#:body ""))
(('GET "admin" "specifications" . rest)
(respond-html (html-page
"Cuirass [Admin]"
(specifications-table (db-get-specifications) 'admin)
'())))
(('GET (or "jobsets" "specifications") . rest)
(respond-json (object->json-string
(list->vector (db-get-specifications)))))