[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/03: Implement compare by datetime for system test derivations
|
From: |
Christopher Baines |
|
Subject: |
03/03: Implement compare by datetime for system test derivations |
|
Date: |
Mon, 4 Jan 2021 18:00:10 -0500 (EST) |
cbaines pushed a commit to branch master
in repository data-service.
commit 10500700671fa0640665e244eeb40677f577c527
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Mon Jan 4 22:59:28 2021 +0000
Implement compare by datetime for system test derivations
Also fix some general issues with the rendering.
---
guix-data-service/web/compare/controller.scm | 111 +++++++++++++++++++++++++++
guix-data-service/web/compare/html.scm | 101 +++++++++++++++---------
2 files changed, 174 insertions(+), 38 deletions(-)
diff --git a/guix-data-service/web/compare/controller.scm
b/guix-data-service/web/compare/controller.scm
index c5a58f8..95a5bf3 100644
--- a/guix-data-service/web/compare/controller.scm
+++ b/guix-data-service/web/compare/controller.scm
@@ -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)))))))))
diff --git a/guix-data-service/web/compare/html.scm
b/guix-data-service/web/compare/html.scm
index 812dc9a..9fcd6a6 100644
--- a/guix-data-service/web/compare/html.scm
+++ b/guix-data-service/web/compare/html.scm
@@ -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