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.

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
+   (filter-map
-    (lambda (name-and-version target-packages-entry result)
+    (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
+        (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)
-                  result
+                #f
-                  `(((name . ,(car name-and-version))
+                `((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))))
+                               target-derivations)))))))
-                    ,@result)))
+         (base-packages-entry
-            result)))
+          (let ((base-derivations (map cdr base-packages-entry)))
-    '()
+            `((name . ,(car name-and-version))
-    target-package-details-by-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)))

guix-data-service/web/controller.scm

@@ -429,14 +429,19 @@
             (systems        (assq-ref query-parameters 'system))
             (targets        (assq-ref query-parameters 'target))
             (build-statuses (assq-ref query-parameters 'build_status)))
-        (let-values
+        (let*
-            (((base-packages-vhash target-packages-vhash)
+            ((data
-              (package-data->package-data-vhashes
               (package-differences-data conn
                                         (commit->revision-id conn base-commit)
-                                         (commit->revision-id conn target-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 base-packages-vhash
+                   (package-data-derivation-changes names-and-versions
+                                                    base-packages-vhash
                                                     target-packages-vhash)))
               (case (most-appropriate-mime-type
                      '(application/json text/html)
@@ -452,7 +457,7 @@
                           (valid-systems conn)
                           build-status-strings
                           derivation-changes)
-                #:extra-headers http-headers-for-unchanging-content))))))))
+                  #:extra-headers http-headers-for-unchanging-content)))))))))
 
 (define (render-compare/packages mime-types
                                  conn