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
This commit is contained in:
commit
5a9262b38d
GPG key ID:
5E28A33B0B84F577
32 changed files with 9457 additions and 0 deletions
70
guix-data-service/model/derivation.scm
Normal file
70
guix-data-service/model/derivation.scm
Normal file
|
|
@ -0,0 +1,70 @@
|
|||
(define-module (guix-data-service model derivation)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (squee)
|
||||
#:use-module (guix inferior)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix-data-service model utils)
|
||||
#:export (select-existing-derivations
|
||||
insert-into-derivations
|
||||
inferior-packages->derivation-ids))
|
||||
|
||||
(define (select-existing-derivations file-names)
|
||||
(string-append "SELECT id, file_name "
|
||||
"FROM derivations "
|
||||
"WHERE file_name IN "
|
||||
"(" (string-join (map (lambda (file-name)
|
||||
(simple-format #f "'~A'" file-name))
|
||||
file-names)
|
||||
",")
|
||||
");"))
|
||||
|
||||
(define (insert-into-derivations file-names)
|
||||
(string-append "INSERT INTO derivations (file_name) VALUES "
|
||||
(string-join
|
||||
(map
|
||||
(lambda (file-name)
|
||||
(simple-format #f "('~A')" file-name))
|
||||
file-names)
|
||||
",")
|
||||
" RETURNING id"
|
||||
";"))
|
||||
|
||||
(define (inferior-packages->derivation-ids store conn inferior-packages)
|
||||
(let* ((package-derivation-file-names (map (lambda (package)
|
||||
(derivation-file-name
|
||||
(inferior-package-derivation
|
||||
store package)))
|
||||
inferior-packages))
|
||||
|
||||
(existing-derivation-entries (exec-query->vhash
|
||||
conn
|
||||
(select-existing-derivations
|
||||
package-derivation-file-names)
|
||||
second ;; file_name
|
||||
first)) ;; id
|
||||
|
||||
(missing-derivation-file-names
|
||||
(filter (lambda (file-name)
|
||||
(not (vhash-assoc file-name
|
||||
existing-derivation-entries)))
|
||||
package-derivation-file-names))
|
||||
(new-derivation-entries
|
||||
(if (null? missing-derivation-file-names)
|
||||
'()
|
||||
(map car
|
||||
(exec-query
|
||||
conn
|
||||
(insert-into-derivations
|
||||
missing-derivation-file-names)))))
|
||||
(new-entries-id-lookup-vhash
|
||||
(two-lists->vhash missing-derivation-file-names
|
||||
new-derivation-entries)))
|
||||
(map (lambda (derivation-file-name)
|
||||
(cdr
|
||||
(or (vhash-assoc derivation-file-name
|
||||
existing-derivation-entries)
|
||||
(vhash-assoc derivation-file-name
|
||||
new-entries-id-lookup-vhash)
|
||||
(error "missing derivation id"))))
|
||||
package-derivation-file-names)))
|
||||
19
guix-data-service/model/guix-revision-package.scm
Normal file
19
guix-data-service/model/guix-revision-package.scm
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
(define-module (guix-data-service model guix-revision-package)
|
||||
#:use-module (squee)
|
||||
#:export (insert-guix-revision-packages))
|
||||
|
||||
(define (insert-guix-revision-packages conn guix-revision-id package-ids)
|
||||
(define insert
|
||||
(string-append "INSERT INTO guix_revision_packages "
|
||||
"(revision_id, package_id) "
|
||||
"VALUES "
|
||||
(string-join (map (lambda (package-id)
|
||||
(simple-format
|
||||
#f "(~A, ~A)"
|
||||
guix-revision-id
|
||||
package-id))
|
||||
package-ids)
|
||||
", ")
|
||||
";"))
|
||||
|
||||
(exec-query conn insert))
|
||||
39
guix-data-service/model/guix-revision.scm
Normal file
39
guix-data-service/model/guix-revision.scm
Normal file
|
|
@ -0,0 +1,39 @@
|
|||
(define-module (guix-data-service model guix-revision)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (squee)
|
||||
#:export (most-recent-n-guix-revisions
|
||||
commit->revision-id
|
||||
insert-guix-revision
|
||||
guix-revision-exists?))
|
||||
|
||||
(define (most-recent-n-guix-revisions conn n)
|
||||
(exec-query conn "SELECT * FROM guix_revisions ORDER BY id DESC LIMIT 10"))
|
||||
|
||||
(define (commit->revision-id conn commit)
|
||||
(match (exec-query
|
||||
conn "SELECT id FROM guix_revisions WHERE commit = $1 LIMIT 1"
|
||||
(list commit))
|
||||
(((id))
|
||||
id)))
|
||||
|
||||
(define (insert-guix-revision conn url commit store_path)
|
||||
(define insert
|
||||
(string-append "INSERT INTO guix_revisions "
|
||||
"(url, commit, store_path) VALUES "
|
||||
"('" url "', '"
|
||||
commit "', '"
|
||||
store_path "') "
|
||||
"RETURNING id;"))
|
||||
|
||||
(map car (exec-query conn insert)))
|
||||
|
||||
(define (guix-revision-exists? conn url commit)
|
||||
(define query
|
||||
(string-append "SELECT EXISTS("
|
||||
"SELECT 1 FROM guix_revisions WHERE url = '" url "' "
|
||||
"AND commit = '" commit "')"
|
||||
";"))
|
||||
|
||||
(let ((result (caar
|
||||
(exec-query conn query))))
|
||||
(string=? result "t")))
|
||||
96
guix-data-service/model/package-metadata.scm
Normal file
96
guix-data-service/model/package-metadata.scm
Normal file
|
|
@ -0,0 +1,96 @@
|
|||
(define-module (guix-data-service model package-metadata)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (squee)
|
||||
#:use-module (gcrypt hash)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (guix base16)
|
||||
#:use-module (guix inferior)
|
||||
#:use-module (guix-data-service model utils)
|
||||
#:export (select-package-metadata
|
||||
insert-package-metadata
|
||||
inferior-packages->package-metadata-ids))
|
||||
|
||||
(define (select-package-metadata hashes)
|
||||
(string-append "SELECT id, sha1_hash "
|
||||
"FROM package_metadata "
|
||||
"WHERE sha1_hash IN ("
|
||||
(string-join (map (lambda (hash)
|
||||
(simple-format #f "'~A'" hash))
|
||||
hashes)
|
||||
",")
|
||||
");"))
|
||||
|
||||
(define (insert-package-metadata metadata-rows)
|
||||
(string-append "INSERT INTO package_metadata "
|
||||
"(sha1_hash, synopsis, description, home_page) "
|
||||
"VALUES "
|
||||
(string-join
|
||||
(map (match-lambda
|
||||
((sha1_hash synopsis description home_page)
|
||||
(string-append
|
||||
"('" sha1_hash "',"
|
||||
(value->quoted-string-or-null synopsis) ","
|
||||
(value->quoted-string-or-null description) ","
|
||||
(value->quoted-string-or-null home_page) ")")))
|
||||
metadata-rows)
|
||||
",")
|
||||
" RETURNING id"
|
||||
";"))
|
||||
|
||||
|
||||
(define (inferior-packages->package-metadata-ids conn packages)
|
||||
(define package-metadata
|
||||
(map (lambda (package)
|
||||
(let ((data (list (inferior-package-synopsis package)
|
||||
(inferior-package-description package)
|
||||
(inferior-package-home-page package))))
|
||||
`(,(bytevector->base16-string
|
||||
(sha1 (string->utf8
|
||||
(string-join
|
||||
(map (lambda (d)
|
||||
(cond
|
||||
((string? d) d)
|
||||
((boolean? d) (simple-format #f "~A" d))
|
||||
(else d)))
|
||||
data)
|
||||
":"))))
|
||||
,@data)))
|
||||
packages))
|
||||
|
||||
(define package-metadata-hashes
|
||||
(map first package-metadata))
|
||||
|
||||
(let* ((existing-package-metadata-entries
|
||||
(exec-query->vhash conn
|
||||
(select-package-metadata
|
||||
package-metadata-hashes)
|
||||
second ;; sha1_hash
|
||||
first)) ;; id))
|
||||
(missing-package-metadata-entries
|
||||
(delete-duplicates
|
||||
(filter (lambda (metadata)
|
||||
(not (vhash-assoc (first metadata)
|
||||
existing-package-metadata-entries)))
|
||||
package-metadata)))
|
||||
(new-package-metadata-entries
|
||||
(if (null? missing-package-metadata-entries)
|
||||
'()
|
||||
(map car (exec-query conn
|
||||
(insert-package-metadata
|
||||
missing-package-metadata-entries)))))
|
||||
(new-entries-id-lookup-vhash
|
||||
(two-lists->vhash (map first missing-package-metadata-entries)
|
||||
new-package-metadata-entries)))
|
||||
|
||||
(map (lambda (sha1-hash)
|
||||
(cdr
|
||||
(or (vhash-assoc sha1-hash
|
||||
existing-package-metadata-entries)
|
||||
(vhash-assoc sha1-hash
|
||||
new-entries-id-lookup-vhash)
|
||||
(begin
|
||||
sha1-hash
|
||||
(error "missing package-metadata entry")))))
|
||||
package-metadata-hashes)))
|
||||
90
guix-data-service/model/package.scm
Normal file
90
guix-data-service/model/package.scm
Normal file
|
|
@ -0,0 +1,90 @@
|
|||
(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)))
|
||||
27
guix-data-service/model/utils.scm
Normal file
27
guix-data-service/model/utils.scm
Normal file
|
|
@ -0,0 +1,27 @@
|
|||
(define-module (guix-data-service model utils)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (squee)
|
||||
#:export (value->quoted-string-or-null
|
||||
exec-query->vhash
|
||||
two-lists->vhash))
|
||||
|
||||
(define (value->quoted-string-or-null value)
|
||||
(if (string? value)
|
||||
(string-append "$STR$" value "$STR$")
|
||||
"NULL"))
|
||||
|
||||
(define (exec-query->vhash conn query field-function value-function)
|
||||
(fold (lambda (row result)
|
||||
(vhash-cons (field-function row)
|
||||
(value-function row)
|
||||
result))
|
||||
vlist-null
|
||||
(exec-query conn query)))
|
||||
|
||||
(define (two-lists->vhash l1 l2)
|
||||
(fold (lambda (key value result)
|
||||
(vhash-cons key value result))
|
||||
vlist-null
|
||||
l1
|
||||
l2))
|
||||
Loading…
Add table
Add a link
Reference in a new issue