From 36a16d356f526bcc3425147ffc6a36df1c1a1782 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 6 Aug 2019 09:55:03 +0100 Subject: 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 | 83 +++++++++++++++++++++++++++--------- guix-data-service/web/controller.scm | 53 ++++++++++++----------- 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 -- cgit v1.2.3