diff options
| -rw-r--r-- | guix-data-service/web/compare/controller.scm | 494 | ||||
| -rw-r--r-- | guix-data-service/web/compare/html.scm | 661 | ||||
| -rw-r--r-- | guix-data-service/web/controller.scm | 451 | ||||
| -rw-r--r-- | guix-data-service/web/view/html.scm | 638 |
4 files changed, 1158 insertions, 1086 deletions
diff --git a/guix-data-service/web/compare/controller.scm b/guix-data-service/web/compare/controller.scm new file mode 100644 index 0000000..7c75767 --- /dev/null +++ b/guix-data-service/web/compare/controller.scm @@ -0,0 +1,494 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU Affero General Public License +;;; as published by the Free Software Foundation, either version 3 of +;;; the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-data-service web compare controller) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (ice-9 match) + #:use-module (guix-data-service web util) + #:use-module (guix-data-service web render) + #:use-module (guix-data-service web query-parameters) + #:use-module (guix-data-service model utils) + #:use-module (guix-data-service comparison) + #:use-module (guix-data-service model guix-revision) + #:use-module (guix-data-service model derivation) + #:use-module (guix-data-service model build-status) + #:use-module (guix-data-service web compare html) + #:export (compare-controller)) + +(define cache-control-default-max-age + (* 60 60 24)) ; One day + +(define http-headers-for-unchanging-content + `((cache-control + . (public + (max-age . ,cache-control-default-max-age))))) + +(define (parse-system s) + s) + +(define (parse-build-status s) + s) + +(define (parse-commit conn) + (lambda (s) + (if (guix-commit-exists? conn s) + s + (make-invalid-query-parameter + s "unknown commit")))) + +(define (compare-controller request + method-and-path-components + mime-types + body + conn) + (match method-and-path-components + (('GET "compare") + (let* ((parsed-query-parameters + (parse-query-parameters + request + `((base_commit ,(parse-commit conn) #:required) + (target_commit ,(parse-commit conn) #:required))))) + (render-compare mime-types + conn + parsed-query-parameters))) + (('GET "compare-by-datetime") + (let* ((parsed-query-parameters + (parse-query-parameters + request + `((base_branch ,identity #:required) + (base_datetime ,parse-datetime #:required) + (target_branch ,identity #:required) + (target_datetime ,parse-datetime #:required))))) + (render-compare-by-datetime mime-types + conn + parsed-query-parameters))) + (('GET "compare" "derivations") + (let* ((parsed-query-parameters + (parse-query-parameters + request + `((base_commit ,(parse-commit conn) #:required) + (target_commit ,(parse-commit conn) #:required) + (system ,parse-system #:multi-value) + (target ,parse-system #:multi-value) + (build_status ,parse-build-status #:multi-value))))) + (render-compare/derivations mime-types + conn + parsed-query-parameters))) + (('GET "compare-by-datetime" "derivations") + (let* ((parsed-query-parameters + (guard-against-mutually-exclusive-query-parameters + (parse-query-parameters + request + `((base_branch ,identity #:required) + (base_datetime ,parse-datetime #:required) + (target_branch ,identity #:required) + (target_datetime ,parse-datetime #:required) + (system ,parse-system #:multi-value) + (target ,parse-system #:multi-value) + (build_status ,parse-build-status #:multi-value))) + '((base_commit base_datetime) + (target_commit target_datetime))))) + (render-compare-by-datetime/derivations mime-types + conn + parsed-query-parameters))) + (('GET "compare" "packages") + (let* ((parsed-query-parameters + (parse-query-parameters + request + `((base_commit ,(parse-commit conn) #:required) + (target_commit ,(parse-commit conn) #:required))))) + (render-compare/packages mime-types + conn + parsed-query-parameters))))) + +(define (render-compare mime-types + conn + query-parameters) + (if (any-invalid-query-parameters? query-parameters) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + '((error . "invalid query")))) + (else + (render-html + #:sxml (compare-invalid-parameters + query-parameters + (match (assq-ref query-parameters 'base_commit) + (($ <invalid-query-parameter> value) + (select-job-for-commit conn value)) + (_ #f)) + (match (assq-ref query-parameters 'target_commit) + (($ <invalid-query-parameter> value) + (select-job-for-commit conn value)) + (_ #f)))))) + + (let ((base-revision-id (commit->revision-id + conn + (assq-ref query-parameters 'base_commit))) + (target-revision-id (commit->revision-id + conn + (assq-ref query-parameters 'target_commit)))) + (let-values + (((base-packages-vhash target-packages-vhash) + (package-data->package-data-vhashes + (package-differences-data conn + base-revision-id + target-revision-id)))) + (let* ((new-packages + (package-data-vhashes->new-packages base-packages-vhash + target-packages-vhash)) + (removed-packages + (package-data-vhashes->removed-packages base-packages-vhash + target-packages-vhash)) + (version-changes + (package-data-version-changes base-packages-vhash + target-packages-vhash)) + (lint-warnings-data + (group-list-by-first-n-fields + 2 + (lint-warning-differences-data conn + base-revision-id + target-revision-id)))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((new-packages . ,(list->vector new-packages)) + (removed-packages . ,(list->vector removed-packages)) + (version-changes . ,(list->vector + (map + (match-lambda + ((name data ...) + `((name . ,name) + ,@data))) + version-changes)))) + #:extra-headers http-headers-for-unchanging-content)) + (else + (render-html + #:sxml (compare query-parameters + (guix-revisions-cgit-url-bases + conn + (list base-revision-id + target-revision-id)) + new-packages + removed-packages + version-changes + lint-warnings-data) + #:extra-headers http-headers-for-unchanging-content)))))))) + +(define (render-compare-by-datetime mime-types + conn + query-parameters) + (if (any-invalid-query-parameters? query-parameters) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + '((error . "invalid query")))) + (else + (render-html + #:sxml (compare-invalid-parameters + query-parameters + (match (assq-ref query-parameters 'base_commit) + (($ <invalid-query-parameter> value) + (select-job-for-commit conn value)) + (_ #f)) + (match (assq-ref query-parameters 'target_commit) + (($ <invalid-query-parameter> value) + (select-job-for-commit conn value)) + (_ #f)))))) + + (let ((base-branch (assq-ref query-parameters 'base_branch)) + (base-datetime (assq-ref query-parameters 'base_datetime)) + (target-branch (assq-ref query-parameters 'target_branch)) + (target-datetime (assq-ref query-parameters 'target_datetime))) + (let* ((base-revision-details + (select-guix-revision-for-branch-and-datetime conn + base-branch + base-datetime)) + (base-revision-id + (first base-revision-details)) + (target-revision-details + (select-guix-revision-for-branch-and-datetime conn + target-branch + target-datetime)) + (target-revision-id + (first target-revision-details))) + (let-values + (((base-packages-vhash target-packages-vhash) + (package-data->package-data-vhashes + (package-differences-data conn + base-revision-id + target-revision-id)))) + (let* ((new-packages + (package-data-vhashes->new-packages base-packages-vhash + target-packages-vhash)) + (removed-packages + (package-data-vhashes->removed-packages base-packages-vhash + target-packages-vhash)) + (version-changes + (package-data-version-changes base-packages-vhash + target-packages-vhash)) + (lint-warnings-data + (group-list-by-first-n-fields + 2 + (lint-warning-differences-data conn + base-revision-id + target-revision-id)))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((new-packages . ,(list->vector new-packages)) + (removed-packages . ,(list->vector removed-packages)) + (version-changes . ,(list->vector + (map + (match-lambda + ((name data ...) + `((name . ,name) + ,@data))) + version-changes)))) + #:extra-headers http-headers-for-unchanging-content)) + (else + (render-html + #:sxml (compare `(,@query-parameters + (base_commit . ,(second base-revision-details)) + (target_commit . ,(second target-revision-details))) + (guix-revisions-cgit-url-bases + conn + (list base-revision-id + target-revision-id)) + new-packages + removed-packages + version-changes + lint-warnings-data) + #:extra-headers http-headers-for-unchanging-content))))))))) + +(define (render-compare/derivations mime-types + conn + query-parameters) + (define (derivations->alist derivations) + (map (match-lambda + ((file-name system target buildstatus) + `((file_name . ,file-name) + (system . ,system) + (target . ,target) + (build_status . ,(if (string=? buildstatus "") + "unknown" + buildstatus))))) + derivations)) + + (if (any-invalid-query-parameters? query-parameters) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + '((error . "invalid query")))) + (else + (render-html + #:sxml (compare/derivations + query-parameters + (valid-systems conn) + build-status-strings + '())))) + + (let ((base-commit (assq-ref query-parameters 'base_commit)) + (target-commit (assq-ref query-parameters 'target_commit)) + (systems (assq-ref query-parameters 'system)) + (targets (assq-ref query-parameters 'target)) + (build-statuses (assq-ref query-parameters 'build_status))) + (let* + ((data + (package-differences-data conn + (commit->revision-id conn base-commit) + (commit->revision-id conn target-commit) + #:systems systems + #:targets targets)) + (names-and-versions + (package-data->names-and-versions data))) + (let-values + (((base-packages-vhash target-packages-vhash) + (package-data->package-data-vhashes data))) + (let ((derivation-changes + (package-data-derivation-changes names-and-versions + base-packages-vhash + target-packages-vhash))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + derivation-changes + #:extra-headers http-headers-for-unchanging-content)) + (else + (render-html + #:sxml (compare/derivations + query-parameters + (valid-systems conn) + build-status-strings + derivation-changes) + #:extra-headers http-headers-for-unchanging-content))))))))) + +(define (render-compare-by-datetime/derivations mime-types + conn + query-parameters) + (define (derivations->alist derivations) + (map (match-lambda + ((file-name system target buildstatus) + `((file_name . ,file-name) + (system . ,system) + (target . ,target) + (build_status . ,(if (string=? buildstatus "") + "unknown" + buildstatus))))) + derivations)) + + (if (any-invalid-query-parameters? query-parameters) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + '((error . "invalid query")))) + (else + (render-html + #:sxml (compare-by-datetime/derivations + query-parameters + (valid-systems conn) + build-status-strings + '())))) + + (let ((base-branch (assq-ref query-parameters 'base_branch)) + (base-datetime (assq-ref query-parameters 'base_datetime)) + (target-branch (assq-ref query-parameters 'target_branch)) + (target-datetime (assq-ref query-parameters 'target_datetime)) + (systems (assq-ref query-parameters 'system)) + (targets (assq-ref query-parameters 'target)) + (build-statuses (assq-ref query-parameters 'build_status))) + (let* + ((base-revision-details + (select-guix-revision-for-branch-and-datetime conn + base-branch + base-datetime)) + (target-revision-details + (select-guix-revision-for-branch-and-datetime conn + target-branch + target-datetime)) + (data + (package-differences-data conn + (first base-revision-details) + (first target-revision-details) + #:systems systems + #:targets targets)) + (names-and-versions + (package-data->names-and-versions data))) + (let-values + (((base-packages-vhash target-packages-vhash) + (package-data->package-data-vhashes data))) + (let ((derivation-changes + (package-data-derivation-changes names-and-versions + base-packages-vhash + target-packages-vhash))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + derivation-changes + #:extra-headers http-headers-for-unchanging-content)) + (else + (render-html + #:sxml (compare-by-datetime/derivations + query-parameters + (valid-systems conn) + build-status-strings + base-revision-details + target-revision-details + derivation-changes) + #:extra-headers http-headers-for-unchanging-content))))))))) + +(define (render-compare/packages mime-types + conn + query-parameters) + (define (package-data-vhash->json vh) + (delete-duplicates + (vhash-fold (lambda (name data result) + (cons `((name . ,name) + (version . ,(car data))) + result)) + '() + vh))) + + (if (any-invalid-query-parameters? query-parameters) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + '((error . "invalid query")))) + (else + (render-html + #:sxml (compare-invalid-parameters + query-parameters + (match (assq-ref query-parameters 'base_commit) + (($ <invalid-query-parameter> value) + (select-job-for-commit conn value)) + (_ #f)) + (match (assq-ref query-parameters 'target_commit) + (($ <invalid-query-parameter> value) + (select-job-for-commit conn value)) + (_ #f)))))) + + (let ((base-commit (assq-ref query-parameters 'base_commit)) + (target-commit (assq-ref query-parameters 'target_commit))) + (let ((base-revision-id (commit->revision-id conn base-commit)) + (target-revision-id (commit->revision-id conn target-commit))) + + (let-values + (((base-packages-vhash target-packages-vhash) + (package-data->package-data-vhashes + (package-differences-data conn + base-revision-id + target-revision-id)))) + (case (most-appropriate-mime-type + '(application/json text/html) + mime-types) + ((application/json) + (render-json + `((base + . ((commit . ,base-commit) + (packages . ,(list->vector + (package-data-vhash->json base-packages-vhash))))) + (target + . ((commit . ,target-commit) + (packages . ,(list->vector + (package-data-vhash->json target-packages-vhash)))))) + #:extra-headers http-headers-for-unchanging-content)) + (else + (render-html + #:sxml (compare/packages + query-parameters + base-packages-vhash + target-packages-vhash) + #:extra-headers http-headers-for-unchanging-content)))))))) diff --git a/guix-data-service/web/compare/html.scm b/guix-data-service/web/compare/html.scm new file mode 100644 index 0000000..86be5a9 --- /dev/null +++ b/guix-data-service/web/compare/html.scm @@ -0,0 +1,661 @@ +;;; Guix Data Service -- Information about Guix over time +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU Affero General Public License +;;; as published by the Free Software Foundation, either version 3 of +;;; the License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Affero General Public License for more details. +;;; +;;; You should have received a copy of the GNU Affero General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (guix-data-service web compare html) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (guix-data-service web query-parameters) + #:use-module (guix-data-service web view html) + #:export (compare + compare/derivations + compare-by-datetime/derivations + compare/packages + compare-invalid-parameters)) + +(define (compare query-parameters + cgit-url-bases + new-packages + removed-packages + version-changes + lint-warnings-data) + (define base-commit + (assq-ref query-parameters 'base_commit)) + + (define target-commit + (assq-ref query-parameters 'target_commit)) + + (define query-params + (string-append "?base_commit=" base-commit + "&target_commit=" target-commit)) + + (layout + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-sm-8")) + (h1 "Comparing " + (samp ,(string-take base-commit 8) "…") + " and " + (samp ,(string-take target-commit 8) "…")) + ,@(if (apply string=? cgit-url-bases) + `((a (@ (href ,(string-append + (first cgit-url-bases) + "log/?qt=range&q=" + base-commit ".." target-commit))) + "(View cgit)")) + '())) + (div + (@ (class "col-sm-4")) + (div + (@ (class "btn-group-vertical btn-group-lg pull-right") + (style "margin-top: 2em;") + (role "group")) + (a (@ (class "btn btn-default") + (href ,(string-append "/compare/packages" query-params))) + "Compare packages") + (a (@ (class "btn btn-default") + (href ,(string-append "/compare/derivations" query-params))) + "Compare derivations")))) + (div + (@ (class "row") (style "clear: left;")) + (div + (@ (class "col-sm-12")) + (a (@ (class "btn btn-default btn-lg") + (href ,(string-append + "/compare.json" query-params))) + "View JSON"))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h3 (@ (style "clear: both;")) + "New packages") + ,(if (null? new-packages) + '(p "No new packages") + `(table + (@ (class "table")) + (thead + (tr + (th (@ (class "col-md-4")) "Name") + (th (@ (class "col-md-4")) "Version") + (th (@ (class "col-md-4")) ""))) + (tbody + ,@(map + (match-lambda + ((('name . name) + ('version . version)) + `(tr + (td ,name) + (td ,version) + (td (@ (class "text-right")) + (a (@ (href ,(string-append + "/revision/" target-commit + "/package/" name "/" version))) + "More information"))))) + new-packages)))))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h3 "Removed packages") + ,(if (null? removed-packages) + '(p "No removed packages") + `(table + (@ (class "table")) + (thead + (tr + (th (@ (class "col-md-4")) "Name") + (th (@ (class "col-md-4")) "Version") + (th (@ (class "col-md-4")) ""))) + (tbody + ,@(map + (match-lambda + ((('name . name) + ('version . version)) + `(tr + (td ,name) + (td ,version) + (td (@ (class "text-right")) + (a (@ (href ,(string-append + "/revision/" base-commit + "/package/" name "/" version))) + "More information"))))) + removed-packages)))))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h3 "Version changes") + ,(if + (null? version-changes) + '(p "No version changes") + `(table + (@ (class "table")) + (thead + (tr + (th (@ (class "col-md-3")) "Name") + (th (@ (class "col-md-9")) "Versions"))) + (tbody + ,@(map + (match-lambda + ((name . versions) + `(tr + (td ,name) + (td + (ul + ,@(map + (match-lambda + ((type . versions) + `(li (@ (class ,(if (eq? type 'base) + "text-danger" + "text-success"))) + (ul + (@ (class "list-inline") + (style "display: inline-block;")) + ,@(map + (lambda (version) + `(li (a (@ (href + ,(string-append + "/revision/" + (if (eq? type 'base) + base-commit + target-commit) + "/package/" + name "/" version))) + ,version))) + (vector->list versions))) + ,(if (eq? type 'base) + " (old)" + " (new)")))) + versions)))))) + version-changes)))))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h2 "Lint warnings") + ,@(if + (null? lint-warnings-data) + '((p "No lint warning changes")) + (map + (match-lambda + (((package-name package-version) . warnings) + `((h4 ,package-name " (version: " ,package-version ")") + (table + (@ (class "table")) + (thead + (tr + (th "") + (th "Linter") + (th "Message"))) + (tbody + ,@(map (match-lambda + ((lint-checker-name + message + lint-checker-description + lint-checker-network-dependent + file line column-number ;; TODO Maybe use the location? + change) + + `(tr + (td (@ (class ,(if (string=? change "new") + "text-danger" + "text-success")) + (style "font-weight: bold")) + ,(if (string=? change "new") + "New warning" + "Resolved warning")) + (td (span (@ (style "font-family: monospace; display: block;")) + ,lint-checker-name) + (p (@ (style "font-size: small; margin: 6px 0 0px;")) + ,lint-checker-description)) + (td ,message)))) + warnings)))))) + lint-warnings-data)))))))) + +(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") + (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 "Package derivation changes") + ,(if + (null? derivation-changes) + '(p "No derivation changes") + `(table + (@ (class "table") + (style "table-layout: fixed;")) + (thead + (tr + (th "Name") + (th "Version") + (th "System") + (th "Target") + (th (@ (class "col-xs-5")) "Derivations"))) + (tbody + ,@(append-map + (match-lambda + ((('name . name) + ('version . version) + ('base . base-derivations) + ('target . target-derivations)) + (let* ((system-and-versions + (delete-duplicates + (append (map (lambda (details) + (cons (assq-ref details 'system) + (assq-ref details 'target))) + (vector->list base-derivations)) + (map (lambda (details) + (cons (assq-ref details 'system) + (assq-ref details 'target))) + (vector->list target-derivations))))) + (data-columns + (map + (match-lambda + ((system . target) + (let ((base-derivation-file-name + (assq-ref (find (lambda (details) + (and (string=? (assq-ref details 'system) system) + (string=? (assq-ref details 'target) target))) + (vector->list base-derivations)) + 'derivation-file-name)) + (target-derivation-file-name + (assq-ref (find (lambda (details) + (and (string=? (assq-ref details 'system) system) + (string=? (assq-ref details 'target) target))) + (vector->list target-derivations)) + 'derivation-file-name))) + `((td (samp (@ (style "white-space: nowrap;")) + ,system)) + (td (samp (@ (style "white-space: nowrap;")) + ,target)) + (td ,@(if base-derivation-file-name + `((a (@ (style "display: block;") + (href ,base-derivation-file-name)) + (span (@ (class "text-danger glyphicon glyphicon-minus pull-left") + (style "font-size: 1.5em; padding-right: 0.4em;"))) + ,(display-store-item-short base-derivation-file-name))) + '()) + ,@(if target-derivation-file-name + `((a (@ (style "display: block; clear: left;") + (href ,target-derivation-file-name)) + (span (@ (class "text-success glyphicon glyphicon-plus pull-left") + (style "font-size: 1.5em; padding-right: 0.4em;"))) + ,(and=> target-derivation-file-name display-store-item-short))) + '())))))) + system-and-versions))) + + `((tr (td (@ (rowspan , (length system-and-versions))) + ,name) + (td (@ (rowspan , (length system-and-versions))) + ,version) + ,@(car data-columns)) + ,@(map (lambda (data-row) + `(tr ,data-row)) + (cdr data-columns)))))) + (vector->list derivation-changes))))))))))) + +(define (compare-by-datetime/derivations query-parameters + valid-systems + valid-build-statuses + base-revision-details + target-revision-details + 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 branch" query-parameters + #:required? #t + #:help-text "The branch to compare from." + #:font-family "monospace") + ,(form-horizontal-control + "Base datetime" query-parameters + #:required? #t + #:help-text "The date and time to compare from." + #:font-family "monospace") + ,(form-horizontal-control + "Target branch" query-parameters + #:required? #t + #:help-text "The branch to compare to." + #:font-family "monospace") + ,(form-horizontal-control + "Target datetime" query-parameters + #:required? #t + #:help-text "The date and time to compare to." + #: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") + (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")) + (div + (a (@ (href ,(string-append "/revision/" (second base-revision-details)))) + "Base revision: " ,(second base-revision-details))) + (div + (a (@ (href ,(string-append "/revision/" (second target-revision-details)))) + "Target revision: " ,(second target-revision-details))) + (h3 "Package derivation changes") + ,(if + (null? derivation-changes) + '(p "No derivation changes") + `(table + (@ (class "table") + (style "table-layout: fixed;")) + (thead + (tr + (th "Name") + (th "Version") + (th "System") + (th "Target") + (th (@ (class "col-xs-5")) "Derivations"))) + (tbody + ,@(append-map + (match-lambda + ((('name . name) + ('version . version) + ('base . base-derivations) + ('target . target-derivations)) + (let* ((system-and-versions + (delete-duplicates + (append (map (lambda (details) + (cons (assq-ref details 'system) + (assq-ref details 'target))) + (vector->list base-derivations)) + (map (lambda (details) + (cons (assq-ref details 'system) + (assq-ref details 'target))) + (vector->list target-derivations))))) + (data-columns + (map + (match-lambda + ((system . target) + (let ((base-derivation-file-name + (assq-ref (find (lambda (details) + (and (string=? (assq-ref details 'system) system) + (string=? (assq-ref details 'target) target))) + (vector->list base-derivations)) + 'derivation-file-name)) + (target-derivation-file-name + (assq-ref (find (lambda (details) + (and (string=? (assq-ref details 'system) system) + (string=? (assq-ref details 'target) target))) + (vector->list target-derivations)) + 'derivation-file-name))) + `((td (samp (@ (style "white-space: nowrap;")) + ,system)) + (td (samp (@ (style "white-space: nowrap;")) + ,target)) + (td ,@(if base-derivation-file-name + `((a (@ (style "display: block;") + (href ,base-derivation-file-name)) + (span (@ (class "text-danger glyphicon glyphicon-minus pull-left") + (style "font-size: 1.5em; padding-right: 0.4em;"))) + ,(display-store-item-short base-derivation-file-name))) + '()) + ,@(if target-derivation-file-name + `((a (@ (style "display: block; clear: left;") + (href ,target-derivation-file-name)) + (span (@ (class "text-success glyphicon glyphicon-plus pull-left") + (style "font-size: 1.5em; padding-right: 0.4em;"))) + ,(and=> target-derivation-file-name display-store-item-short))) + '())))))) + system-and-versions))) + + `((tr (td (@ (rowspan , (length system-and-versions))) + ,name) + (td (@ (rowspan , (length system-and-versions))) + ,version) + ,@(car data-columns)) + ,@(map (lambda (data-row) + `(tr ,data-row)) + (cdr data-columns)))))) + (vector->list derivation-changes))))))))))) + +(define (compare/packages query-parameters + base-packages-vhash + target-packages-vhash) + (define base-commit + (assq-ref query-parameters 'base_commit)) + + (define target-commit + (assq-ref query-parameters 'target_commit)) + + (define query-params + (string-append "?base_commit=" base-commit + "&target_commit=" target-commit)) + + (layout + #:body + `(,(header) + (div + (@ (class "container")) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (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/packages.json" query-params))) + "View JSON"))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h3 "Base (" + (samp ,base-commit) + ")") + (p "Packages found in the base revision.") + (table + (@ (class "table")) + (thead + (tr + (th (@ (class "col-md-4")) "Name") + (th (@ (class "col-md-4")) "Version") + (th (@ (class "col-md-4")) ""))) + (tbody + ,@(map + (match-lambda + ((name version) + `(tr + (td ,name) + (td ,version) + (td (@ (class "text-right")) + (a (@ (href ,(string-append + "/revision/" base-commit + "/package/" name "/" version))) + "More information"))))) + (delete-duplicates + (map (lambda (data) + (take data 2)) + (vlist->list base-packages-vhash)))))))) + (div + (@ (class "row")) + (div + (@ (class "col-sm-12")) + (h3 "Target (" + (samp ,target-commit) + ")") + (p "Packages found in the target revision.") + (table + (@ (class "table")) + (thead + (tr + (th (@ (class "col-md-4")) "Name") + (th (@ (class "col-md-4")) "Version") + (th (@ (class "col-md-4")) ""))) + (tbody + ,@(map + (match-lambda + ((name version) + `(tr + (td ,name) + (td ,version) + (td (@ (class "text-right")) + (a (@ (href ,(string-append + "/revision/" target-commit + "/package/" name "/" version))) + "More information"))))) + (delete-duplicates + (map (lambda (data) + (take data 2)) + (vlist->list target-packages-vhash)))))))))))) + +(define (compare-invalid-parameters query-parameters + base-job + target-job) + (define base-commit + (assq-ref query-parameters 'base_commit)) + + (define target-commit + (peek (assq-ref query-parameters 'target_commit))) + + (layout + #:body + `(,(header) + (div (@ (class "container")) + (h1 "Unknown commit") + ,(if (invalid-query-parameter? base-commit) + `(p "No known revision with commit " + (strong (samp ,(invalid-query-parameter-value base-commit))) + ,(if (null? base-job) + " and it is not currently queued for processing" + " but it is queued for processing")) + '()) + ,(if (invalid-query-parameter? target-commit) + `(p "No known revision with commit " + (strong (samp ,(invalid-query-parameter-value target-commit))) + ,(if (null? target-job) + " and it is not currently queued for processing" + " but it is queued for processing")) + '()))))) diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index 769d2dd..b5df73b 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -53,6 +53,7 @@ #:use-module (guix-data-service web revision controller) #:use-module (guix-data-service web jobs controller) #:use-module (guix-data-service web view html) + #:use-module (guix-data-service web compare controller) #:use-module (guix-data-service web revision controller) #:use-module (guix-data-service web repository controller) #:export (controller)) @@ -91,383 +92,6 @@ value))) alist)) -(define (render-compare mime-types - conn - query-parameters) - (if (any-invalid-query-parameters? query-parameters) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - '((error . "invalid query")))) - (else - (render-html - #:sxml (compare-invalid-parameters - query-parameters - (match (assq-ref query-parameters 'base_commit) - (($ <invalid-query-parameter> value) - (select-job-for-commit conn value)) - (_ #f)) - (match (assq-ref query-parameters 'target_commit) - (($ <invalid-query-parameter> value) - (select-job-for-commit conn value)) - (_ #f)))))) - - (let ((base-revision-id (commit->revision-id - conn - (assq-ref query-parameters 'base_commit))) - (target-revision-id (commit->revision-id - conn - (assq-ref query-parameters 'target_commit)))) - (let-values - (((base-packages-vhash target-packages-vhash) - (package-data->package-data-vhashes - (package-differences-data conn - base-revision-id - target-revision-id)))) - (let* ((new-packages - (package-data-vhashes->new-packages base-packages-vhash - target-packages-vhash)) - (removed-packages - (package-data-vhashes->removed-packages base-packages-vhash - target-packages-vhash)) - (version-changes - (package-data-version-changes base-packages-vhash - target-packages-vhash)) - (lint-warnings-data - (group-list-by-first-n-fields - 2 - (lint-warning-differences-data conn - base-revision-id - target-revision-id)))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((new-packages . ,(list->vector new-packages)) - (removed-packages . ,(list->vector removed-packages)) - (version-changes . ,(list->vector - (map - (match-lambda - ((name data ...) - `((name . ,name) - ,@data))) - version-changes)))) - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (compare query-parameters - (guix-revisions-cgit-url-bases - conn - (list base-revision-id - target-revision-id)) - new-packages - removed-packages - version-changes - lint-warnings-data) - #:extra-headers http-headers-for-unchanging-content)))))))) - -(define (render-compare-by-datetime mime-types - conn - query-parameters) - (if (any-invalid-query-parameters? query-parameters) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - '((error . "invalid query")))) - (else - (render-html - #:sxml (compare-invalid-parameters - query-parameters - (match (assq-ref query-parameters 'base_commit) - (($ <invalid-query-parameter> value) - (select-job-for-commit conn value)) - (_ #f)) - (match (assq-ref query-parameters 'target_commit) - (($ <invalid-query-parameter> value) - (select-job-for-commit conn value)) - (_ #f)))))) - - (let ((base-branch (assq-ref query-parameters 'base_branch)) - (base-datetime (assq-ref query-parameters 'base_datetime)) - (target-branch (assq-ref query-parameters 'target_branch)) - (target-datetime (assq-ref query-parameters 'target_datetime))) - (let* ((base-revision-details - (select-guix-revision-for-branch-and-datetime conn - base-branch - base-datetime)) - (base-revision-id - (first base-revision-details)) - (target-revision-details - (select-guix-revision-for-branch-and-datetime conn - target-branch - target-datetime)) - (target-revision-id - (first target-revision-details))) - (let-values - (((base-packages-vhash target-packages-vhash) - (package-data->package-data-vhashes - (package-differences-data conn - base-revision-id - target-revision-id)))) - (let* ((new-packages - (package-data-vhashes->new-packages base-packages-vhash - target-packages-vhash)) - (removed-packages - (package-data-vhashes->removed-packages base-packages-vhash - target-packages-vhash)) - (version-changes - (package-data-version-changes base-packages-vhash - target-packages-vhash)) - (lint-warnings-data - (group-list-by-first-n-fields - 2 - (lint-warning-differences-data conn - base-revision-id - target-revision-id)))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((new-packages . ,(list->vector new-packages)) - (removed-packages . ,(list->vector removed-packages)) - (version-changes . ,(list->vector - (map - (match-lambda - ((name data ...) - `((name . ,name) - ,@data))) - version-changes)))) - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (compare `(,@query-parameters - (base_commit . ,(second base-revision-details)) - (target_commit . ,(second target-revision-details))) - (guix-revisions-cgit-url-bases - conn - (list base-revision-id - target-revision-id)) - new-packages - removed-packages - version-changes - lint-warnings-data) - #:extra-headers http-headers-for-unchanging-content))))))))) - -(define (render-compare/derivations mime-types - conn - query-parameters) - (define (derivations->alist derivations) - (map (match-lambda - ((file-name system target buildstatus) - `((file_name . ,file-name) - (system . ,system) - (target . ,target) - (build_status . ,(if (string=? buildstatus "") - "unknown" - buildstatus))))) - derivations)) - - (if (any-invalid-query-parameters? query-parameters) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - '((error . "invalid query")))) - (else - (render-html - #:sxml (compare/derivations - query-parameters - (valid-systems conn) - build-status-strings - '())))) - - (let ((base-commit (assq-ref query-parameters 'base_commit)) - (target-commit (assq-ref query-parameters 'target_commit)) - (systems (assq-ref query-parameters 'system)) - (targets (assq-ref query-parameters 'target)) - (build-statuses (assq-ref query-parameters 'build_status))) - (let* - ((data - (package-differences-data conn - (commit->revision-id conn base-commit) - (commit->revision-id conn target-commit) - #:systems systems - #:targets targets)) - (names-and-versions - (package-data->names-and-versions data))) - (let-values - (((base-packages-vhash target-packages-vhash) - (package-data->package-data-vhashes data))) - (let ((derivation-changes - (package-data-derivation-changes names-and-versions - base-packages-vhash - target-packages-vhash))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - derivation-changes - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (compare/derivations - query-parameters - (valid-systems conn) - build-status-strings - derivation-changes) - #:extra-headers http-headers-for-unchanging-content))))))))) - -(define (render-compare-by-datetime/derivations mime-types - conn - query-parameters) - (define (derivations->alist derivations) - (map (match-lambda - ((file-name system target buildstatus) - `((file_name . ,file-name) - (system . ,system) - (target . ,target) - (build_status . ,(if (string=? buildstatus "") - "unknown" - buildstatus))))) - derivations)) - - (if (any-invalid-query-parameters? query-parameters) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - '((error . "invalid query")))) - (else - (render-html - #:sxml (compare-by-datetime/derivations - query-parameters - (valid-systems conn) - build-status-strings - '())))) - - (let ((base-branch (assq-ref query-parameters 'base_branch)) - (base-datetime (assq-ref query-parameters 'base_datetime)) - (target-branch (assq-ref query-parameters 'target_branch)) - (target-datetime (assq-ref query-parameters 'target_datetime)) - (systems (assq-ref query-parameters 'system)) - (targets (assq-ref query-parameters 'target)) - (build-statuses (assq-ref query-parameters 'build_status))) - (let* - ((base-revision-details - (select-guix-revision-for-branch-and-datetime conn - base-branch - base-datetime)) - (target-revision-details - (select-guix-revision-for-branch-and-datetime conn - target-branch - target-datetime)) - (data - (package-differences-data conn - (first base-revision-details) - (first target-revision-details) - #:systems systems - #:targets targets)) - (names-and-versions - (package-data->names-and-versions data))) - (let-values - (((base-packages-vhash target-packages-vhash) - (package-data->package-data-vhashes data))) - (let ((derivation-changes - (package-data-derivation-changes names-and-versions - base-packages-vhash - target-packages-vhash))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - derivation-changes - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (compare-by-datetime/derivations - query-parameters - (valid-systems conn) - build-status-strings - base-revision-details - target-revision-details - derivation-changes) - #:extra-headers http-headers-for-unchanging-content))))))))) - -(define (render-compare/packages mime-types - conn - query-parameters) - (define (package-data-vhash->json vh) - (delete-duplicates - (vhash-fold (lambda (name data result) - (cons `((name . ,name) - (version . ,(car data))) - result)) - '() - vh))) - - (if (any-invalid-query-parameters? query-parameters) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - '((error . "invalid query")))) - (else - (render-html - #:sxml (compare-invalid-parameters - query-parameters - (match (assq-ref query-parameters 'base_commit) - (($ <invalid-query-parameter> value) - (select-job-for-commit conn value)) - (_ #f)) - (match (assq-ref query-parameters 'target_commit) - (($ <invalid-query-parameter> value) - (select-job-for-commit conn value)) - (_ #f)))))) - - (let ((base-commit (assq-ref query-parameters 'base_commit)) - (target-commit (assq-ref query-parameters 'target_commit))) - (let ((base-revision-id (commit->revision-id conn base-commit)) - (target-revision-id (commit->revision-id conn target-commit))) - - (let-values - (((base-packages-vhash target-packages-vhash) - (package-data->package-data-vhashes - (package-differences-data conn - base-revision-id - target-revision-id)))) - (case (most-appropriate-mime-type - '(application/json text/html) - mime-types) - ((application/json) - (render-json - `((base - . ((commit . ,base-commit) - (packages . ,(list->vector - (package-data-vhash->json base-packages-vhash))))) - (target - . ((commit . ,target-commit) - (packages . ,(list->vector - (package-data-vhash->json target-packages-vhash)))))) - #:extra-headers http-headers-for-unchanging-content)) - (else - (render-html - #:sxml (compare/packages - query-parameters - base-packages-vhash - target-packages-vhash) - #:extra-headers http-headers-for-unchanging-content)))))))) - (define (render-derivation conn derivation-file-name) (let ((derivation (select-derivation-by-file-name conn derivation-file-name))) @@ -515,19 +139,6 @@ derivations)) #:extra-headers http-headers-for-unchanging-content))))) -(define (parse-commit conn) - (lambda (s) - (if (guix-commit-exists? conn s) - s - (make-invalid-query-parameter - s "unknown commit")))) - -(define (parse-system s) - s) - -(define (parse-build-status s) - s) - (define handle-static-assets (if assets-dir-in-store? (static-asset-from-store-renderer) @@ -627,64 +238,8 @@ (if (string-suffix? ".drv" path) (render-derivation conn path) (render-store-item conn path)))) - (('GET "compare") - (let* ((parsed-query-parameters - (parse-query-parameters - request - `((base_commit ,(parse-commit conn) #:required) - (target_commit ,(parse-commit conn) #:required))))) - (render-compare mime-types - conn - parsed-query-parameters))) - (('GET "compare-by-datetime") - (let* ((parsed-query-parameters - (parse-query-parameters - request - `((base_branch ,identity #:required) - (base_datetime ,parse-datetime #:required) - (target_branch ,identity #:required) - (target_datetime ,parse-datetime #:required))))) - (render-compare-by-datetime mime-types - conn - parsed-query-parameters))) - (('GET "compare" "derivations") - (let* ((parsed-query-parameters - (parse-query-parameters - request - `((base_commit ,(parse-commit conn) #:required) - (target_commit ,(parse-commit conn) #:required) - (system ,parse-system #:multi-value) - (target ,parse-system #:multi-value) - (build_status ,parse-build-status #:multi-value))))) - (render-compare/derivations mime-types - conn - parsed-query-parameters))) - (('GET "compare-by-datetime" "derivations") - (let* ((parsed-query-parameters - (guard-against-mutually-exclusive-query-parameters - (parse-query-parameters - request - `((base_branch ,identity #:required) - (base_datetime ,parse-datetime #:required) - (target_branch ,identity #:required) - (target_datetime ,parse-datetime #:required) - (system ,parse-system #:multi-value) - (target ,parse-system #:multi-value) - (build_status ,parse-build-status #:multi-value))) - '((base_commit base_datetime) - (target_commit target_datetime))))) - (render-compare-by-datetime/derivations mime-types - conn - parsed-query-parameters))) - (('GET "compare" "packages") - (let* ((parsed-query-parameters - (parse-query-parameters - request - `((base_commit ,(parse-commit conn) #:required) - (target_commit ,(parse-commit conn) #:required))))) - (render-compare/packages mime-types - conn - parsed-query-parameters))) + (('GET "compare" _ ...) (delegate-to compare-controller)) + (('GET "compare-by-datetime" _ ...) (delegate-to compare-controller)) (('GET "jobs") (delegate-to jobs-controller)) (('GET "jobs" "queue") (delegate-to jobs-controller)) (('GET "job" job-id) (delegate-to jobs-controller)) diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index 0972063..ae9fe0e 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -44,11 +44,6 @@ view-builds view-derivation view-store-item - compare - compare/derivations - compare-by-datetime/derivations - compare/packages - compare-invalid-parameters error-page)) (define* (header) @@ -581,610 +576,6 @@ ,(display-store-item-short path)))))) derivation-outputs))))))))) -(define (compare query-parameters - cgit-url-bases - new-packages - removed-packages - version-changes - lint-warnings-data) - (define base-commit - (assq-ref query-parameters 'base_commit)) - - (define target-commit - (assq-ref query-parameters 'target_commit)) - - (define query-params - (string-append "?base_commit=" base-commit - "&target_commit=" target-commit)) - - (layout - #:body - `(,(header) - (div - (@ (class "container")) - (div - (@ (class "row")) - (div - (@ (class "col-sm-8")) - (h1 "Comparing " - (samp ,(string-take base-commit 8) "…") - " and " - (samp ,(string-take target-commit 8) "…")) - ,@(if (apply string=? cgit-url-bases) - `((a (@ (href ,(string-append - (first cgit-url-bases) - "log/?qt=range&q=" - base-commit ".." target-commit))) - "(View cgit)")) - '())) - (div - (@ (class "col-sm-4")) - (div - (@ (class "btn-group-vertical btn-group-lg pull-right") - (style "margin-top: 2em;") - (role "group")) - (a (@ (class "btn btn-default") - (href ,(string-append "/compare/packages" query-params))) - "Compare packages") - (a (@ (class "btn btn-default") - (href ,(string-append "/compare/derivations" query-params))) - "Compare derivations")))) - (div - (@ (class "row") (style "clear: left;")) - (div - (@ (class "col-sm-12")) - (a (@ (class "btn btn-default btn-lg") - (href ,(string-append - "/compare.json" query-params))) - "View JSON"))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (h3 (@ (style "clear: both;")) - "New packages") - ,(if (null? new-packages) - '(p "No new packages") - `(table - (@ (class "table")) - (thead - (tr - (th (@ (class "col-md-4")) "Name") - (th (@ (class "col-md-4")) "Version") - (th (@ (class "col-md-4")) ""))) - (tbody - ,@(map - (match-lambda - ((('name . name) - ('version . version)) - `(tr - (td ,name) - (td ,version) - (td (@ (class "text-right")) - (a (@ (href ,(string-append - "/revision/" target-commit - "/package/" name "/" version))) - "More information"))))) - new-packages)))))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (h3 "Removed packages") - ,(if (null? removed-packages) - '(p "No removed packages") - `(table - (@ (class "table")) - (thead - (tr - (th (@ (class "col-md-4")) "Name") - (th (@ (class "col-md-4")) "Version") - (th (@ (class "col-md-4")) ""))) - (tbody - ,@(map - (match-lambda - ((('name . name) - ('version . version)) - `(tr - (td ,name) - (td ,version) - (td (@ (class "text-right")) - (a (@ (href ,(string-append - "/revision/" base-commit - "/package/" name "/" version))) - "More information"))))) - removed-packages)))))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (h3 "Version changes") - ,(if - (null? version-changes) - '(p "No version changes") - `(table - (@ (class "table")) - (thead - (tr - (th (@ (class "col-md-3")) "Name") - (th (@ (class "col-md-9")) "Versions"))) - (tbody - ,@(map - (match-lambda - ((name . versions) - `(tr - (td ,name) - (td - (ul - ,@(map - (match-lambda - ((type . versions) - `(li (@ (class ,(if (eq? type 'base) - "text-danger" - "text-success"))) - (ul - (@ (class "list-inline") - (style "display: inline-block;")) - ,@(map - (lambda (version) - `(li (a (@ (href - ,(string-append - "/revision/" - (if (eq? type 'base) - base-commit - target-commit) - "/package/" - name "/" version))) - ,version))) - (vector->list versions))) - ,(if (eq? type 'base) - " (old)" - " (new)")))) - versions)))))) - version-changes)))))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (h2 "Lint warnings") - ,@(if - (null? lint-warnings-data) - '((p "No lint warning changes")) - (map - (match-lambda - (((package-name package-version) . warnings) - `((h4 ,package-name " (version: " ,package-version ")") - (table - (@ (class "table")) - (thead - (tr - (th "") - (th "Linter") - (th "Message"))) - (tbody - ,@(map (match-lambda - ((lint-checker-name - message - lint-checker-description - lint-checker-network-dependent - file line column-number ;; TODO Maybe use the location? - change) - - `(tr - (td (@ (class ,(if (string=? change "new") - "text-danger" - "text-success")) - (style "font-weight: bold")) - ,(if (string=? change "new") - "New warning" - "Resolved warning")) - (td (span (@ (style "font-family: monospace; display: block;")) - ,lint-checker-name) - (p (@ (style "font-size: small; margin: 6px 0 0px;")) - ,lint-checker-description)) - (td ,message)))) - warnings)))))) - lint-warnings-data)))))))) - -(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") - (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 "Package derivation changes") - ,(if - (null? derivation-changes) - '(p "No derivation changes") - `(table - (@ (class "table") - (style "table-layout: fixed;")) - (thead - (tr - (th "Name") - (th "Version") - (th "System") - (th "Target") - (th (@ (class "col-xs-5")) "Derivations"))) - (tbody - ,@(append-map - (match-lambda - ((('name . name) - ('version . version) - ('base . base-derivations) - ('target . target-derivations)) - (let* ((system-and-versions - (delete-duplicates - (append (map (lambda (details) - (cons (assq-ref details 'system) - (assq-ref details 'target))) - (vector->list base-derivations)) - (map (lambda (details) - (cons (assq-ref details 'system) - (assq-ref details 'target))) - (vector->list target-derivations))))) - (data-columns - (map - (match-lambda - ((system . target) - (let ((base-derivation-file-name - (assq-ref (find (lambda (details) - (and (string=? (assq-ref details 'system) system) - (string=? (assq-ref details 'target) target))) - (vector->list base-derivations)) - 'derivation-file-name)) - (target-derivation-file-name - (assq-ref (find (lambda (details) - (and (string=? (assq-ref details 'system) system) - (string=? (assq-ref details 'target) target))) - (vector->list target-derivations)) - 'derivation-file-name))) - `((td (samp (@ (style "white-space: nowrap;")) - ,system)) - (td (samp (@ (style "white-space: nowrap;")) - ,target)) - (td ,@(if base-derivation-file-name - `((a (@ (style "display: block;") - (href ,base-derivation-file-name)) - (span (@ (class "text-danger glyphicon glyphicon-minus pull-left") - (style "font-size: 1.5em; padding-right: 0.4em;"))) - ,(display-store-item-short base-derivation-file-name))) - '()) - ,@(if target-derivation-file-name - `((a (@ (style "display: block; clear: left;") - (href ,target-derivation-file-name)) - (span (@ (class "text-success glyphicon glyphicon-plus pull-left") - (style "font-size: 1.5em; padding-right: 0.4em;"))) - ,(and=> target-derivation-file-name display-store-item-short))) - '())))))) - system-and-versions))) - - `((tr (td (@ (rowspan , (length system-and-versions))) - ,name) - (td (@ (rowspan , (length system-and-versions))) - ,version) - ,@(car data-columns)) - ,@(map (lambda (data-row) - `(tr ,data-row)) - (cdr data-columns)))))) - (vector->list derivation-changes))))))))))) - -(define (compare-by-datetime/derivations query-parameters - valid-systems - valid-build-statuses - base-revision-details - target-revision-details - 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 branch" query-parameters - #:required? #t - #:help-text "The branch to compare from." - #:font-family "monospace") - ,(form-horizontal-control - "Base datetime" query-parameters - #:required? #t - #:help-text "The date and time to compare from." - #:font-family "monospace") - ,(form-horizontal-control - "Target branch" query-parameters - #:required? #t - #:help-text "The branch to compare to." - #:font-family "monospace") - ,(form-horizontal-control - "Target datetime" query-parameters - #:required? #t - #:help-text "The date and time to compare to." - #: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") - (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")) - (div - (a (@ (href ,(string-append "/revision/" (second base-revision-details)))) - "Base revision: " ,(second base-revision-details))) - (div - (a (@ (href ,(string-append "/revision/" (second target-revision-details)))) - "Target revision: " ,(second target-revision-details))) - (h3 "Package derivation changes") - ,(if - (null? derivation-changes) - '(p "No derivation changes") - `(table - (@ (class "table") - (style "table-layout: fixed;")) - (thead - (tr - (th "Name") - (th "Version") - (th "System") - (th "Target") - (th (@ (class "col-xs-5")) "Derivations"))) - (tbody - ,@(append-map - (match-lambda - ((('name . name) - ('version . version) - ('base . base-derivations) - ('target . target-derivations)) - (let* ((system-and-versions - (delete-duplicates - (append (map (lambda (details) - (cons (assq-ref details 'system) - (assq-ref details 'target))) - (vector->list base-derivations)) - (map (lambda (details) - (cons (assq-ref details 'system) - (assq-ref details 'target))) - (vector->list target-derivations))))) - (data-columns - (map - (match-lambda - ((system . target) - (let ((base-derivation-file-name - (assq-ref (find (lambda (details) - (and (string=? (assq-ref details 'system) system) - (string=? (assq-ref details 'target) target))) - (vector->list base-derivations)) - 'derivation-file-name)) - (target-derivation-file-name - (assq-ref (find (lambda (details) - (and (string=? (assq-ref details 'system) system) - (string=? (assq-ref details 'target) target))) - (vector->list target-derivations)) - 'derivation-file-name))) - `((td (samp (@ (style "white-space: nowrap;")) - ,system)) - (td (samp (@ (style "white-space: nowrap;")) - ,target)) - (td ,@(if base-derivation-file-name - `((a (@ (style "display: block;") - (href ,base-derivation-file-name)) - (span (@ (class "text-danger glyphicon glyphicon-minus pull-left") - (style "font-size: 1.5em; padding-right: 0.4em;"))) - ,(display-store-item-short base-derivation-file-name))) - '()) - ,@(if target-derivation-file-name - `((a (@ (style "display: block; clear: left;") - (href ,target-derivation-file-name)) - (span (@ (class "text-success glyphicon glyphicon-plus pull-left") - (style "font-size: 1.5em; padding-right: 0.4em;"))) - ,(and=> target-derivation-file-name display-store-item-short))) - '())))))) - system-and-versions))) - - `((tr (td (@ (rowspan , (length system-and-versions))) - ,name) - (td (@ (rowspan , (length system-and-versions))) - ,version) - ,@(car data-columns)) - ,@(map (lambda (data-row) - `(tr ,data-row)) - (cdr data-columns)))))) - (vector->list derivation-changes))))))))))) - -(define (compare/packages query-parameters - base-packages-vhash - target-packages-vhash) - (define base-commit - (assq-ref query-parameters 'base_commit)) - - (define target-commit - (assq-ref query-parameters 'target_commit)) - - (define query-params - (string-append "?base_commit=" base-commit - "&target_commit=" target-commit)) - - (layout - #:body - `(,(header) - (div - (@ (class "container")) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (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/packages.json" query-params))) - "View JSON"))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (h3 "Base (" - (samp ,base-commit) - ")") - (p "Packages found in the base revision.") - (table - (@ (class "table")) - (thead - (tr - (th (@ (class "col-md-4")) "Name") - (th (@ (class "col-md-4")) "Version") - (th (@ (class "col-md-4")) ""))) - (tbody - ,@(map - (match-lambda - ((name version) - `(tr - (td ,name) - (td ,version) - (td (@ (class "text-right")) - (a (@ (href ,(string-append - "/revision/" base-commit - "/package/" name "/" version))) - "More information"))))) - (delete-duplicates - (map (lambda (data) - (take data 2)) - (vlist->list base-packages-vhash)))))))) - (div - (@ (class "row")) - (div - (@ (class "col-sm-12")) - (h3 "Target (" - (samp ,target-commit) - ")") - (p "Packages found in the target revision.") - (table - (@ (class "table")) - (thead - (tr - (th (@ (class "col-md-4")) "Name") - (th (@ (class "col-md-4")) "Version") - (th (@ (class "col-md-4")) ""))) - (tbody - ,@(map - (match-lambda - ((name version) - `(tr - (td ,name) - (td ,version) - (td (@ (class "text-right")) - (a (@ (href ,(string-append - "/revision/" target-commit - "/package/" name "/" version))) - "More information"))))) - (delete-duplicates - (map (lambda (data) - (take data 2)) - (vlist->list target-packages-vhash)))))))))))) - (define (general-not-found header-text body) (layout #:body @@ -1194,35 +585,6 @@ (h1 ,header-text) (p ,body))))) -(define (compare-invalid-parameters query-parameters - base-job - target-job) - (define base-commit - (assq-ref query-parameters 'base_commit)) - - (define target-commit - (peek (assq-ref query-parameters 'target_commit))) - - (layout - #:body - `(,(header) - (div (@ (class "container")) - (h1 "Unknown commit") - ,(if (invalid-query-parameter? base-commit) - `(p "No known revision with commit " - (strong (samp ,(invalid-query-parameter-value base-commit))) - ,(if (null? base-job) - " and it is not currently queued for processing" - " but it is queued for processing")) - '()) - ,(if (invalid-query-parameter? target-commit) - `(p "No known revision with commit " - (strong (samp ,(invalid-query-parameter-value target-commit))) - ,(if (null? target-job) - " and it is not currently queued for processing" - " but it is queued for processing")) - '()))))) - (define (error-page message) (layout #:body |