Improve the model for derivations

These changes mean that more information about derivations is
recorded. There are a number of corresponding changes in the database
schema that are not tracked in the repository unfortunately.

4 files changed, 349 insertions, 47 deletions

diff --git a/guix-data-service/comparison.scm b/guix-data-service/comparison.scm
index 4dfd96e..bd09d49 100644
--- a/guix-data-service/comparison.scm
+++ b/guix-data-service/comparison.scm
@@ -4,8 +4,10 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (squee)
+  #:use-module (guix-data-service model derivation)
   #:export (package-data->package-data-vhashes
             package-differences-data
+            package-data-vhashes->derivations
             package-data-vhashes->new-packages
             package-data-vhashes->removed-packages
             package-data-version-changes
@@ -45,6 +47,24 @@ ORDER BY base_packages.name, base_packages.version, target_packages.name, target
                (list vlist-null vlist-null)
                package-data)))
 
+(define (package-data-vhashes->derivations conn
+                                           base-packages-vhash
+                                           target-packages-vhash)
+  (define (vhash->derivation-ids vhash)
+    (vhash-fold (lambda (key value result)
+                  (cons (third value)
+                        result))
+                '()
+                vhash))
+
+  (let* ((derivation-ids
+          (delete-duplicates
+           (append (vhash->derivation-ids base-packages-vhash)
+                   (vhash->derivation-ids target-packages-vhash))))
+         (derivation-data
+          (select-derivations-by-id conn derivation-ids)))
+    derivation-data))
+
 (define (package-data-vhash->package-name-and-version-vhash vhash)
   (vhash-fold (lambda (name details result)
                 (vhash-cons (cons name (first details))
diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm
index 8aeef51..ea1909a 100644
--- a/guix-data-service/jobs/load-new-guix-revision.scm
+++ b/guix-data-service/jobs/load-new-guix-revision.scm
@@ -19,7 +19,11 @@
          (packages-metadata-ids
           (inferior-packages->package-metadata-ids conn packages))
          (packages-derivation-ids
-          (inferior-packages->derivation-ids store conn packages)))
+          (derivations->derivation-ids conn
+                                       (map (lambda (package)
+                                              (inferior-package-derivation
+                                               store package))
+                                            packages))))
 
     (inferior-packages->package-ids
      conn packages packages-metadata-ids packages-derivation-ids)))
diff --git a/guix-data-service/model/derivation.scm b/guix-data-service/model/derivation.scm
index 0dfa2af..ef39251 100644
--- a/guix-data-service/model/derivation.scm
+++ b/guix-data-service/model/derivation.scm
@@ -1,13 +1,16 @@
 (define-module (guix-data-service model derivation)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
   #:use-module (squee)
+  #:use-module (guix base32)
   #:use-module (guix inferior)
   #:use-module (guix derivations)
   #:use-module (guix-data-service model utils)
   #:export (select-existing-derivations
+            select-derivations-by-id
             insert-into-derivations
-            inferior-packages->derivation-ids))
+            derivations->derivation-ids))
 
 (define (select-existing-derivations file-names)
   (string-append "SELECT id, file_name "
@@ -19,52 +22,323 @@
                                   ",")
                  ");"))
 
-(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)
+(define (select-from-derivation-output-details paths)
+  (string-append
+   "SELECT id, path FROM derivation_output_details "
+   "WHERE path IN ("
+   (string-join (map quote-string paths)
+                ",")
+   ")"))
+
+(define (insert-derivation-outputs conn
+                                   derivation-id
+                                   names-and-derivation-outputs)
+  (define (insert-into-derivation-output-details derivation-outputs)
+    (string-append
+     "INSERT INTO derivation_output_details "
+     "(path, hash_algorithm, hash, recursive) VALUES "
+     (string-join
+      (map
+       (match-lambda
+         (($ <derivation-output> path hash-algo hash recursive?)
+          (string-append
+           "("
+           (string-join
+            (list (quote-string path)
+                  (value->quoted-string-or-null
+                   (and=> hash-algo symbol->string))
+                  (value->quoted-string-or-null
+                   (and=> hash bytevector->nix-base32-string))
+                  (if recursive? "TRUE" "FALSE"))
+            ",")
+           ")")))
+       derivation-outputs)
+      ",")
+     " RETURNING id"
+     ";"))
+
+  (define (insert-into-derivation-outputs output-names
+                                          derivation-output-ids)
+    (string-append "INSERT INTO derivation_outputs "
+                   "(derivation_id, name, derivation_output_details_id) VALUES "
+                   (string-join
+                    (map (lambda (output-name derivation-output-id)
+                           (simple-format
+                            #f "(~A, '~A', ~A)"
+                            derivation-id output-name derivation-output-id))
+                         output-names
+                         derivation-output-ids)
+                    ",")
+                   ";"))
+
+  (let* ((derivation-outputs (map cdr names-and-derivation-outputs))
+         (derivation-output-paths (map derivation-output-path
+                                       derivation-outputs))
+
+         (existing-derivation-output-details-entries
+          (exec-query->vhash
+           conn
+           (select-from-derivation-output-details
+            derivation-output-paths)
+           second ;; path
+           first)) ;; id
+
+         (missing-entries (filter
+                           (lambda (derivation-output)
+                             (not (vhash-assoc
+                                   (derivation-output-path derivation-output)
+                                   existing-derivation-output-details-entries)))
+                           derivation-outputs))
+
+         (new-derivation-output-details-ids
+          (if (null? missing-entries)
               '()
               (map car
                    (exec-query
                     conn
-                    (insert-into-derivations
-                     missing-derivation-file-names)))))
+                    (insert-into-derivation-output-details missing-entries)))))
+
+         (new-entries-id-lookup-vhash
+          (two-lists->vhash (map derivation-output-path missing-entries)
+                            new-derivation-output-details-ids))
+
+         (derivation-output-ids
+          (map (lambda (path)
+                 (cdr
+                  (or (vhash-assoc path
+                                   existing-derivation-output-details-entries)
+                      (vhash-assoc path
+                                   new-entries-id-lookup-vhash)
+                      (error "missing derivation output details entry"))))
+               derivation-output-paths))
+
+         (derivation-output-names
+          (map car names-and-derivation-outputs)))
+
+    (exec-query conn
+                (insert-into-derivation-outputs derivation-output-names
+                                                derivation-output-ids))
+
+    derivation-output-ids))
+
+(define (select-derivation-output-id conn name path)
+  (match (exec-query
+          conn
+          (string-append
+           "SELECT derivation_outputs.id FROM derivation_outputs "
+           "INNER JOIN derivations ON "
+           "derivation_outputs.derivation_id = derivations.id "
+           "WHERE derivations.file_name = '" path "' "
+           "AND derivation_outputs.name = '" name "';"))
+    (((id))
+     id)
+    (()
+     (error (simple-format
+             #f "cannot find derivation-output with name ~A and path ~A"
+             name path)))))
+
+(define (insert-derivation-input conn derivation-id derivation-input)
+  (define (insert-into-derivation-inputs output-ids)
+    (string-append "INSERT INTO derivation_inputs "
+                   "(derivation_id, derivation_output_id) VALUES "
+                   (string-join
+                    (map (lambda (output-id)
+                           (simple-format
+                            #f "(~A, ~A)"
+                            derivation-id output-id))
+                         output-ids)
+                    ",")
+                   ";"))
+
+  (match derivation-input
+    (($ <derivation-input> path sub-derivations)
+     (exec-query
+      conn
+      (insert-into-derivation-inputs
+       (map (lambda (sub-derivation)
+              (select-derivation-output-id conn
+                                           sub-derivation
+                                           path))
+            sub-derivations))))))
+
+(define (select-from-derivation-source-files store-paths)
+  (string-append
+   "SELECT id, store_path FROM derivation_source_files "
+   "WHERE store_path IN ("
+   (string-join (map quote-string store-paths)
+                ",")
+   ");"))
+
+(define (insert-derivation-sources conn derivation-id sources)
+  (define (insert-into-derivation-source-files store-paths)
+    (string-append
+     "INSERT INTO derivation_source_files (store_path) VALUES "
+     (string-join
+      (map (lambda (store-path)
+             (simple-format
+              #f "('~A')" store-path))
+           store-paths)
+      ",")
+     " RETURNING id"
+     ";"))
+
+  (define (insert-into-derivation-sources derivation-source-file-ids)
+    (string-append
+     "INSERT INTO derivation_sources "
+     "(derivation_id, derivation_source_file_id) VALUES "
+     (string-join
+      (map (lambda (derivation-source-file-id)
+             (simple-format
+              #f "(~A, ~A)" derivation-id derivation-source-file-id))
+           derivation-source-file-ids)
+      ",")
+     ";"))
+
+  (let* ((existing-derivation-store-paths
+          (exec-query->vhash
+           conn
+           (select-from-derivation-source-files sources)
+           second ;; store_path
+           first)) ;; id
+
+         (missing-entries (filter
+                           (lambda (store-path)
+                             (not (vhash-assoc store-path
+                                               existing-derivation-store-paths)))
+                           sources))
+
+         (new-derivation-source-file-entries
+          (if (null? missing-entries)
+              '()
+              (exec-query conn
+                          (insert-into-derivation-source-files missing-entries))))
+
          (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)))
+          (two-lists->vhash missing-entries
+                            new-derivation-source-file-entries))
+
+         (sources-ids
+          (map (lambda (store-path)
+                 (cdr
+                  (or (vhash-assoc store-path
+                                   existing-derivation-store-paths)
+                      (vhash-assoc store-path
+                                   new-entries-id-lookup-vhash)
+                      (error "missing derivation source files entry"))))
+               sources)))
+
+    (exec-query conn
+                (insert-into-derivation-sources sources-ids))))
+
+(define (insert-missing-derivations conn derivations)
+  (define (insert-into-derivations)
+    (string-append
+     "INSERT INTO derivations "
+     "(file_name, builder, args, env_vars, system) VALUES "
+     (string-join
+      (map (match-lambda
+             (($ <derivation> outputs inputs sources
+                              system builder args env-vars file-name)
+              (simple-format
+               #f "('~A', '~A', ARRAY[~A]::varchar[], ARRAY[~A], '~A')"
+               file-name
+               builder
+               (string-join (map quote-string args) ",")
+               (string-join (map (match-lambda
+                                   ((key . value)
+                                    (string-append
+                                     "['" key '"', $$"
+                                     value "$$ ]")))
+                                 env-vars)
+                            ",")
+               system)))
+           derivations)
+      ",")
+     " RETURNING id"
+     ";"))
+
+  (map (lambda (derivation-id derivation)
+         (insert-derivation-outputs conn
+                                    derivation-id
+                                    (derivation-outputs derivation))
+
+         (insert-derivation-sources conn
+                                    derivation-id
+                                    (derivation-sources derivation))
+
+         (for-each (lambda (derivation-input)
+                     (insert-derivation-input conn
+                                              derivation-id
+                                              derivation-input))
+                   (derivation-inputs derivation))
+
+         derivation-id)
+       (map car (exec-query conn (insert-into-derivations)))
+       derivations))
+
+(define (select-derivations-by-id conn ids)
+  (define query
+    (string-append "SELECT id, file_name "
+                   "FROM derivations "
+                   "WHERE id IN "
+                   "(" (string-join (map (lambda (id)
+                                           (simple-format #f "'~A'" id))
+                                         ids)
+                                    ",")
+                   ");"))
+
+  (exec-query conn query))
+
+(define (derivations->derivation-ids conn derivations)
+  (define (ensure-input-derivations-exist)
+    (let* ((missing-derivation-file-names (map derivation-file-name
+                                               derivations))
+
+           (input-derivation-file-names (delete-duplicates
+                                         (map derivation-input-path
+                                              (append-map
+                                               derivation-inputs
+                                               derivations)))))
+
+      ;; Ensure all the input derivations exist
+      (derivations->derivation-ids
+       conn
+       (map read-derivation-from-file
+            input-derivation-file-names))))
+
+  (if (null? derivations)
+      '()
+      (begin
+        (ensure-input-derivations-exist)
+        (let* ((derivation-file-names (map derivation-file-name
+                                           derivations))
+
+               (existing-derivation-entries (exec-query->vhash
+                                             conn
+                                             (select-existing-derivations
+                                              derivation-file-names)
+                                             second ;; file_name
+                                             first)) ;; id
+
+               (missing-derivations
+                (filter (lambda (derivation)
+                          (not (vhash-assoc (derivation-file-name derivation)
+                                            existing-derivation-entries)))
+                        derivations))
+
+               (new-derivation-entries
+                (if (null? missing-derivations)
+                    '()
+                    (insert-missing-derivations conn missing-derivations)))
+
+               (new-entries-id-lookup-vhash
+                (two-lists->vhash (map derivation-file-name missing-derivations)
+                                  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"))))
+               derivation-file-names)))))
diff --git a/guix-data-service/model/utils.scm b/guix-data-service/model/utils.scm
index df2acd9..8a85e2b 100644
--- a/guix-data-service/model/utils.scm
+++ b/guix-data-service/model/utils.scm
@@ -2,10 +2,14 @@
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 vlist)
   #:use-module (squee)
-  #:export (value->quoted-string-or-null
+  #:export (quote-string
+            value->quoted-string-or-null
             exec-query->vhash
             two-lists->vhash))
 
+(define (quote-string s)
+  (string-append "'" s "'"))
+
 (define (value->quoted-string-or-null value)
   (if (string? value)
       (string-append "$STR$" value "$STR$")