Add a variant of compare/derivations to work with a branch and datetime
This commit is contained in:
Christopher Baines
parent
fc6aeab4ed
commit
15db1b0688
|
|
@ -601,6 +601,84 @@
|
|||
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)
|
||||
|
|
@ -1112,6 +1190,23 @@
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -50,6 +50,7 @@
|
|||
view-job
|
||||
compare
|
||||
compare/derivations
|
||||
compare-by-datetime/derivations
|
||||
compare/packages
|
||||
compare-invalid-parameters
|
||||
error-page))
|
||||
|
|
@ -2061,6 +2062,168 @@
|
|||
(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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue