Add a variant of compare/derivations to work with a branch and datetime

2 files changed, 258 insertions, 0 deletions

diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index cad1db5..cda058e 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -601,6 +601,84 @@
                           derivation-changes)
                   #:extra-headers http-headers-for-unchanging-content)))))))))
 
+(define (render-compare-by-datetime/derivations mime-types
+                                                conn
+                                                query-parameters)
+  (define (derivations->alist derivations)
+    (map (match-lambda
+           ((file-name system target buildstatus)
+            `((file_name . ,file-name)
+              (system . ,system)
+              (target . ,target)
+              (build_status . ,(if (string=? buildstatus "")
+                                   "unknown"
+                                   buildstatus)))))
+         derivations))
+
+  (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
+         (render-html
+          #:sxml (compare-by-datetime/derivations
+                  query-parameters
+                  (valid-systems conn)
+                  build-status-strings
+                  '()))))
+
+      (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))
+            (systems         (assq-ref query-parameters 'system))
+            (targets         (assq-ref query-parameters 'target))
+            (build-statuses  (assq-ref query-parameters 'build_status)))
+        (let*
+            ((base-revision-details
+              (select-guix-revision-for-branch-and-datetime conn
+                                                            base-branch
+                                                            base-datetime))
+             (target-revision-details
+              (select-guix-revision-for-branch-and-datetime conn
+                                                            target-branch
+                                                            target-datetime))
+             (data
+              (package-differences-data conn
+                                        (first base-revision-details)
+                                        (first target-revision-details)
+                                        #:systems systems
+                                        #:targets targets))
+             (names-and-versions
+              (package-data->names-and-versions data)))
+          (let-values
+              (((base-packages-vhash target-packages-vhash)
+                (package-data->package-data-vhashes data)))
+            (let ((derivation-changes
+                   (package-data-derivation-changes names-and-versions
+                                                    base-packages-vhash
+                                                    target-packages-vhash)))
+              (case (most-appropriate-mime-type
+                     '(application/json text/html)
+                     mime-types)
+                ((application/json)
+                 (render-json
+                  derivation-changes
+                  #:extra-headers http-headers-for-unchanging-content))
+                (else
+                 (render-html
+                  #:sxml (compare-by-datetime/derivations
+                          query-parameters
+                          (valid-systems conn)
+                          build-status-strings
+                          base-revision-details
+                          target-revision-details
+                          derivation-changes)
+                  #:extra-headers http-headers-for-unchanging-content)))))))))
+
 (define (render-compare/packages mime-types
                                  conn
                                  query-parameters)
@@ -1112,6 +1190,23 @@
        (render-compare/derivations mime-types
                                    conn
                                    parsed-query-parameters)))
+    (('GET "compare-by-datetime" "derivations")
+     (let* ((parsed-query-parameters
+             (guard-against-mutually-exclusive-query-parameters
+              (parse-query-parameters
+               request
+               `((base_branch     ,identity #:required)
+                 (base_datetime   ,parse-datetime #:required)
+                 (target_branch   ,identity #:required)
+                 (target_datetime ,parse-datetime #:required)
+                 (system          ,parse-system #:multi-value)
+                 (target          ,parse-system #:multi-value)
+                 (build_status    ,parse-build-status #:multi-value)))
+              '((base_commit base_datetime)
+                (target_commit target_datetime)))))
+       (render-compare-by-datetime/derivations mime-types
+                                               conn
+                                               parsed-query-parameters)))
     (('GET "compare" "packages")
      (let* ((parsed-query-parameters
              (parse-query-parameters
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index b49c254..ff815c4 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -50,6 +50,7 @@
             view-job
             compare
             compare/derivations
+            compare-by-datetime/derivations
             compare/packages
             compare-invalid-parameters
             error-page))
@@ -2061,6 +2062,168 @@
                               (cdr data-columns))))))
                 (vector->list derivation-changes)))))))))))
 
+(define (compare-by-datetime/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 "
+                     (samp ,(string-take base-commit 8) "…")
+                     " and "
+                     (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
+            #:required? #t
+            #: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
+            #:required? #t
+            #: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/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)