aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix-data-service/web/compare/controller.scm494
-rw-r--r--guix-data-service/web/compare/html.scm661
-rw-r--r--guix-data-service/web/controller.scm451
-rw-r--r--guix-data-service/web/view/html.scm638
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