Implement compare by datetime for system test derivations
Also fix some general issues with the rendering.
This commit is contained in:
parent
b4bb92c8a9
commit
1050070067
2 changed files with 174 additions and 38 deletions
|
|
@ -200,6 +200,21 @@
|
|||
|
||||
(render-compare/system-test-derivations mime-types
|
||||
parsed-query-parameters)))
|
||||
(('GET "compare-by-datetime" "system-test-derivations")
|
||||
(let* ((parsed-query-parameters
|
||||
(parse-query-parameters
|
||||
request
|
||||
`((base_branch ,identity #:required)
|
||||
(base_datetime ,parse-datetime
|
||||
#:default ,(current-date))
|
||||
(target_branch ,identity #:required)
|
||||
(target_datetime ,parse-datetime
|
||||
#:default ,(current-date))
|
||||
(system ,parse-system #:default "x86_64-linux")))))
|
||||
|
||||
(render-compare-by-datetime/system-test-derivations
|
||||
mime-types
|
||||
parsed-query-parameters)))
|
||||
(_ #f)))
|
||||
|
||||
(define (texinfo->variants-alist s)
|
||||
|
|
@ -929,3 +944,99 @@
|
|||
base-git-repositories
|
||||
target-git-repositories
|
||||
data))))))))
|
||||
|
||||
(define (render-compare-by-datetime/system-test-derivations mime-types
|
||||
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
|
||||
(letpar& ((systems
|
||||
(with-thread-postgresql-connection
|
||||
valid-systems))
|
||||
(build-server-urls
|
||||
(with-thread-postgresql-connection
|
||||
select-build-server-urls-by-id)))
|
||||
(render-html
|
||||
#:sxml (compare/system-test-derivations
|
||||
query-parameters
|
||||
'datetime
|
||||
systems
|
||||
build-server-urls
|
||||
'()
|
||||
'()
|
||||
'())))))
|
||||
|
||||
(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))
|
||||
(system (assq-ref query-parameters 'system)))
|
||||
(letpar&
|
||||
((base-revision-details
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-guix-revision-for-branch-and-datetime conn
|
||||
base-branch
|
||||
base-datetime))))
|
||||
(target-revision-details
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(select-guix-revision-for-branch-and-datetime conn
|
||||
target-branch
|
||||
target-datetime)))))
|
||||
(letpar& ((data
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(system-test-derivations-differences-data
|
||||
conn
|
||||
(first base-revision-details)
|
||||
(first target-revision-details)
|
||||
system))))
|
||||
(build-server-urls
|
||||
(with-thread-postgresql-connection
|
||||
select-build-server-urls-by-id))
|
||||
(base-git-repositories
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(git-repositories-containing-commit
|
||||
conn
|
||||
(second base-revision-details)))))
|
||||
(target-git-repositories
|
||||
(with-thread-postgresql-connection
|
||||
(lambda (conn)
|
||||
(git-repositories-containing-commit
|
||||
conn
|
||||
(second target-revision-details)))))
|
||||
(systems
|
||||
(with-thread-postgresql-connection
|
||||
valid-systems)))
|
||||
(case (most-appropriate-mime-type
|
||||
'(application/json text/html)
|
||||
mime-types)
|
||||
((application/json)
|
||||
(render-json
|
||||
`((revisions
|
||||
. ((base
|
||||
. ((commit . ,(second base-revision-details))
|
||||
(datetime . ,(fifth base-revision-details))))
|
||||
(target
|
||||
. ((commit . ,(second target-revision-details))
|
||||
(datetime . ,(fifth target-revision-details))))))
|
||||
(changes . ,(list->vector data)))))
|
||||
(else
|
||||
(render-html
|
||||
#:sxml (compare/system-test-derivations
|
||||
query-parameters
|
||||
'datetime
|
||||
systems
|
||||
build-server-urls
|
||||
base-git-repositories
|
||||
target-git-repositories
|
||||
data
|
||||
base-revision-details
|
||||
target-revision-details)))))))))
|
||||
|
|
|
|||
|
|
@ -1195,22 +1195,40 @@ enough builds to determine a change")))
|
|||
(list
|
||||
(if (list? description-data)
|
||||
(cons
|
||||
`(td ,(assq-ref description-data 'base))
|
||||
`(td ,(assq-ref description-data 'target)))
|
||||
`(td ,(let ((description
|
||||
(assq-ref description-data 'base)))
|
||||
(if (eq? description 'null)
|
||||
""
|
||||
description)))
|
||||
`(td ,(let ((description
|
||||
(assq-ref description-data 'target)))
|
||||
(if (eq? description 'null)
|
||||
""
|
||||
description))))
|
||||
(cons
|
||||
`(td (@ (rowspan 2))
|
||||
,description-data)
|
||||
""))
|
||||
(if (assq-ref location-data 'base)
|
||||
(cons
|
||||
`(td ,(render-location
|
||||
base-git-repositories
|
||||
(assq-ref query-parameters 'base_commit)
|
||||
(assq-ref location-data 'base)))
|
||||
`(td ,(render-location
|
||||
target-git-repositories
|
||||
(assq-ref query-parameters 'target_commit)
|
||||
(assq-ref location-data 'target))))
|
||||
(if (list? (assq-ref location-data 'base))
|
||||
`(td ,(render-location
|
||||
base-git-repositories
|
||||
(if (eq? mode 'revision)
|
||||
(assq-ref query-parameters
|
||||
'base_commit)
|
||||
(second base-revision-details))
|
||||
(assq-ref location-data 'base)))
|
||||
"")
|
||||
(if (list? (assq-ref location-data 'target))
|
||||
`(td ,(render-location
|
||||
target-git-repositories
|
||||
(if (eq? mode 'revision)
|
||||
(assq-ref query-parameters
|
||||
'target_commit)
|
||||
(second target-revision-details))
|
||||
(assq-ref location-data 'target)))
|
||||
""))
|
||||
(cons
|
||||
`(td (@ (rowspan 2))
|
||||
,(render-location
|
||||
|
|
@ -1220,36 +1238,43 @@ enough builds to determine a change")))
|
|||
""))
|
||||
(cons
|
||||
(let ((base-derivation (assq-ref derivation-data 'base)))
|
||||
`(td
|
||||
(a (@ (style "display: block;")
|
||||
(href ,base-derivation))
|
||||
(span (@ (class "text-danger glyphicon glyphicon-minus pull-left")
|
||||
(style "font-size: 1.5em; padding-right: 0.4em;")))
|
||||
,@(build-statuses->build-status-labels
|
||||
(vector->list (assq-ref builds-data 'base)))
|
||||
,(display-store-item-short base-derivation))))
|
||||
(if (string? base-derivation)
|
||||
`(td
|
||||
(a (@ (style "display: block;")
|
||||
(href ,base-derivation))
|
||||
(span (@ (class "text-danger glyphicon glyphicon-minus pull-left")
|
||||
(style "font-size: 1.5em; padding-right: 0.4em;")))
|
||||
,@(build-statuses->build-status-labels
|
||||
(vector->list (assq-ref builds-data 'base)))
|
||||
,(display-store-item-short base-derivation)))
|
||||
""))
|
||||
(let ((target-derivation (assq-ref derivation-data 'target)))
|
||||
`(td
|
||||
(a (@ (style "display: block;")
|
||||
(href ,target-derivation))
|
||||
(span (@ (class "text-success glyphicon glyphicon-plus pull-left")
|
||||
(style "font-size: 1.5em; padding-right: 0.4em;")))
|
||||
,@(build-statuses->build-status-labels
|
||||
(vector->list (assq-ref builds-data 'target)))
|
||||
,(display-store-item-short target-derivation)))))
|
||||
(if (string? target-derivation)
|
||||
`(td
|
||||
(a (@ (style "display: block;")
|
||||
(href ,target-derivation))
|
||||
(span (@ (class "text-success glyphicon glyphicon-plus pull-left")
|
||||
(style "font-size: 1.5em; padding-right: 0.4em;")))
|
||||
,@(build-statuses->build-status-labels
|
||||
(vector->list (assq-ref builds-data 'target)))
|
||||
,(display-store-item-short target-derivation)))
|
||||
"")))
|
||||
(cons
|
||||
`(td (@ (style "vertical-align: middle;")
|
||||
(rowspan 2))
|
||||
(a (@ (class "btn btn-sm btn-default")
|
||||
(title "Compare")
|
||||
(href
|
||||
,(string-append
|
||||
"/compare/derivation?"
|
||||
"base_derivation="
|
||||
(assq-ref derivation-data 'base)
|
||||
"&target_derivation="
|
||||
(assq-ref derivation-data 'target))))
|
||||
"⇕ Compare"))
|
||||
(if (and (string? (assq-ref derivation-data 'base))
|
||||
(string? (assq-ref derivation-data 'target)))
|
||||
`(td (@ (style "vertical-align: middle;")
|
||||
(rowspan 2))
|
||||
(a (@ (class "btn btn-sm btn-default")
|
||||
(title "Compare")
|
||||
(href
|
||||
,(string-append
|
||||
"/compare/derivation?"
|
||||
"base_derivation="
|
||||
(assq-ref derivation-data 'base)
|
||||
"&target_derivation="
|
||||
(assq-ref derivation-data 'target))))
|
||||
"⇕ Compare"))
|
||||
"")
|
||||
"")))
|
||||
|
||||
`((tr
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue