cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Improve derivation comparison to show more changes

Browse source 
In cases where the version is changed for example, the relevant derivations
will now show up, whereas previously they did not.
This commit is contained in:
Christopher Baines 2019-08-06 09:55:03 +01:00
parent 82c3e8942b
commit 36a16d356f
2 changed files with 92 additions and 44 deletions
Download patch file Download diff file Expand all files Collapse all files

83
guix-data-service/comparison.scm
View file

@ -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)))

53
guix-data-service/web/controller.scm
View file

@ -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