diff options
author | Christopher Baines <mail@cbaines.net> | 2019-06-20 14:29:56 +0200 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2019-06-20 14:29:56 +0200 |
commit | d07e3d9ba88aee9a90f78e5ee945f51fbb9dcb9f (patch) | |
tree | 1b85f7607ec02d62efb75e3c888b30a12c924fbb /guix-data-service/web | |
parent | bb0251160730a36488185eefe16e35f611ecc655 (diff) | |
download | data-service-d07e3d9ba88aee9a90f78e5ee945f51fbb9dcb9f.tar data-service-d07e3d9ba88aee9a90f78e5ee945f51fbb9dcb9f.tar.gz |
Move the derivations off the compare page
To the compare/derivations page. Previously, the compare/derivations page was
comparing more than the derivations, notably the package metadata. This change
avoids that, and also reduces the information overload on the compare page.
Diffstat (limited to 'guix-data-service/web')
-rw-r--r-- | guix-data-service/web/controller.scm | 41 | ||||
-rw-r--r-- | guix-data-service/web/view/html.scm | 200 |
2 files changed, 78 insertions, 163 deletions
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index a6330d8..f5d4d90 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -358,10 +358,7 @@ target-packages-vhash)) (version-changes (package-data-version-changes base-packages-vhash - target-packages-vhash)) - (derivation-changes - (package-data-derivation-changes base-packages-vhash - target-packages-vhash))) + target-packages-vhash))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) @@ -369,8 +366,7 @@ (render-json `((new-packages . ,(list->vector new-packages)) (removed-packages . ,(list->vector removed-packages)) - (version-changes . ,version-changes) - (derivation-changes . ,derivation-changes)) + (version-changes . ,(list->vector version-changes))) #:extra-headers http-headers-for-unchanging-content)) (else (render-html @@ -378,8 +374,7 @@ target-commit new-packages removed-packages - version-changes - derivation-changes) + version-changes) #:extra-headers http-headers-for-unchanging-content)))))) (define (render-compare/derivations mime-types @@ -409,7 +404,6 @@ query-parameters (valid-systems conn) build-status-strings - '() '())))) (let ((base-commit (assq-ref query-parameters 'base_commit)) @@ -423,33 +417,15 @@ (package-differences-data conn (commit->revision-id conn base-commit) (commit->revision-id conn target-commit))))) - (let ((base-derivations - (package-data-vhash->derivations-and-build-status - conn - base-packages-vhash - systems - targets - build-statuses)) - (target-derivations - (package-data-vhash->derivations-and-build-status - conn - target-packages-vhash - systems - targets - build-statuses))) + (let ((derivation-changes + (package-data-derivation-changes base-packages-vhash + target-packages-vhash))) (case (most-appropriate-mime-type '(application/json text/html) mime-types) ((application/json) (render-json - `((base . ((commit . ,base-commit) - (derivations . ,(list->vector - (derivations->alist - base-derivations))))) - (target . ((commit . ,target-commit) - (derivations . ,(list->vector - (derivations->alist - target-derivations)))))) + derivation-changes #:extra-headers http-headers-for-unchanging-content)) (else (render-html @@ -457,8 +433,7 @@ query-parameters (valid-systems conn) build-status-strings - base-derivations - target-derivations) + derivation-changes) #:extra-headers http-headers-for-unchanging-content)))))))) (define (render-compare/packages mime-types diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index 3e66bd2..6b95ee9 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -1095,8 +1095,7 @@ target-commit new-packages removed-packages - version-changes - derivation-changes) + version-changes) (define query-params (string-append "?base_commit=" base-commit "&target_commit=" target-commit)) @@ -1210,7 +1209,75 @@ " (old)" " (new)")))) versions)))))) - version-changes)))))) + version-changes)))))))))) + +(define (compare/derivations query-parameters + valid-systems + valid-build-statuses + derivation-changes) + (layout + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (h1 ,@(let ((base-commit (assq-ref query-parameters 'base_commit)) + (target-commit (assq-ref query-parameters 'target_commit))) + (if (every string? (list base-commit target-commit)) + `("Comparing " + (samp ,(string-take base-commit 8) "…") + " and " + (samp ,(string-take target-commit 8) "…")) + '("Comparing derivations"))))) + (div + (@ (class "row")) + (div + (@ (class "col-md-12")) + (div + (@ (class "well")) + (form + (@ (method "get") + (action "") + (class "form-horizontal")) + ,(form-horizontal-control + "Base commit" query-parameters + #:required? #t + #:help-text "The commit to use as the basis for the comparison." + #:font-family "monospace") + ,(form-horizontal-control + "Target commit" query-parameters + #:required? #t + #:help-text "The commit to compare against the base commit." + #:font-family "monospace") + ,(form-horizontal-control + "System" query-parameters + #:options valid-systems + #:help-text "Only include derivations for this system." + #:font-family "monospace") + ,(form-horizontal-control + "Target" query-parameters + #:options valid-systems + #:help-text "Only include derivations that are build for this system." + #:font-family "monospace") + ,(form-horizontal-control + "Build status" query-parameters + #:options valid-build-statuses + #:help-text "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 ,(let ((query-parameter-string + (query-parameters->string query-parameters))) + (string-append + "/compare/derivations.json" + (if (string-null? query-parameter-string) + "" + (string-append "?" query-parameter-string)))))) + "View JSON"))))) (div (@ (class "row")) (div @@ -1292,133 +1359,6 @@ (cdr data-columns)))))) (vector->list derivation-changes))))))))))) -(define (compare/derivations query-parameters - valid-systems - valid-build-statuses - base-derivations - target-derivations) - (layout - #:body - `(,(header) - (div - (@ (class "container")) - (div - (@ (class "row")) - (h1 ,@(let ((base-commit (assq-ref query-parameters 'base_commit)) - (target-commit (assq-ref query-parameters 'target_commit))) - (if (every string? (list base-commit target-commit)) - `("Comparing " - (samp ,(string-take base-commit 8) "…") - " and " - (samp ,(string-take target-commit 8) "…")) - '("Comparing derivations"))))) - (div - (@ (class "row")) - (div - (@ (class "col-md-12")) - (div - (@ (class "well")) - (form - (@ (method "get") - (action "") - (class "form-horizontal")) - ,(form-horizontal-control - "Base commit" query-parameters - #:required? #t - #:help-text "The commit to use as the basis for the comparison." - #:font-family "monospace") - ,(form-horizontal-control - "Target commit" query-parameters - #:required? #t - #:help-text "The commit to compare against the base commit." - #:font-family "monospace") - ,(form-horizontal-control - "System" query-parameters - #:options valid-systems - #:help-text "Only include derivations for this system." - #:font-family "monospace") - ,(form-horizontal-control - "Target" query-parameters - #:options valid-systems - #:help-text "Only include derivations that are build for this system." - #:font-family "monospace") - ,(form-horizontal-control - "Build status" query-parameters - #:options valid-build-statuses - #:help-text "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 ,(let ((query-parameter-string - (query-parameters->string query-parameters))) - (string-append - "/compare/derivations.json" - (if (string-null? query-parameter-string) - "" - (string-append "?" query-parameter-string)))))) - "View JSON"))))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (h3 "Base" - ,@(let ((base-commit (assq-ref query-parameters 'base_commit))) - (if (string? base-commit) - `(" (" (samp ,base-commit) ")") - '()))) - (p "Derivations found only in the base revision.") - (table - (@ (class "table")) - (thead - (tr - (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 system target build-status) - `(tr - (td (a (@ (href ,file-name)) - ,(display-store-item-short file-name))) - (td (samp ,system)) - (td (samp ,target)) - (td ,(build-status-span build-status))))) - base-derivations))))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (h3 "Target" - ,@(let ((target-commit (assq-ref query-parameters 'target_commit))) - (if (string? target-commit) - `(" (" (samp ,target-commit) ")") - '()))) - (p "Derivations found only in the target revision.") - (table - (@ (class "table")) - (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 system target build-status) - `(tr - (td (a (@ (href ,file-name)) - ,(display-store-item-short file-name))) - (td (samp ,system)) - (td (samp ,target)) - (td ,(build-status-span build-status))))) - target-derivations))))))))) - (define (compare/packages base-commit target-commit base-packages-vhash |