Begin to add support for importing narinfo files

This commit adds the tables, as well as code to support extracting data from
narinfo files.

1 files changed, 247 insertions, 0 deletions

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)))))