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

Fix the JSON responses for the comparison pages

Browse source
This commit is contained in:
Christopher Baines 2019-03-16 21:55:09 +00:00
parent 902409b828
commit 5325cf0234
Signed by: cbaines
GPG key ID: 5E28A33B0B84F577
3 changed files with 102 additions and 63 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -126,20 +126,30 @@ ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, t
vhash)) vhash))
(define (package-data-vhashes->new-packages base-packages-vhash target-packages-vhash) (define (package-data-vhashes->new-packages base-packages-vhash target-packages-vhash)
(vlist->list (map
(package-data-vhash->package-name-and-version-vhash (match-lambda
(vlist-filter (match-lambda (((name . version) metadata ...)
((name . details) `((name . ,name)
(not (vhash-assoc name base-packages-vhash)))) (version . ,version))))
target-packages-vhash)))) (vlist->list
(package-data-vhash->package-name-and-version-vhash
(vlist-filter (match-lambda
((name . details)
(not (vhash-assoc name base-packages-vhash))))
target-packages-vhash)))))
(define (package-data-vhashes->removed-packages base-packages-vhash target-packages-vhash) (define (package-data-vhashes->removed-packages base-packages-vhash target-packages-vhash)
(vlist->list (map
(package-data-vhash->package-name-and-version-vhash (match-lambda
(vlist-filter (match-lambda (((name . version) metadata ...)
((name . details) `((name . ,name)
(not (vhash-assoc name target-packages-vhash)))) (version . ,version))))
base-packages-vhash)))) (vlist->list
(package-data-vhash->package-name-and-version-vhash
(vlist-filter (match-lambda
((name . details)
(not (vhash-assoc name target-packages-vhash))))
base-packages-vhash)))))
(define (package-data-vhash->package-versions-vhash package-data-vhash) (define (package-data-vhash->package-versions-vhash package-data-vhash)
(define (system-and-target<? a b) (define (system-and-target<? a b)
@ -180,8 +190,10 @@ ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, t
(begin (begin
(if (equal? base-versions target-versions) (if (equal? base-versions target-versions)
result result
`((,name . ((base . ,(map car base-versions)) `((,name . ((base . ,(list->vector
(target . ,(map car target-versions)))) (map car base-versions)))
(target . ,(list->vector
(map car target-versions)))))
,@result))) ,@result)))
result))) result)))
'() '()
@ -197,25 +209,33 @@ ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, t
(define (derivation-system-and-target-list->alist lst) (define (derivation-system-and-target-list->alist lst)
(if (null? lst) (if (null? lst)
'() '()
`((,(cdr (first lst)) . ,(car (first lst))) `(,(match (first lst)
((derivation-file-name system target)
`((system . ,system)
(target . ,target)
(derivation-file-name . ,derivation-file-name))))
,@(derivation-system-and-target-list->alist (cdr lst))))) ,@(derivation-system-and-target-list->alist (cdr lst)))))
(vhash-fold (list->vector
(lambda (name-and-version target-packages-entry result) (vhash-fold
(let ((base-packages-entry (lambda (name-and-version target-packages-entry result)
(vhash-assoc name-and-version (let ((base-packages-entry
base-package-details-by-name-and-version))) (vhash-assoc name-and-version
(if base-packages-entry base-package-details-by-name-and-version)))
(let ((base-derivations (map cdr (cdr base-packages-entry))) (if base-packages-entry
(target-derivations (map cdr target-packages-entry))) (let ((base-derivations (map cdr (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-and-version result
. ((base . ,(derivation-system-and-target-list->alist `(((name . ,(car name-and-version))
base-derivations)) (version . ,(cdr name-and-version))
(target . ,(derivation-system-and-target-list->alist (base . ,(list->vector
target-derivations)))) (derivation-system-and-target-list->alist
,@result))) base-derivations)))
result))) (target . ,(list->vector
'() (derivation-system-and-target-list->alist
target-package-details-by-name-and-version)) target-derivations))))
,@result)))
result)))
'()
target-package-details-by-name-and-version)))

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

@ -121,8 +121,8 @@
(cond (cond
((eq? content-type 'json) ((eq? content-type 'json)
(render-json (render-json
`((new-packages . ,new-packages) `((new-packages . ,(list->vector new-packages))
(removed-packages . ,removed-packages) (removed-packages . ,(list->vector removed-packages))
(version-changes . ,version-changes) (version-changes . ,version-changes)
(derivation-changes . ,derivation-changes)))) (derivation-changes . ,derivation-changes))))
(else (else

73
guix-data-service/web/view/html.scm
View file

@ -593,7 +593,8 @@
(tbody (tbody
,@(map ,@(map
(match-lambda (match-lambda
(((name . version) metadata) ((('name . name)
('version . version))
`(tr `(tr
(td ,name) (td ,name)
(td ,version)))) (td ,version))))
@ -612,7 +613,8 @@
(tbody (tbody
,@(map ,@(map
(match-lambda (match-lambda
(((name . version) metadata) ((('name . name)
('version . version))
`(tr `(tr
(td ,name) (td ,name)
(td ,version)))) (td ,version))))
@ -636,7 +638,7 @@
(td ,name) (td ,name)
(td (ul (td (ul
,@(map (match-lambda ,@(map (match-lambda
((type . version) ((type . #(version))
`(li (@ (class ,(if (eq? type 'base) `(li (@ (class ,(if (eq? type 'base)
"text-danger" "text-danger"
"text-success"))) "text-success")))
@ -665,33 +667,50 @@
(tbody (tbody
,@(append-map ,@(append-map
(match-lambda (match-lambda
(((name . version) . (('base . base-derivations) ((('name . name)
('target . target-derivations))) ('version . version)
('base . base-derivations)
('target . target-derivations))
(let* ((system-and-versions (let* ((system-and-versions
(delete-duplicates (delete-duplicates
(append (map car base-derivations) (append (map (lambda (details)
(map car target-derivations)))) (cons (assq-ref details 'system)
(assq-ref details 'target)))
(vector->list base-derivations))
(map (lambda (details)
(cons (assq-ref details 'system)
(assq-ref details 'target)))
(vector->list target-derivations)))))
(data-columns (data-columns
(map (map
(lambda (system-and-target) (match-lambda
(let ((base-derivation-file-name ((system . target)
(assoc-ref base-derivations system-and-target)) (let ((base-derivation-file-name
(target-derivation-file-name (assq-ref (find (lambda (details)
(assoc-ref target-derivations system-and-target))) (and (string=? (assq-ref details 'system) system)
`((td (samp (@ (style "white-space: nowrap;")) (string=? (assq-ref details 'target) target)))
,(car system-and-target))) (vector->list base-derivations))
(td (samp (@ (style "white-space: nowrap;")) 'derivation-file-name))
,(cdr system-and-target))) (target-derivation-file-name
(td (a (@ (style "display: block;") (assq-ref (find (lambda (details)
(href ,base-derivation-file-name)) (and (string=? (assq-ref details 'system) system)
(span (@ (class "text-danger glyphicon glyphicon-minus pull-left") (string=? (assq-ref details 'target) target)))
(style "font-size: 1.5em; padding-right: 0.4em;"))) (vector->list target-derivations))
,(display-store-item-short base-derivation-file-name)) 'derivation-file-name)))
(a (@ (style "display: block;") `((td (samp (@ (style "white-space: nowrap;"))
(href ,target-derivation-file-name)) ,system))
(span (@ (class "text-success glyphicon glyphicon-plus pull-left") (td (samp (@ (style "white-space: nowrap;"))
(style "font-size: 1.5em; padding-right: 0.4em;"))) ,target))
,(display-store-item-short target-derivation-file-name)))))) (td (a (@ (style "display: block;")
(href ,base-derivation-file-name))
(span (@ (class "text-danger glyphicon glyphicon-minus pull-left")
(style "font-size: 1.5em; padding-right: 0.4em;")))
,(display-store-item-short base-derivation-file-name))
(a (@ (style "display: block;")
(href ,target-derivation-file-name))
(span (@ (class "text-success glyphicon glyphicon-plus pull-left")
(style "font-size: 1.5em; padding-right: 0.4em;")))
,(display-store-item-short target-derivation-file-name)))))))
system-and-versions))) system-and-versions)))
`((tr (td (@ (rowspan , (length system-and-versions))) `((tr (td (@ (rowspan , (length system-and-versions)))
@ -702,7 +721,7 @@
,@(map (lambda (data-row) ,@(map (lambda (data-row)
`(tr ,data-row)) `(tr ,data-row))
(cdr data-columns)))))) (cdr data-columns))))))
derivation-changes))))))))) (vector->list derivation-changes))))))))))
(define (compare/derivations base-commit (define (compare/derivations base-commit
target-commit target-commit