aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am1
-rw-r--r--guix-data-service/model/nar.scm247
-rw-r--r--sqitch/deploy/nar_related_tables.sql53
-rw-r--r--sqitch/revert/nar_related_tables.sql12
-rw-r--r--sqitch/sqitch.plan1
-rw-r--r--sqitch/verify/nar_related_tables.sql7
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;