Implement compare by datetime for system test derivations

Also fix some general issues with the rendering.

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