From 189014f3bc5a9526970ec3bf86104fd92f43bef6 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 17 Mar 2019 22:44:09 +0000 Subject: Improve the compare derivations page Add support for filtering the results, and add the system and target to the output. --- guix-data-service/comparison.scm | 11 ++- guix-data-service/model/build-status.scm | 4 + guix-data-service/model/derivation.scm | 56 +++++++++--- guix-data-service/web/controller.scm | 84 ++++++++++++----- guix-data-service/web/view/html.scm | 150 ++++++++++++++++++++++++++++--- 5 files changed, 254 insertions(+), 51 deletions(-) (limited to 'guix-data-service') diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm index 68cafa8..733d740 100644 --- a/guix-data-service/comparison.scm +++ b/guix-data-service/comparison.scm @@ -98,7 +98,9 @@ ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, t (select-derivations-by-id conn derivation-ids))) derivation-data)) -(define (package-data-vhash->derivations-and-build-status conn packages-vhash) +(define (package-data-vhash->derivations-and-build-status conn packages-vhash + systems targets + build-statuses) (define (vhash->derivation-file-names vhash) (vhash-fold (lambda (key value result) (cons (third value) @@ -109,9 +111,12 @@ ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, t (let* ((derivation-file-names (vhash->derivation-file-names packages-vhash)) (derivation-data - (select-derivations-and-build-status-by-file-name + (select-derivations-and-build-status conn - derivation-file-names))) + #:file-names derivation-file-names + #:systems systems + #:targets targets + #:build-statuses build-statuses))) derivation-data)) (define (package-data-vhash->package-name-and-version-vhash vhash) diff --git a/guix-data-service/model/build-status.scm b/guix-data-service/model/build-status.scm index d6fde3a..26efde1 100644 --- a/guix-data-service/model/build-status.scm +++ b/guix-data-service/model/build-status.scm @@ -1,6 +1,7 @@ (define-module (guix-data-service model build-status) #:use-module (squee) #:export (build-statuses + build-status-strings insert-build-status)) (define build-statuses @@ -12,6 +13,9 @@ (3 . "failed-other") (4 . "canceled"))) +(define build-status-strings + (map cdr build-statuses)) + (define (insert-build-status conn internal-build-id starttime stoptime status) (exec-query conn diff --git a/guix-data-service/model/derivation.scm b/guix-data-service/model/derivation.scm index 3104059..7a710de 100644 --- a/guix-data-service/model/derivation.scm +++ b/guix-data-service/model/derivation.scm @@ -8,7 +8,8 @@ #:use-module (guix memoization) #:use-module (guix derivations) #:use-module (guix-data-service model utils) - #:export (select-derivation-by-file-name + #:export (valid-systems + select-derivation-by-file-name select-derivation-outputs-by-derivation-id select-derivation-by-output-filename select-derivations-using-output @@ -16,10 +17,16 @@ select-derivation-inputs-by-derivation-id select-existing-derivations select-derivations-by-id - select-derivations-and-build-status-by-file-name + select-derivations-and-build-status insert-into-derivations derivation-file-names->derivation-ids)) +(define (valid-systems conn) + (map car + (exec-query + conn + "SELECT DISTINCT system FROM derivations ORDER BY 1"))) + (define (select-existing-derivations file-names) (string-append "SELECT id, file_name " "FROM derivations " @@ -462,11 +469,45 @@ ORDER BY derivations.system DESC, (exec-query conn query)) -(define (select-derivations-and-build-status-by-file-name conn file-names) +(define* (select-derivations-and-build-status conn #:key + file-names + systems + targets + build-statuses) + (define criteria + (string-join + (filter-map + (lambda (field values) + (if (and values (not (null? values))) + (string-append + field " IN (" + (string-join (map (lambda (value) + (simple-format #f "'~A'" value)) + values) + ",") + ")") + #f)) + '("derivations.file_name" + "derivations.system" + "target" + "latest_build_status.status") + (list file-names + systems + targets + build-statuses)) + " AND ")) + (define query (string-append - "SELECT derivations.file_name, latest_build_status.status " + "SELECT derivations.file_name, derivations.system, (" + " SELECT DISTINCT package_derivations.target" + " FROM package_derivations" + " WHERE derivations.id = package_derivations.derivation_id" + ") AS target, " + "latest_build_status.status " "FROM derivations " + "INNER JOIN package_derivations" + " ON derivations.id = package_derivations.derivation_id " "LEFT OUTER JOIN builds ON derivations.id = builds.derivation_id " "LEFT OUTER JOIN " "(SELECT DISTINCT ON (internal_build_id) * " @@ -474,12 +515,7 @@ ORDER BY derivations.system DESC, "ORDER BY internal_build_id, status_fetched_at DESC" ") AS latest_build_status " "ON builds.internal_id = latest_build_status.internal_build_id " - "WHERE derivations.file_name IN " - "(" (string-join (map (lambda (file-name) - (simple-format #f "'~A'" file-name)) - file-names) - ",") - ");")) + "WHERE " criteria ";")) (exec-query conn query)) diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 1b83b02..bf0e127 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -32,6 +32,7 @@ #:use-module (guix-data-service model package-derivation) #:use-module (guix-data-service model package-metadata) #:use-module (guix-data-service model derivation) + #:use-module (guix-data-service model build-status) #:use-module (guix-data-service model build) #:use-module (guix-data-service jobs load-new-guix-revision) #:use-module (guix-data-service web render) @@ -57,17 +58,18 @@ ;; (render-html (error-page message)))) ) -(define (with-base-and-target-commits request conn f) - (let ((base-commit (-> request - request-uri - uri-query - parse-query-string - (cut assoc-ref <> "base_commit"))) - (target-commit (-> request - request-uri - uri-query - parse-query-string - (cut assoc-ref <> "target_commit")))) +(define (assoc-ref-multiple alist key) + (filter-map + (match-lambda + ((k . value) + (and (string=? k key) + value))) + alist)) + +(define (with-base-and-target-commits query-parameters conn f) + (let* ((base-commit (assoc-ref query-parameters "base_commit")) + (target-commit (assoc-ref query-parameters "target_commit"))) + (f base-commit (commit->revision-id conn base-commit) target-commit @@ -139,11 +141,16 @@ base-commit base-revision-id target-commit - target-revision-id) + target-revision-id + systems + targets + build-statuses) (define (derivations->alist derivations) (map (match-lambda - ((file-name buildstatus) + ((file-name system target buildstatus) `((file_name . ,file-name) + (system . ,system) + (target . ,target) (build_status . ,(if (string=? "") "unknown" buildstatus))))) @@ -158,11 +165,17 @@ (let ((base-derivations (package-data-vhash->derivations-and-build-status conn - base-packages-vhash)) + base-packages-vhash + systems + targets + build-statuses)) (target-derivations (package-data-vhash->derivations-and-build-status conn - target-packages-vhash))) + target-packages-vhash + systems + targets + build-statuses))) (cond ((eq? content-type 'json) (render-json @@ -177,10 +190,15 @@ (else (apply render-html (compare/derivations + (valid-systems conn) + build-status-strings base-commit target-commit base-derivations - target-derivations))))))) + target-derivations + systems + targets + build-statuses))))))) (define (render-compare/packages content-type conn @@ -260,6 +278,12 @@ derivations))))))) (define (controller request body conn) + (define query-parameters + (-> request + request-uri + uri-query + parse-query-string)) + (match-lambda ((GET) (apply render-html (index @@ -303,7 +327,7 @@ (render-store-item conn (string-append "/gnu/store/" filename)))) ((GET "compare") (with-base-and-target-commits - request conn + query-parameters conn (lambda (base-commit base-revision-id target-commit target-revision-id) (if (not (and base-revision-id target-revision-id)) (render-compare-unknown-commit 'html @@ -320,7 +344,7 @@ target-revision-id))))) ((GET "compare.json") (with-base-and-target-commits - request conn + query-parameters conn (lambda (base-commit base-revision-id target-commit target-revision-id) (if (not (and base-revision-id target-revision-id)) (render-compare-unknown-commit 'json @@ -337,7 +361,7 @@ target-revision-id))))) ((GET "compare" "derivations") (with-base-and-target-commits - request conn + query-parameters conn (lambda (base-commit base-revision-id target-commit target-revision-id) (if (not (and base-revision-id target-revision-id)) (render-compare-unknown-commit 'html @@ -351,10 +375,16 @@ base-commit base-revision-id target-commit - target-revision-id))))) + target-revision-id + (assoc-ref-multiple query-parameters + "system") + (assoc-ref-multiple query-parameters + "target") + (assoc-ref-multiple query-parameters + "build_status")))))) ((GET "compare" "derivations.json") (with-base-and-target-commits - request conn + query-parameters conn (lambda (base-commit base-revision-id target-commit target-revision-id) (if (not (and base-revision-id target-revision-id)) (render-compare-unknown-commit 'json @@ -368,10 +398,16 @@ base-commit base-revision-id target-commit - target-revision-id))))) + target-revision-id + (assoc-ref-multiple query-parameters + "system") + (assoc-ref-multiple query-parameters + "target") + (assoc-ref-multiple query-parameters + "build_status")))))) ((GET "compare" "packages") (with-base-and-target-commits - request conn + query-parameters conn (lambda (base-commit base-revision-id target-commit target-revision-id) (if (not (and base-revision-id target-revision-id)) (render-compare-unknown-commit 'html @@ -388,7 +424,7 @@ target-revision-id))))) ((GET "compare" "packages.json") (with-base-and-target-commits - request conn + query-parameters conn (lambda (base-commit base-revision-id target-commit target-revision-id) (if (not (and base-revision-id target-revision-id)) (render-compare-unknown-commit 'json diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index 40d5d74..07f5f1a 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -641,11 +641,13 @@ (td ,name) (td (ul ,@(map (match-lambda - ((type . #(version)) + ((type . versions) `(li (@ (class ,(if (eq? type 'base) "text-danger" "text-success"))) - ,version + ,(string-join + (vector->list versions) + ", ") ,(if (eq? type 'base) " (old)" " (new)")))) @@ -726,10 +728,15 @@ (cdr data-columns)))))) (vector->list derivation-changes)))))))))) -(define (compare/derivations base-commit +(define (compare/derivations valid-systems + valid-build-statuses + base-commit target-commit base-derivations - target-derivations) + target-derivations + systems + targets + build-statues) (define query-params (string-append "?base_commit=" base-commit "&target_commit=" target-commit)) @@ -746,11 +753,118 @@ (h1 "Comparing " (samp ,(string-take base-commit 8) "…") " and " - (samp ,(string-take target-commit 8) "…")) - (a (@ (class "btn btn-default btn-lg") - (href ,(string-append - "/compare/derivations.json" query-params))) - "View JSON")) + (samp ,(string-take target-commit 8) "…"))) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (div + (@ (class "well")) + (form + (@ (method "get") + (action "") + (class "form-horizontal")) + (div (@ (class "form-group form-group-lg")) + (label (@ (for "inputBaseCommit") + (class "col-sm-2 control-label")) + "Base commit") + (div (@ (class "col-sm-9")) + (input (@ (class "form-control") + (style "font-family: monospace;") + (id "inputBaseCommit") + (required #t) + (aria-describedby "baseCommitHelp") + (name "base_commit") + (value ,base-commit))) + (span (@ (id "baseCommitHelp") + (class "help-block")) + (strong "Required.") + " The commit to use as the basis for the comparison."))) + (div (@ (class "form-group form-group-lg")) + (label (@ (for "inputTargetCommit") + (class "col-sm-2 control-label")) + "Target commit") + (div (@ (class "col-sm-9")) + (input (@ (class "form-control") + (style "font-family: monospace;") + (id "inputTargetCommit") + (required #t) + (aria-describedby "targetCommitHelp") + (name "target_commit") + (value ,target-commit))) + (span (@ (id "targetCommitHelp") + (class "help-block")) + (strong "Required.") + " The commit to compare against the base commit."))) + (div (@ (class "form-group form-group-lg")) + (label (@ (for "inputSystem") + (class "col-sm-2 control-label")) + "System") + (div (@ (class "col-sm-9")) + (select (@ (class "form-control") + (style "font-family: monospace;") + (multiple #t) + (id "inputSystem") + (aria-describedby "systemHelp") + (name "system")) + ,@(map (lambda (system) + `(option (@ ,@(if (member system systems) + '((selected "")) + '())) + ,system)) + valid-systems)) + (span (@ (id "systemHelp") + (class "help-block")) + "Only include derivations for this system."))) + (div (@ (class "form-group form-group-lg")) + (label (@ (for "inputTarget") + (class "col-sm-2 control-label")) + "Target") + (div (@ (class "col-sm-9")) + (select (@ (class "form-control") + (style "font-family: monospace;") + (multiple #t) + (id "inputTarget") + (aria-describedby "targetHelp") + (name "target")) + ,@(map (lambda (system) + `(option (@ ,@(if (member system targets) + '((selected "")) + '())) + ,system)) + valid-systems)) + (span (@ (id "targetHelp") + (class "help-block")) + "Only include derivations that are build for this system."))) + (div (@ (class "form-group form-group-lg")) + (label (@ (for "inputBuildStatus") + (class "col-sm-2 control-label")) + "Build status") + (div (@ (class "col-sm-9")) + (select (@ (class "form-control") + (id "inputBuildStatus") + (aria-describedby "buildStatusHelp") + (multiple #t) + (name "build_status")) + ,@(map (lambda (build-status) + `(option (@ ,@(if (member build-status build-statues) + '((selected "")) + '()) + (value ,build-status)) + ,(build-status-value->display-string build-status))) + valid-build-statuses)) + (span (@ (id "buildStatusHelp") + (class "help-block")) + "Only include derivations which have this build status."))) + (div (@ (class "form-group form-group-lg")) + (div (@ (class "col-sm-offset-2 col-sm-10")) + (button (@ (type "submit") + (class "btn btn-lg btn-primary")) + "Update results"))) + (a (@ (class "btn btn-default btn-lg pull-right") + (href ,(string-append + "/compare/derivations.json" query-params))) + "View JSON"))))) (div (@ (class "row")) (h3 "Base (" @@ -761,15 +875,19 @@ (@ (class "table")) (thead (tr - (th (@ (class "col-md-8")) "File Name") + (th (@ (class "col-md-6")) "File Name") + (th (@ (class "col-md-2")) "System") + (th (@ (class "col-md-2")) "Target") (th (@ (class "col-md-4")) "Build status"))) (tbody ,@(map (match-lambda - ((file-name build-status) + ((file-name system target build-status) `(tr (td (a (@ (href ,file-name)) - ,(display-store-item file-name))) + ,(display-store-item-short file-name))) + (td (samp ,system)) + (td (samp ,target)) (td ,(build-status-span build-status))))) base-derivations)))) (div @@ -783,14 +901,18 @@ (thead (tr (th (@ (class "col-md-8")) "File Name") + (th (@ (class "col-md-2")) "System") + (th (@ (class "col-md-2")) "Target") (th (@ (class "col-md-4")) "Build status"))) (tbody ,@(map (match-lambda - ((file-name build-status) + ((file-name system target build-status) `(tr (td (a (@ (href ,file-name)) - ,(display-store-item file-name))) + ,(display-store-item-short file-name))) + (td (samp ,system)) + (td (samp ,target)) (td ,(build-status-span build-status))))) target-derivations)))))))) -- cgit v1.2.3