Consolidate the package derivation comparison code
This commit is contained in:
parent
0c3e208a83
commit
7e1cba3309
2 changed files with 77 additions and 186 deletions
|
|
@ -645,10 +645,14 @@
|
||||||
'((error . "invalid query"))))
|
'((error . "invalid query"))))
|
||||||
(else
|
(else
|
||||||
(render-html
|
(render-html
|
||||||
#:sxml (compare-by-datetime/package-derivations
|
#:sxml (compare/package-derivations
|
||||||
query-parameters
|
query-parameters
|
||||||
|
'datetime
|
||||||
(parallel-via-thread-pool-channel
|
(parallel-via-thread-pool-channel
|
||||||
(with-thread-postgresql-connection valid-systems))
|
(with-thread-postgresql-connection valid-systems))
|
||||||
|
(valid-targets->options
|
||||||
|
(parallel-via-thread-pool-channel
|
||||||
|
(with-thread-postgresql-connection valid-targets)))
|
||||||
build-status-strings
|
build-status-strings
|
||||||
'()
|
'()
|
||||||
'()
|
'()
|
||||||
|
|
@ -708,14 +712,21 @@
|
||||||
derivation-changes))
|
derivation-changes))
|
||||||
(else
|
(else
|
||||||
(render-html
|
(render-html
|
||||||
#:sxml (compare-by-datetime/package-derivations
|
#:sxml (compare/package-derivations
|
||||||
query-parameters
|
query-parameters
|
||||||
|
'datetime
|
||||||
(parallel-via-thread-pool-channel
|
(parallel-via-thread-pool-channel
|
||||||
(with-thread-postgresql-connection valid-systems))
|
(with-thread-postgresql-connection valid-systems))
|
||||||
|
(valid-targets->options
|
||||||
|
(parallel-via-thread-pool-channel
|
||||||
|
(with-thread-postgresql-connection valid-targets)))
|
||||||
build-status-strings
|
build-status-strings
|
||||||
|
(parallel-via-thread-pool-channel
|
||||||
|
(with-thread-postgresql-connection
|
||||||
|
select-build-server-urls-by-id))
|
||||||
|
derivation-changes
|
||||||
base-revision-details
|
base-revision-details
|
||||||
target-revision-details
|
target-revision-details))))))))))))
|
||||||
derivation-changes))))))))))))
|
|
||||||
|
|
||||||
(define (render-compare/packages mime-types
|
(define (render-compare/packages mime-types
|
||||||
query-parameters)
|
query-parameters)
|
||||||
|
|
|
||||||
|
|
@ -17,6 +17,7 @@
|
||||||
|
|
||||||
(define-module (guix-data-service web compare html)
|
(define-module (guix-data-service web compare html)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-19)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (ice-9 vlist)
|
#:use-module (ice-9 vlist)
|
||||||
#:use-module (texinfo)
|
#:use-module (texinfo)
|
||||||
|
|
@ -652,13 +653,16 @@
|
||||||
target-value))))))))))))
|
target-value))))))))))))
|
||||||
environment-variables))))))))))
|
environment-variables))))))))))
|
||||||
|
|
||||||
(define (compare/package-derivations query-parameters
|
(define* (compare/package-derivations query-parameters
|
||||||
mode
|
mode
|
||||||
valid-systems
|
valid-systems
|
||||||
valid-targets
|
valid-targets
|
||||||
valid-build-statuses
|
valid-build-statuses
|
||||||
build-server-urls
|
build-server-urls
|
||||||
derivation-changes)
|
derivation-changes
|
||||||
|
#:optional
|
||||||
|
base-revision-details
|
||||||
|
target-revision-details)
|
||||||
(layout
|
(layout
|
||||||
#:body
|
#:body
|
||||||
`(,(header)
|
`(,(header)
|
||||||
|
|
@ -666,19 +670,57 @@
|
||||||
(@ (class "container"))
|
(@ (class "container"))
|
||||||
(div
|
(div
|
||||||
(@ (class "row"))
|
(@ (class "row"))
|
||||||
(h3 ,@(let ((base-commit (assq-ref query-parameters 'base_commit))
|
,@(cond
|
||||||
(target-commit (assq-ref query-parameters 'target_commit)))
|
((any-invalid-query-parameters? query-parameters)
|
||||||
(if (every string? (list base-commit target-commit))
|
'((h3 "Comparing package derivations")))
|
||||||
`((a (@ (href ,(string-append
|
((eq? mode 'revision)
|
||||||
"/compare?base_commit="
|
(let ((base-commit (assq-ref query-parameters 'base_commit))
|
||||||
base-commit
|
(target-commit (assq-ref query-parameters 'target_commit)))
|
||||||
"&target_commit="
|
`((h3
|
||||||
target-commit)))
|
(a (@ (href ,(string-append
|
||||||
"Comparing "
|
"/compare?base_commit="
|
||||||
(samp ,(string-take base-commit 8) "…")
|
base-commit
|
||||||
" and "
|
"&target_commit="
|
||||||
(samp ,(string-take target-commit 8) "…")))
|
target-commit)))
|
||||||
'("Comparing package derivations")))))
|
"Comparing "
|
||||||
|
(samp ,(string-take base-commit 8) "…")
|
||||||
|
" and "
|
||||||
|
(samp ,(string-take target-commit 8) "…"))))))
|
||||||
|
((eq? mode 'datetime)
|
||||||
|
(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)))
|
||||||
|
`((h3
|
||||||
|
(a (@ (href ,(string-append
|
||||||
|
"/compare-by-datetime?"
|
||||||
|
(query-parameters->string
|
||||||
|
(filter (match-lambda
|
||||||
|
((key . _)
|
||||||
|
(member key '(base_branch
|
||||||
|
base_datetime
|
||||||
|
target_branch
|
||||||
|
target_datetime))))
|
||||||
|
query-parameters)))))
|
||||||
|
"Comparing "
|
||||||
|
(br)
|
||||||
|
(samp (*ENTITY* nbsp) (*ENTITY* nbsp)
|
||||||
|
,base-branch
|
||||||
|
,@(map (lambda _ '(*ENTITY* nbsp))
|
||||||
|
(iota (max
|
||||||
|
0
|
||||||
|
(- (string-length target-branch)
|
||||||
|
(string-length base-branch))))))
|
||||||
|
" at " ,(date->string base-datetime "~1 ~3")
|
||||||
|
" to "
|
||||||
|
(br)
|
||||||
|
(samp (*ENTITY* nbsp) (*ENTITY* nbsp)
|
||||||
|
,target-branch
|
||||||
|
,@(map (lambda _ '(*ENTITY* nbsp))
|
||||||
|
(iota (max 0
|
||||||
|
(- (string-length base-branch)
|
||||||
|
(string-length target-branch))))))
|
||||||
|
" at " ,(date->string target-datetime "~1 ~3"))))))))
|
||||||
(div
|
(div
|
||||||
(@ (class "row"))
|
(@ (class "row"))
|
||||||
(div
|
(div
|
||||||
|
|
@ -854,168 +896,6 @@ enough builds to determine a change")))
|
||||||
(cdr data-columns))))))
|
(cdr data-columns))))))
|
||||||
(vector->list derivation-changes)))))))))))
|
(vector->list derivation-changes)))))))))))
|
||||||
|
|
||||||
(define (compare-by-datetime/package-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 "
|
|
||||||
(a (@ (href ,(string-append "/revision/" base-commit)))
|
|
||||||
(samp ,(string-take base-commit 8) "…"))
|
|
||||||
" and "
|
|
||||||
(a (@ (href ,(string-append "/revision/" target-commit)))
|
|
||||||
(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
|
|
||||||
#: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
|
|
||||||
#: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/package-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
|
(define (compare/packages query-parameters
|
||||||
base-packages-vhash
|
base-packages-vhash
|
||||||
target-packages-vhash)
|
target-packages-vhash)
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue