diff options
author | Christopher Baines <mail@cbaines.net> | 2019-02-10 09:42:22 +0000 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2019-02-10 09:42:22 +0000 |
commit | c88d8335babf437bec3961b24d5aa92c82a59d27 (patch) | |
tree | 2f69e46c93bd30a768aa85e331a2a81936940c50 /guix-data-service/model/derivation.scm | |
parent | 552723cef15285d36f1ca8ae87d8672a093522d2 (diff) | |
download | data-service-c88d8335babf437bec3961b24d5aa92c82a59d27.tar data-service-c88d8335babf437bec3961b24d5aa92c82a59d27.tar.gz |
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.
Diffstat (limited to 'guix-data-service/model/derivation.scm')
-rw-r--r-- | guix-data-service/model/derivation.scm | 364 |
1 files changed, 319 insertions, 45 deletions
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))))) |