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"))))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare-by-datetime/package-derivations
|
||||
#:sxml (compare/package-derivations
|
||||
query-parameters
|
||||
'datetime
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection valid-systems))
|
||||
(valid-targets->options
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection valid-targets)))
|
||||
build-status-strings
|
||||
'()
|
||||
'()
|
||||
|
|
@ -708,14 +712,21 @@
|
|||
derivation-changes))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare-by-datetime/package-derivations
|
||||
#:sxml (compare/package-derivations
|
||||
query-parameters
|
||||
'datetime
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection valid-systems))
|
||||
(valid-targets->options
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection valid-targets)))
|
||||
build-status-strings
|
||||
(parallel-via-thread-pool-channel
|
||||
(with-thread-postgresql-connection
|
||||
select-build-server-urls-by-id))
|
||||
derivation-changes
|
||||
base-revision-details
|
||||
target-revision-details
|
||||
derivation-changes))))))))))))
|
||||
target-revision-details))))))))))))
|
||||
|
||||
(define (render-compare/packages mime-types
|
||||
query-parameters)
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@
|
|||
|
||||
(define-module (guix-data-service web compare html)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-19)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (texinfo)
|
||||
|
|
@ -652,13 +653,16 @@
|
|||
target-value))))))))))))
|
||||
environment-variables))))))))))
|
||||
|
||||
(define (compare/package-derivations query-parameters
|
||||
mode
|
||||
valid-systems
|
||||
valid-targets
|
||||
valid-build-statuses
|
||||
build-server-urls
|
||||
derivation-changes)
|
||||
(define* (compare/package-derivations query-parameters
|
||||
mode
|
||||
valid-systems
|
||||
valid-targets
|
||||
valid-build-statuses
|
||||
build-server-urls
|
||||
derivation-changes
|
||||
#:optional
|
||||
base-revision-details
|
||||
target-revision-details)
|
||||
(layout
|
||||
#:body
|
||||
`(,(header)
|
||||
|
|
@ -666,19 +670,57 @@
|
|||
(@ (class "container"))
|
||||
(div
|
||||
(@ (class "row"))
|
||||
(h3 ,@(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))
|
||||
`((a (@ (href ,(string-append
|
||||
"/compare?base_commit="
|
||||
base-commit
|
||||
"&target_commit="
|
||||
target-commit)))
|
||||
"Comparing "
|
||||
(samp ,(string-take base-commit 8) "…")
|
||||
" and "
|
||||
(samp ,(string-take target-commit 8) "…")))
|
||||
'("Comparing package derivations")))))
|
||||
,@(cond
|
||||
((any-invalid-query-parameters? query-parameters)
|
||||
'((h3 "Comparing package derivations")))
|
||||
((eq? mode 'revision)
|
||||
(let ((base-commit (assq-ref query-parameters 'base_commit))
|
||||
(target-commit (assq-ref query-parameters 'target_commit)))
|
||||
`((h3
|
||||
(a (@ (href ,(string-append
|
||||
"/compare?base_commit="
|
||||
base-commit
|
||||
"&target_commit="
|
||||
target-commit)))
|
||||
"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
|
||||
(@ (class "row"))
|
||||
(div
|
||||
|
|
@ -854,168 +896,6 @@ enough builds to determine a change")))
|
|||
(cdr data-columns))))))
|
||||
(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
|
||||
base-packages-vhash
|
||||
target-packages-vhash)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue