Improve derivation comparison to show more changes

In cases where the version is changed for example, the relevant derivations
will now show up, whereas previously they did not.

2 files changed, 92 insertions, 44 deletions

diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm
index 3e0bfe9..18f7c35 100644
--- a/guix-data-service/comparison.scm
+++ b/guix-data-service/comparison.scm
@@ -8,6 +8,7 @@
   #:export (package-data->package-data-vhashes
             package-differences-data
             package-data-vhash->derivations
+            package-data->names-and-versions
             package-data-vhash->derivations-and-build-status
             package-data-vhashes->new-packages
             package-data-vhashes->removed-packages
@@ -84,6 +85,28 @@ ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, t
                (list vlist-null vlist-null)
                package-data)))
 
+(define (package-data->names-and-versions package-data)
+  (reverse
+   (pair-fold
+    (lambda (pair result)
+      (match pair
+        (((name . version))
+         (cons (cons name version)
+               result))
+        (((name1 . version1) (name2 . version2) rest ...)
+         (if (and (string=? name1 name2)
+                  (string=? version1 version2))
+             result
+             (cons (cons name1 version1)
+                   result)))))
+    '()
+    (map (match-lambda
+           ((base-name base-version _ _ _ _ target-name target-version _ _ _ _)
+            (if (string-null? base-name)
+                (cons target-name target-version)
+                (cons base-name base-version))))
+         package-data))))
+
 (define (package-data-vhash->derivations conn packages-vhash)
   (define (vhash->derivation-ids vhash)
     (vhash-fold (lambda (key value result)
@@ -206,7 +229,10 @@ ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, t
                '()
                target-versions)))
 
-(define (package-data-derivation-changes base-packages-vhash target-packages-vhash)
+(define (package-data-derivation-changes names-and-versions
+                                         base-packages-vhash
+                                         target-packages-vhash)
+
   (define base-package-details-by-name-and-version
     (package-data-vhash->package-name-and-version-hash-table base-packages-vhash))
 
@@ -224,25 +250,42 @@ ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, t
           ,@(derivation-system-and-target-list->alist (cdr lst)))))
 
   (list->vector
-   (hash-fold
-    (lambda (name-and-version target-packages-entry result)
+   (filter-map
+    (lambda (name-and-version)
       (let ((base-packages-entry
              (hash-ref base-package-details-by-name-and-version
+                       name-and-version))
+            (target-packages-entry
+             (hash-ref target-package-details-by-name-and-version
                        name-and-version)))
-        (if base-packages-entry
-            (let ((base-derivations (map cdr base-packages-entry))
-                  (target-derivations (map cdr target-packages-entry)))
-              (if (equal? base-derivations target-derivations)
-                  result
-                  `(((name . ,(car name-and-version))
-                     (version . ,(cdr name-and-version))
-                     (base . ,(list->vector
-                               (derivation-system-and-target-list->alist
-                                base-derivations)))
-                     (target . ,(list->vector
-                                 (derivation-system-and-target-list->alist
-                                  target-derivations))))
-                    ,@result)))
-            result)))
-    '()
-    target-package-details-by-name-and-version)))
+        (cond
+         ((and base-packages-entry target-packages-entry)
+          (let ((base-derivations (map cdr base-packages-entry))
+                (target-derivations (map cdr target-packages-entry)))
+            (if (equal? base-derivations target-derivations)
+                #f
+                `((name . ,(car name-and-version))
+                  (version . ,(cdr name-and-version))
+                  (base . ,(list->vector
+                            (derivation-system-and-target-list->alist
+                             base-derivations)))
+                  (target . ,(list->vector
+                              (derivation-system-and-target-list->alist
+                               target-derivations)))))))
+         (base-packages-entry
+          (let ((base-derivations (map cdr base-packages-entry)))
+            `((name . ,(car name-and-version))
+              (version . ,(cdr name-and-version))
+              (base . ,(list->vector
+                        (derivation-system-and-target-list->alist
+                         base-derivations)))
+              (target . ,(list->vector '())))))
+         (else
+          (let ((target-derivations (map cdr target-packages-entry)))
+            `((name . ,(car name-and-version))
+              (version . ,(cdr name-and-version))
+              (base . ,(list->vector '()))
+              (target . ,(list->vector
+                          (derivation-system-and-target-list->alist
+                           target-derivations)))))))))
+    names-and-versions)))
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index e55ebae..8c4530f 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -429,30 +429,35 @@
             (systems        (assq-ref query-parameters 'system))
             (targets        (assq-ref query-parameters 'target))
             (build-statuses (assq-ref query-parameters 'build_status)))
-        (let-values
-            (((base-packages-vhash target-packages-vhash)
-              (package-data->package-data-vhashes
-               (package-differences-data conn
-                                         (commit->revision-id conn base-commit)
-                                         (commit->revision-id conn target-commit)))))
-          (let ((derivation-changes
-                 (package-data-derivation-changes 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/derivations
-                        query-parameters
-                        (valid-systems conn)
-                        build-status-strings
-                        derivation-changes)
-                #:extra-headers http-headers-for-unchanging-content))))))))
+        (let*
+            ((data
+              (package-differences-data conn
+                                        (commit->revision-id conn base-commit)
+                                        (commit->revision-id conn target-commit)))
+             (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/derivations
+                          query-parameters
+                          (valid-systems conn)
+                          build-status-strings
+                          derivation-changes)
+                  #:extra-headers http-headers-for-unchanging-content)))))))))
 
 (define (render-compare/packages mime-types
                                  conn