From 5a9262b38d506008b21fd73eb8f7c3046b47de92 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 6 Feb 2019 16:14:44 +0000 Subject: Initial commit This is a service designed to provide information about Guix. At the moment, this initial prototype gathers up information about packages, the associated metadata and derivations. The initial primary use case is to compare two different revisions of Guix, detecting which packages are new, no longer present, updated or otherwise different. It's based on the Mumi project. [1]: https://git.elephly.net/software/mumi.git --- guix-data-service/comparison.scm | 122 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 122 insertions(+) create mode 100644 guix-data-service/comparison.scm (limited to 'guix-data-service/comparison.scm') diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm new file mode 100644 index 0000000..4dfd96e --- /dev/null +++ b/guix-data-service/comparison.scm @@ -0,0 +1,122 @@ +(define-module (guix-data-service comparison) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:use-module (squee) + #:export (package-data->package-data-vhashes + package-differences-data + package-data-vhashes->new-packages + package-data-vhashes->removed-packages + package-data-version-changes + package-data-other-changes)) + +(define (package-differences-data conn base_guix_revision_id target_guix_revision_id) + (define query + "WITH base_packages AS ( + SELECT packages.* FROM packages INNER JOIN guix_revision_packages ON packages.id = guix_revision_packages.package_id WHERE revision_id = $1 +), target_packages AS ( + SELECT packages.* FROM packages INNER JOIN guix_revision_packages ON packages.id = guix_revision_packages.package_id WHERE revision_id = $2 +) +SELECT base_packages.name, base_packages.version, base_packages.package_metadata_id, base_packages.derivation_id, target_packages.name, target_packages.version, target_packages.package_metadata_id, target_packages.derivation_id +FROM base_packages +FULL OUTER JOIN target_packages ON base_packages.name = target_packages.name AND base_packages.version = target_packages.version +WHERE (base_packages.id IS NULL OR target_packages.id IS NULL OR base_packages.id != target_packages.id) +ORDER BY base_packages.name, base_packages.version, target_packages.name, target_packages.version") + + (exec-query conn query (list base_guix_revision_id target_guix_revision_id))) + +(define (package-data->package-data-vhashes package-data) + (define (add-data-to-vhash data vhash) + (let ((key (first data))) + (if (string-null? key) + vhash + (vhash-cons key + (drop data 1) + vhash)))) + + (apply values + (fold (lambda (row result) + (let-values (((base-row-part target-row-part) (split-at row 4))) + (match result + ((base-package-data target-package-data) + (list (add-data-to-vhash base-row-part base-package-data) + (add-data-to-vhash target-row-part target-package-data)))))) + (list vlist-null vlist-null) + package-data))) + +(define (package-data-vhash->package-name-and-version-vhash vhash) + (vhash-fold (lambda (name details result) + (vhash-cons (cons name (first details)) + (cdr details) + result)) + vlist-null + vhash)) + +(define (package-data-vhashes->new-packages base-packages-vhash target-packages-vhash) + (vlist->list + (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 + (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) + (vhash-fold (lambda (name details result) + (let ((version (first details)) + (known-versions (vhash-assoc name result))) + (if known-versions + (vhash-cons name + (cons version known-versions) + (vhash-delete name result)) + (vhash-cons name + (list version) + result)))) + vlist-null + package-data-vhash)) + +(define (package-data-version-changes base-packages-vhash target-packages-vhash) + (let ((base-versions (package-data-vhash->package-versions-vhash + base-packages-vhash)) + (target-versions (package-data-vhash->package-versions-vhash + target-packages-vhash))) + (vhash-fold (lambda (name target-versions result) + (let ((base-versions (and=> (vhash-assoc name base-versions) + cdr))) + (if base-versions + (begin + (if (equal? base-versions target-versions) + result + `((,name . ((base . ,base-versions) + (target . ,target-versions))) + ,@result))) + result))) + '() + target-versions))) + +(define (package-data-other-changes base-packages-vhash target-packages-vhash) + (define base-package-details-by-name-and-version + (package-data-vhash->package-name-and-version-vhash base-packages-vhash)) + + (define target-package-details-by-name-and-version + (package-data-vhash->package-name-and-version-vhash target-packages-vhash)) + + (vhash-fold (lambda (name-and-version target-details result) + (let ((base-packages-entry + (vhash-assoc name-and-version base-package-details-by-name-and-version))) + (if base-packages-entry + (let ((base-details (cdr base-packages-entry))) + (if (equal? base-details target-details) + result + `((,name-and-version . ((base . ,base-details) + (target . ,target-details))) + ,@result))) + result))) + '() + target-package-details-by-name-and-version)) -- cgit v1.2.3