Extract the comparison pages out from the main modules

In to their own modules. This should help make the code more understandable,
and allow future refactoring for readability.
This commit is contained in:
Christopher Baines 2019-10-14 19:24:14 +01:00
parent 94256c4fa1
commit 4ce8d9e830
4 changed files with 1158 additions and 1086 deletions

View File

@ -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))))))))

View File

@ -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"))
'())))))

View File

@ -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))

View File

@ -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