cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Implement compare by datetime for system test derivations

Browse source 
Also fix some general issues with the rendering.
This commit is contained in:
Christopher Baines 2021-01-04 22:59:28 +00:00
parent b4bb92c8a9
commit 1050070067
2 changed files with 174 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

111
guix-data-service/web/compare/controller.scm
View file

@ -200,6 +200,21 @@
(render-compare/system-test-derivations mime-types (render-compare/system-test-derivations mime-types
parsed-query-parameters))) 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))) (_ #f)))
(define (texinfo->variants-alist s) (define (texinfo->variants-alist s)
@ -929,3 +944,99 @@
base-git-repositories base-git-repositories
target-git-repositories target-git-repositories
data)))))))) 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)))))))))

101
guix-data-service/web/compare/html.scm
View file

@ -1195,22 +1195,40 @@ enough builds to determine a change")))
(list (list
(if (list? description-data) (if (list? description-data)
(cons (cons
`(td ,(assq-ref description-data 'base)) `(td ,(let ((description
`(td ,(assq-ref description-data 'target))) (assq-ref description-data 'base)))
(if (eq? description 'null)
""
description)))
`(td ,(let ((description
(assq-ref description-data 'target)))
(if (eq? description 'null)
""
description))))
(cons (cons
`(td (@ (rowspan 2)) `(td (@ (rowspan 2))
,description-data) ,description-data)
"")) ""))
(if (assq-ref location-data 'base) (if (assq-ref location-data 'base)
(cons (cons
`(td ,(render-location (if (list? (assq-ref location-data 'base))
base-git-repositories `(td ,(render-location
(assq-ref query-parameters 'base_commit) base-git-repositories
(assq-ref location-data 'base))) (if (eq? mode 'revision)
`(td ,(render-location (assq-ref query-parameters
target-git-repositories 'base_commit)
(assq-ref query-parameters 'target_commit) (second base-revision-details))
(assq-ref location-data 'target)))) (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 (cons
`(td (@ (rowspan 2)) `(td (@ (rowspan 2))
,(render-location ,(render-location
@ -1220,36 +1238,43 @@ enough builds to determine a change")))
"")) ""))
(cons (cons
(let ((base-derivation (assq-ref derivation-data 'base))) (let ((base-derivation (assq-ref derivation-data 'base)))
`(td (if (string? base-derivation)
(a (@ (style "display: block;") `(td
(href ,base-derivation)) (a (@ (style "display: block;")
(span (@ (class "text-danger glyphicon glyphicon-minus pull-left") (href ,base-derivation))
(style "font-size: 1.5em; padding-right: 0.4em;"))) (span (@ (class "text-danger glyphicon glyphicon-minus pull-left")
,@(build-statuses->build-status-labels (style "font-size: 1.5em; padding-right: 0.4em;")))
(vector->list (assq-ref builds-data 'base))) ,@(build-statuses->build-status-labels
,(display-store-item-short base-derivation)))) (vector->list (assq-ref builds-data 'base)))
,(display-store-item-short base-derivation)))
""))
(let ((target-derivation (assq-ref derivation-data 'target))) (let ((target-derivation (assq-ref derivation-data 'target)))
`(td (if (string? target-derivation)
(a (@ (style "display: block;") `(td
(href ,target-derivation)) (a (@ (style "display: block;")
(span (@ (class "text-success glyphicon glyphicon-plus pull-left") (href ,target-derivation))
(style "font-size: 1.5em; padding-right: 0.4em;"))) (span (@ (class "text-success glyphicon glyphicon-plus pull-left")
,@(build-statuses->build-status-labels (style "font-size: 1.5em; padding-right: 0.4em;")))
(vector->list (assq-ref builds-data 'target))) ,@(build-statuses->build-status-labels
,(display-store-item-short target-derivation))))) (vector->list (assq-ref builds-data 'target)))
,(display-store-item-short target-derivation)))
"")))
(cons (cons
`(td (@ (style "vertical-align: middle;") (if (and (string? (assq-ref derivation-data 'base))
(rowspan 2)) (string? (assq-ref derivation-data 'target)))
(a (@ (class "btn btn-sm btn-default") `(td (@ (style "vertical-align: middle;")
(title "Compare") (rowspan 2))
(href (a (@ (class "btn btn-sm btn-default")
,(string-append (title "Compare")
"/compare/derivation?" (href
"base_derivation=" ,(string-append
(assq-ref derivation-data 'base) "/compare/derivation?"
"&target_derivation=" "base_derivation="
(assq-ref derivation-data 'target)))) (assq-ref derivation-data 'base)
"⇕ Compare")) "&target_derivation="
(assq-ref derivation-data 'target))))
"⇕ Compare"))
"")
""))) "")))
`((tr `((tr