diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix-data-service/model/nar.scm | 247 | ||||
| -rw-r--r-- | sqitch/deploy/nar_related_tables.sql | 53 | ||||
| -rw-r--r-- | sqitch/revert/nar_related_tables.sql | 12 | ||||
| -rw-r--r-- | sqitch/sqitch.plan | 1 | ||||
| -rw-r--r-- | sqitch/verify/nar_related_tables.sql | 7 |
6 files changed, 321 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am index c66d289..e73f94b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -88,6 +88,7 @@ SOURCES = \ guix-data-service/model/lint-warning-message.scm \ guix-data-service/model/lint-warning.scm \ guix-data-service/model/location.scm \ + guix-data-service/model/nar.scm \ guix-data-service/model/package-derivation.scm \ guix-data-service/model/package-metadata.scm \ guix-data-service/model/package.scm \ diff --git a/guix-data-service/model/nar.scm b/guix-data-service/model/nar.scm new file mode 100644 index 0000000..0898ae4 --- /dev/null +++ b/guix-data-service/model/nar.scm @@ -0,0 +1,247 @@ +1(define-module (guix-data-service model nar) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (web uri) + #:use-module (squee) + #:use-module (json) + #:use-module (rnrs bytevectors) + #:use-module (gcrypt pk-crypto) + #:use-module (gcrypt base16) + #:use-module (guix scripts substitute) + #:use-module (guix-data-service model utils) + #:export (select-outputs-for-successful-builds-without-known-nar-entries + + record-narinfo-details-and-return-ids)) + +(define narinfo-contents + (@@ (guix scripts substitute) narinfo-contents)) + +(define (record-narinfo-details-and-return-ids conn narinfos) + (define data + (map (lambda (narinfo) + (match (string-split + (narinfo-hash narinfo) + #\:) + ((hash-algorithm hash) + (list + (narinfo-path narinfo) + hash-algorithm + hash + (narinfo-size narinfo) + (or (narinfo-system narinfo) NULL) + (or (narinfo-deriver narinfo) NULL))))) + narinfos)) + + (let ((nar-ids + (insert-missing-data-and-return-all-ids + conn + "nars" + '(store_path hash_algorithm hash size system deriver) + data))) + + (exec-query + conn + (string-append + " +INSERT INTO nar_references (nar_id, reference) +VALUES " + (string-join + (concatenate + (map (lambda (nar-id narinfo) + (map (lambda (reference) + (simple-format + #f + "(~A, ~A)" + nar-id + (quote-string reference))) + (narinfo-references narinfo))) + nar-ids + narinfos)) + ", ") + " +ON CONFLICT DO NOTHING")) + + (exec-query + conn + (string-append + " +INSERT INTO nar_urls (nar_id, url, compression, file_size) +VALUES " + (string-join + (concatenate + (map (lambda (nar-id narinfo) + (map (lambda (uri compression file-size) + (simple-format + #f + "(~A, ~A, ~A, ~A)" + nar-id + (quote-string + (uri->string uri)) + (quote-string compression) + file-size)) + (narinfo-uris narinfo) + (narinfo-compressions narinfo) + (narinfo-file-sizes narinfo))) + nar-ids + narinfos)) + ", ") + " +ON CONFLICT DO NOTHING")) + + (for-each (lambda (nar-id narinfo) + (let ((narinfo-signature-data-id + (narinfo-signature->data-id conn narinfo))) + + (exec-query + conn + (string-append + " +INSERT INTO narinfo_signatures (nar_id, narinfo_signature_data_id) +VALUES " + (simple-format + #f + "(~A,~A)" + nar-id + narinfo-signature-data-id) + " +ON CONFLICT DO NOTHING")))) + nar-ids + narinfos) + + nar-ids)) + +(define (sexp->json-string sexp) + (define (transform x) + (if (list? x) + (list->vector (map transform x)) + (if (bytevector? x) + `((base16 . ,(bytevector->base16-string x))) + x))) + + (scm->json-string (transform sexp))) + +(define (narinfo-signature->data-id conn narinfo) + (let ((public-key-id + (narinfo-signature->public-key-id + conn + (narinfo-signature narinfo))) + (contents + (narinfo-contents narinfo))) + + (match (string-contains contents "Signature:") + (#f #f) + (index + (let* ((body (string-take contents index)) + (signature-line (string-drop contents index)) + (signature-sexp + (canonical-sexp->sexp + (narinfo-signature narinfo)))) + + (match (string-split (second (string-split signature-line + #\space)) + #\;) + ((version host-name signature-data) + + (first + (insert-missing-data-and-return-all-ids + conn + "narinfo_signature_data" + '(version host_name data_hash data_hash_algorithm + data_json sig_val_json narinfo_signature_public_key_id + narinfo_body narinfo_signature_line) + (list + (append (list (string->number version) + host-name) + (let* ((data-sexp + (find (match-lambda + ((component data ...) + (if (eq? component 'data) + data + #f)) + (_ #f)) + signature-sexp)) + (hash-sexp + (third data-sexp)) + (hash-algorithm + (second hash-sexp)) + (hash + (third hash-sexp))) + (list + (bytevector->base16-string hash) + hash-algorithm + (cons "jsonb" + (sexp->json-string data-sexp)))) + (let ((sig-val-sexp + (find (match-lambda + ((component data ...) + (if (eq? component 'sig-val) + data + #f)) + (_ #f)) + signature-sexp))) + (list + (cons "jsonb" + (sexp->json-string sig-val-sexp)))) + (list public-key-id + body + signature-line)))))))))))) + +(define (narinfo-signature->public-key-id conn signature) + (let* ((public-key-sexp + (find (match-lambda + ((component data ...) + (if (eq? component 'public-key) + data + #f)) + (_ #f)) + (canonical-sexp->sexp signature))) + (public-key-json-string + (sexp->json-string public-key-sexp))) + + (first + (insert-missing-data-and-return-all-ids + conn + "narinfo_signature_public_keys" + '(sexp_json) + (list (list (cons "jsonb" + public-key-json-string))))))) + +(define (select-outputs-for-successful-builds-without-known-nar-entries + conn + build-server-id + guix-revision-commits) + (define query + (string-append " +SELECT DISTINCT derivation_output_details.path +FROM derivations +INNER JOIN derivation_outputs + ON derivations.id = derivation_outputs.id +INNER JOIN derivation_output_details + ON derivation_outputs.derivation_output_details_id = derivation_output_details.id +WHERE file_name IN ( + SELECT derivation_file_name + FROM builds + INNER JOIN build_status + ON builds.id = build_status.build_id + WHERE + build_server_id = $1 AND + build_status.status = 'succeeded' +) AND derivation_output_details.path NOT IN ( + SELECT store_path FROM nars +) AND + derivations.id IN ( + SELECT derivation_id + FROM package_derivations + INNER JOIN guix_revision_package_derivations + ON guix_revision_package_derivations.package_derivation_id = package_derivations.id + INNER JOIN guix_revisions + ON guix_revisions.id = guix_revision_package_derivations.revision_id + WHERE guix_revisions.commit IN (" + (string-join (map quote-string guix-revision-commits) + ",") + ") +) +LIMIT 1500")) + + (map car (exec-query conn query (list (number->string + build-server-id))))) diff --git a/sqitch/deploy/nar_related_tables.sql b/sqitch/deploy/nar_related_tables.sql new file mode 100644 index 0000000..50bf9b0 --- /dev/null +++ b/sqitch/deploy/nar_related_tables.sql @@ -0,0 +1,53 @@ +-- Deploy guix-data-service:nar_related_tables to pg + +BEGIN; + +CREATE TABLE nars ( + id integer PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + store_path varchar NOT NULL, + hash_algorithm varchar NOT NULL, + hash varchar NOT NULL, + size integer NOT NULL, + system varchar, + deriver varchar +); + +CREATE TABLE nar_urls ( + nar_id integer NOT NULL REFERENCES nars(id), + url varchar PRIMARY KEY, + compression varchar NOT NULL, + file_size integer NOT NULL +); + +CREATE TABLE nar_references ( + nar_id integer NOT NULL REFERENCES nars(id), + reference varchar NOT NULL +); + +CREATE TABLE narinfo_signature_public_keys ( + id integer PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + sexp_json jsonb NOT NULL, + UNIQUE (sexp_json) +); + +CREATE TABLE narinfo_signature_data ( + id integer PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + version integer NOT NULL, + host_name varchar NOT NULL, + data_hash varchar NOT NULL, + data_hash_algorithm varchar NOT NULL, + data_json jsonb NOT NULL, + sig_val_json jsonb NOT NULL, + narinfo_signature_public_key_id integer NOT NULL REFERENCES narinfo_signature_public_keys(id), + narinfo_body varchar NOT NULL, + narinfo_signature_line varchar NOT NULL, + UNIQUE (narinfo_signature_line) +); + +CREATE TABLE narinfo_signatures ( + nar_id integer NOT NULL REFERENCES nars(id), + narinfo_signature_data_id integer NOT NULL REFERENCES narinfo_signature_data(id), + UNIQUE (nar_id, narinfo_signature_data_id) +); + +COMMIT; diff --git a/sqitch/revert/nar_related_tables.sql b/sqitch/revert/nar_related_tables.sql new file mode 100644 index 0000000..eeb1e9c --- /dev/null +++ b/sqitch/revert/nar_related_tables.sql @@ -0,0 +1,12 @@ +-- Revert guix-data-service:nar_related_tables from pg + +BEGIN; + +DROP TABLE narinfo_signatures; +DROP TABLE narinfo_signature_data; +DROP TABLE narinfo_signature_public_keys; +DROP TABLE nar_references; +DROP TABLE nar_urls; +DROP TABLE nars; + +COMMIT; diff --git a/sqitch/sqitch.plan b/sqitch/sqitch.plan index 5990567..c6de817 100644 --- a/sqitch/sqitch.plan +++ b/sqitch/sqitch.plan @@ -29,3 +29,4 @@ package_derivations_by_guix_revision_range 2019-11-09T19:09:48Z Christopher Bain channel_news_tables 2019-11-15T07:32:07Z Christopher Baines <mail@cbaines.net> # Add tables to store channel news build_server_token_seeds 2019-11-23T09:26:48Z Christopher Baines <mail@cbaines.net> # Add build_server_token_seeds table rework_builds 2019-11-23T20:41:20Z Christopher Baines <mail@cbaines.net> # Rework the build tables +nar_related_tables 2019-11-29T20:28:19Z Christopher Baines <mail@cbaines.net> # Add nar related tables diff --git a/sqitch/verify/nar_related_tables.sql b/sqitch/verify/nar_related_tables.sql new file mode 100644 index 0000000..ae5c0e7 --- /dev/null +++ b/sqitch/verify/nar_related_tables.sql @@ -0,0 +1,7 @@ +-- Verify guix-data-service:nar_related_tables on pg + +BEGIN; + +-- XXX Add verifications here. + +ROLLBACK; |