From 14b79936369c2755d9a98d2c3ca839081b20833d Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 22 Dec 2019 14:27:59 +0000 Subject: Allow filtering the revision builds page by system --- guix-data-service/model/build.scm | 37 ++++++++++++++++---- guix-data-service/web/revision/controller.scm | 50 ++++++++++++++++----------- guix-data-service/web/revision/html.scm | 13 +++++++ 3 files changed, 74 insertions(+), 26 deletions(-) (limited to 'guix-data-service') diff --git a/guix-data-service/model/build.scm b/guix-data-service/model/build.scm index 5c943a6..7f1d2fa 100644 --- a/guix-data-service/model/build.scm +++ b/guix-data-service/model/build.scm @@ -13,7 +13,9 @@ insert-build ensure-build-exists)) -(define* (select-build-stats conn build-servers #:key revision-commit) +(define* (select-build-stats conn build-servers + #:key revision-commit + system target) (define criteria `(,@(if revision-commit ;; Ignore cross built derivations, as I'm not aware of a build server @@ -30,6 +32,12 @@ '()) ,@(if revision-commit '("guix_revisions.commit = $1") + '()) + ,@(if system + '("package_derivations.system = $2") + '()) + ,@(if target + '("package_derivations.target = $3") '()))) (define query @@ -85,10 +93,17 @@ ORDER BY status")) query `(,@(if revision-commit (list revision-commit) + '()) + ,@(if system + (list system) + '()) + ,@(if target + (list target) '())))))) (define* (select-builds-with-context conn build-statuses build-server-ids - #:key revision-commit) + #:key revision-commit + system target) (define where-conditions (filter string? @@ -106,7 +121,11 @@ ORDER BY status")) ", ") ")")) (when revision-commit - "guix_revisions.commit = $1")))) + "guix_revisions.commit = $1") + (when system + "package_derivations.system = $2") + (when target + "package_derivations.target = $3")))) (define query (string-append @@ -146,9 +165,15 @@ LIMIT 100")) (exec-query conn query - (if revision-commit - (list revision-commit) - '()))) + `(,@(if revision-commit + (list revision-commit) + '()) + ,@(if system + (list system) + '()) + ,@(if target + (list target) + '())))) (define (select-builds-with-context-by-derivation-file-name conn derivation-file-name) diff --git a/guix-data-service/web/revision/controller.scm b/guix-data-service/web/revision/controller.scm index 05a259b..90416df 100644 --- a/guix-data-service/web/revision/controller.scm +++ b/guix-data-service/web/revision/controller.scm @@ -234,7 +234,9 @@ (parse-query-parameters request `((build_status ,parse-build-status #:multi-value) - (build_server ,(parse-build-server conn) #:multi-value))))) + (build_server ,(parse-build-server conn) #:multi-value) + (system ,parse-system #:default "x86_64-linux") + (target ,parse-system #:default "x86_64-linux"))))) (render-revision-builds mime-types conn @@ -754,28 +756,36 @@ (render-html #:sxml (view-revision-builds query-parameters build-status-strings + (valid-systems conn) '() '() '())) - (render-html - #:sxml (view-revision-builds query-parameters - build-status-strings - (map (match-lambda - ((id url lookup-all-derivations) - (cons url id))) - (select-build-servers conn)) - (select-build-stats - conn - (assq-ref query-parameters - 'build_server) - #:revision-commit commit-hash) - (select-builds-with-context - conn - (assq-ref query-parameters - 'build_status) - (assq-ref query-parameters - 'build_server) - #:revision-commit commit-hash))))) + (let ((system (assq-ref query-parameters 'system)) + (target (assq-ref query-parameters 'target))) + (render-html + #:sxml (view-revision-builds query-parameters + build-status-strings + (valid-systems conn) + (map (match-lambda + ((id url lookup-all-derivations) + (cons url id))) + (select-build-servers conn)) + (select-build-stats + conn + (assq-ref query-parameters + 'build_server) + #:revision-commit commit-hash + #:system system + #:target target) + (select-builds-with-context + conn + (assq-ref query-parameters + 'build_status) + (assq-ref query-parameters + 'build_server) + #:revision-commit commit-hash + #:system system + #:target target)))))) (define* (render-revision-lint-warnings mime-types conn diff --git a/guix-data-service/web/revision/html.scm b/guix-data-service/web/revision/html.scm index 1f451d1..127005f 100644 --- a/guix-data-service/web/revision/html.scm +++ b/guix-data-service/web/revision/html.scm @@ -1149,6 +1149,7 @@ figure { (define (view-revision-builds query-parameters build-status-strings + valid-systems build-server-options stats builds) @@ -1210,6 +1211,18 @@ figure { query-parameters #:options build-server-options #:help-text "Return builds from these build servers.") + ,(form-horizontal-control + "System" query-parameters + #:options valid-systems + #:allow-selecting-multiple-options #f + #:help-text "Only include derivations for this system." + #:font-family "monospace") + ,(form-horizontal-control + "Target" query-parameters + #:options valid-systems + #:allow-selecting-multiple-options #f + #:help-text "Only include derivations that are build for this system." + #:font-family "monospace") (div (@ (class "form-group form-group-lg")) (div (@ (class "col-sm-offset-2 col-sm-10")) (button (@ (type "submit") -- cgit v1.2.3