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 #:export (package-data->package-data-vhashes
package-differences-data package-differences-data
package-data-vhash->derivations package-data-vhash->derivations
package-data->names-and-versions
package-data-vhash->derivations-and-build-status package-data-vhash->derivations-and-build-status
package-data-vhashes->new-packages package-data-vhashes->new-packages
package-data-vhashes->removed-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) (list vlist-null vlist-null)
package-data))) 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 (package-data-vhash->derivations conn packages-vhash)
(define (vhash->derivation-ids vhash) (define (vhash->derivation-ids vhash)
(vhash-fold (lambda (key value result) (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))) 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 (define base-package-details-by-name-and-version
(package-data-vhash->package-name-and-version-hash-table base-packages-vhash)) (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))))) ,@(derivation-system-and-target-list->alist (cdr lst)))))
(list->vector (list->vector
(hash-fold (filter-map
(lambda (name-and-version target-packages-entry result) (lambda (name-and-version)
(let ((base-packages-entry (let ((base-packages-entry
(hash-ref base-package-details-by-name-and-version (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))) name-and-version)))
(if base-packages-entry (cond
(let ((base-derivations (map cdr base-packages-entry)) ((and base-packages-entry target-packages-entry)
(target-derivations (map cdr target-packages-entry))) (let ((base-derivations (map cdr base-packages-entry))
(if (equal? base-derivations target-derivations) (target-derivations (map cdr target-packages-entry)))
result (if (equal? base-derivations target-derivations)
`(((name . ,(car name-and-version)) #f
(version . ,(cdr name-and-version)) `((name . ,(car name-and-version))
(base . ,(list->vector (version . ,(cdr name-and-version))
(derivation-system-and-target-list->alist (base . ,(list->vector
base-derivations))) (derivation-system-and-target-list->alist
(target . ,(list->vector base-derivations)))
(derivation-system-and-target-list->alist (target . ,(list->vector
target-derivations)))) (derivation-system-and-target-list->alist
,@result))) target-derivations)))))))
result))) (base-packages-entry
'() (let ((base-derivations (map cdr base-packages-entry)))
target-package-details-by-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 '())))))
(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)) (systems (assq-ref query-parameters 'system))
(targets (assq-ref query-parameters 'target)) (targets (assq-ref query-parameters 'target))
(build-statuses (assq-ref query-parameters 'build_status))) (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
(package-differences-data conn (commit->revision-id conn base-commit)
(commit->revision-id conn base-commit) (commit->revision-id conn target-commit)))
(commit->revision-id conn target-commit))))) (names-and-versions
(let ((derivation-changes (package-data->names-and-versions data)))
(package-data-derivation-changes base-packages-vhash (let-values
target-packages-vhash))) (((base-packages-vhash target-packages-vhash)
(case (most-appropriate-mime-type (package-data->package-data-vhashes data)))
'(application/json text/html) (let ((derivation-changes
mime-types) (package-data-derivation-changes names-and-versions
((application/json) base-packages-vhash
(render-json target-packages-vhash)))
derivation-changes (case (most-appropriate-mime-type
#:extra-headers http-headers-for-unchanging-content)) '(application/json text/html)
(else mime-types)
(render-html ((application/json)
#:sxml (compare/derivations (render-json
query-parameters derivation-changes
(valid-systems conn) #:extra-headers http-headers-for-unchanging-content))
build-status-strings (else
derivation-changes) (render-html
#:extra-headers http-headers-for-unchanging-content)))))))) #: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 (define (render-compare/packages mime-types
conn conn