mirror of
git://git.savannah.gnu.org/guix/data-service.git
synced 2023-12-14 03:23:03 +01:00
5a9262b38d
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
91 lines
3.7 KiB
Scheme
91 lines
3.7 KiB
Scheme
(define-module (guix-data-service model package)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (ice-9 vlist)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (squee)
|
|
#:use-module (guix inferior)
|
|
#:use-module (guix-data-service model utils)
|
|
#:export (select-existing-package-entries
|
|
insert-into-package-entries
|
|
inferior-packages->package-ids))
|
|
|
|
(define (select-existing-package-entries package-entries)
|
|
(string-append "SELECT id, packages.name, packages.version, "
|
|
"packages.package_metadata_id, packages.derivation_id "
|
|
"FROM packages "
|
|
"JOIN (VALUES "
|
|
(string-join (map (lambda (package-entry)
|
|
(apply
|
|
simple-format
|
|
#f "('~A', '~A', ~A, ~A)"
|
|
package-entry))
|
|
package-entries)
|
|
", ")
|
|
") AS vals (name, version, package_metadata_id, derivation_id) "
|
|
"ON packages.name = vals.name AND "
|
|
"packages.version = vals.version AND "
|
|
"packages.package_metadata_id = vals.package_metadata_id AND "
|
|
"packages.derivation_id = vals.derivation_id"
|
|
";"))
|
|
|
|
(define (insert-into-package-entries package-entries)
|
|
(string-append "INSERT INTO packages "
|
|
"(name, version, package_metadata_id, derivation_id) VALUES "
|
|
(string-join
|
|
(map
|
|
(match-lambda
|
|
((name version package_metadata_id derivation_id)
|
|
(simple-format #f "('~A', '~A', ~A, ~A)"
|
|
name
|
|
version
|
|
package_metadata_id
|
|
derivation_id)))
|
|
package-entries)
|
|
",")
|
|
" RETURNING id"
|
|
";"))
|
|
|
|
(define (inferior-packages->package-ids conn packages metadata-ids derivation-ids)
|
|
(define package-entries
|
|
(map (lambda (package metadata-id derivation-id)
|
|
(list (inferior-package-name package)
|
|
(inferior-package-version package)
|
|
metadata-id
|
|
derivation-id))
|
|
packages
|
|
metadata-ids
|
|
derivation-ids))
|
|
|
|
(let* ((existing-package-entry-ids
|
|
(exec-query->vhash conn
|
|
(select-existing-package-entries package-entries)
|
|
;; name, version, package_metadata_id and
|
|
;; derivation_id
|
|
cdr
|
|
first)) ;;id
|
|
(missing-package-entries
|
|
(filter (lambda (package-entry)
|
|
(not (vhash-assoc package-entry
|
|
existing-package-entry-ids)))
|
|
package-entries))
|
|
(new-package-entry-ids
|
|
(if (null? missing-package-entries)
|
|
'()
|
|
(map car
|
|
(exec-query
|
|
conn
|
|
(insert-into-package-entries
|
|
missing-package-entries)))))
|
|
(new-entries-id-lookup-vhash
|
|
(two-lists->vhash missing-package-entries
|
|
new-package-entry-ids)))
|
|
|
|
(map (lambda (package-entry)
|
|
(cdr
|
|
(or (vhash-assoc package-entry
|
|
existing-package-entry-ids)
|
|
(vhash-assoc package-entry
|
|
new-entries-id-lookup-vhash)
|
|
(error "missing package entry"))))
|
|
package-entries)))
|