From 5325cf02341fca124de8567e14adc06bcbffd5c2 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 16 Mar 2019 21:55:09 +0000 Subject: Fix the JSON responses for the comparison pages --- guix-data-service/comparison.scm | 88 ++++++++++++++++++++++-------------- guix-data-service/web/controller.scm | 4 +- guix-data-service/web/view/html.scm | 73 +++++++++++++++++++----------- 3 files changed, 102 insertions(+), 63 deletions(-) (limited to 'guix-data-service') diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm index 132def8..68cafa8 100644 --- a/guix-data-service/comparison.scm +++ b/guix-data-service/comparison.scm @@ -126,20 +126,30 @@ ORDER BY base_packages.name DESC, base_packages.version, target_packages.name, t vhash)) (define (package-data-vhashes->new-packages base-packages-vhash 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)))) + (map + (match-lambda + (((name . version) metadata ...) + `((name . ,name) + (version . ,version)))) + (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) - (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)))) + (map + (match-lambda + (((name . version) metadata ...) + `((name . ,name) + (version . ,version)))) + (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 (system-and-targetvector + (map car base-versions))) + (target . ,(list->vector + (map car target-versions))))) ,@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) (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))))) - (vhash-fold - (lambda (name-and-version target-packages-entry result) - (let ((base-packages-entry - (vhash-assoc name-and-version - base-package-details-by-name-and-version))) - (if base-packages-entry - (let ((base-derivations (map cdr (cdr base-packages-entry))) - (target-derivations (map cdr target-packages-entry))) - (if (equal? base-derivations target-derivations) - result - `((,name-and-version - . ((base . ,(derivation-system-and-target-list->alist - base-derivations)) - (target . ,(derivation-system-and-target-list->alist - target-derivations)))) - ,@result))) - result))) - '() - target-package-details-by-name-and-version)) + (list->vector + (vhash-fold + (lambda (name-and-version target-packages-entry result) + (let ((base-packages-entry + (vhash-assoc name-and-version + base-package-details-by-name-and-version))) + (if base-packages-entry + (let ((base-derivations (map cdr (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))) diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm index a8dd897..1b83b02 100644 --- a/guix-data-service/web/controller.scm +++ b/guix-data-service/web/controller.scm @@ -121,8 +121,8 @@ (cond ((eq? content-type 'json) (render-json - `((new-packages . ,new-packages) - (removed-packages . ,removed-packages) + `((new-packages . ,(list->vector new-packages)) + (removed-packages . ,(list->vector removed-packages)) (version-changes . ,version-changes) (derivation-changes . ,derivation-changes)))) (else diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm index 8d7405c..8640774 100644 --- a/guix-data-service/web/view/html.scm +++ b/guix-data-service/web/view/html.scm @@ -593,7 +593,8 @@ (tbody ,@(map (match-lambda - (((name . version) metadata) + ((('name . name) + ('version . version)) `(tr (td ,name) (td ,version)))) @@ -612,7 +613,8 @@ (tbody ,@(map (match-lambda - (((name . version) metadata) + ((('name . name) + ('version . version)) `(tr (td ,name) (td ,version)))) @@ -636,7 +638,7 @@ (td ,name) (td (ul ,@(map (match-lambda - ((type . version) + ((type . #(version)) `(li (@ (class ,(if (eq? type 'base) "text-danger" "text-success"))) @@ -665,33 +667,50 @@ (tbody ,@(append-map (match-lambda - (((name . version) . (('base . base-derivations) - ('target . target-derivations))) + ((('name . name) + ('version . version) + ('base . base-derivations) + ('target . target-derivations)) (let* ((system-and-versions (delete-duplicates - (append (map car base-derivations) - (map car target-derivations)))) + (append (map (lambda (details) + (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 (map - (lambda (system-and-target) - (let ((base-derivation-file-name - (assoc-ref base-derivations system-and-target)) - (target-derivation-file-name - (assoc-ref target-derivations system-and-target))) - `((td (samp (@ (style "white-space: nowrap;")) - ,(car system-and-target))) - (td (samp (@ (style "white-space: nowrap;")) - ,(cdr system-and-target))) - (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)))))) + (match-lambda + ((system . target) + (let ((base-derivation-file-name + (assq-ref (find (lambda (details) + (and (string=? (assq-ref details 'system) system) + (string=? (assq-ref details 'target) target))) + (vector->list base-derivations)) + 'derivation-file-name)) + (target-derivation-file-name + (assq-ref (find (lambda (details) + (and (string=? (assq-ref details 'system) system) + (string=? (assq-ref details 'target) target))) + (vector->list target-derivations)) + 'derivation-file-name))) + `((td (samp (@ (style "white-space: nowrap;")) + ,system)) + (td (samp (@ (style "white-space: nowrap;")) + ,target)) + (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))) `((tr (td (@ (rowspan , (length system-and-versions))) @@ -702,7 +721,7 @@ ,@(map (lambda (data-row) `(tr ,data-row)) (cdr data-columns)))))) - derivation-changes))))))))) + (vector->list derivation-changes)))))))))) (define (compare/derivations base-commit target-commit -- cgit v1.2.3