diff options
Diffstat (limited to 'guix-data-service/model')
25 files changed, 1368 insertions, 1490 deletions
diff --git a/guix-data-service/model/blocked-builds.scm b/guix-data-service/model/blocked-builds.scm index 888e842..2dcbee1 100644 --- a/guix-data-service/model/blocked-builds.scm +++ b/guix-data-service/model/blocked-builds.scm @@ -353,7 +353,7 @@ WHERE status IN ('failed', 'failed-dependency', 'failed-other', 'canceled') (get-sql-to-select-package-and-related-derivations-for-revision conn (commit->revision-id conn revision-commit) - #:system-id (system->system-id conn system) + #:system-id (lookup-system-id conn system) #:target target) (string-append " @@ -369,7 +369,7 @@ WITH RECURSIVE all_derivations AS ( (simple-format #f " AND system_id = ~A\n" - (system->system-id conn system)) + (lookup-system-id conn system)) "") (if target (simple-format diff --git a/guix-data-service/model/build-server.scm b/guix-data-service/model/build-server.scm index d73dddd..ee25538 100644 --- a/guix-data-service/model/build-server.scm +++ b/guix-data-service/model/build-server.scm @@ -16,11 +16,15 @@ ;;; <http://www.gnu.org/licenses/>. (define-module (guix-data-service model build-server) + #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (squee) + #:use-module (guix-data-service database) + #:use-module (guix-data-service model utils) #:export (select-build-servers select-build-server - select-build-server-urls-by-id)) + select-build-server-urls-by-id + specify-build-servers)) (define (select-build-servers conn) (define query @@ -58,3 +62,173 @@ WHERE id = $1") ((id url lookup-all-derivations? lookup-builds?) (cons id url))) (select-build-servers conn))) + +(define (specify-build-servers build-servers) + (define (specify-token-seeds conn + build-server-id + token-seeds) + (define string-build-server-id + (number->string build-server-id)) + + (let* ((db-token-seeds + (map + car + (exec-query + conn + " +SELECT token_seed +FROM build_server_token_seeds +WHERE build_server_id = $1" + (list string-build-server-id)))) + (token-seeds-to-delete + (lset-difference string=? + db-token-seeds + token-seeds)) + (token-seeds-to-insert + (lset-difference string=? + token-seeds + db-token-seeds))) + + (for-each + (lambda (seed) + (exec-query + conn + " +DELETE FROM build_server_token_seeds +WHERE build_server_id = $1 + AND token_seed = $2" + (list string-build-server-id + seed))) + token-seeds-to-delete) + + (for-each + (lambda (seed) + (exec-query + conn + " +INSERT INTO build_server_token_seeds +VALUES ($1, $2)" + (list string-build-server-id + seed))) + token-seeds-to-insert))) + + (define (specify-build-config conn + build-server-id + systems-and-targets) + (define string-build-server-id + (number->string build-server-id)) + + (define pair-equal? + (match-lambda* + (((s1 . t1) (s2 . t2)) + (and (string=? s1 s2) + (string=? t1 t2))))) + + (let* ((db-systems-and-targets + (map + (match-lambda + ((system target) + (cons system target))) + (exec-query + conn + " +SELECT system, target +FROM build_servers_build_config +WHERE build_server_id = $1" + (list string-build-server-id)))) + (systems-and-targets-to-delete + (lset-difference pair-equal? + db-systems-and-targets + systems-and-targets)) + (systems-and-targets-to-insert + (lset-difference pair-equal? + systems-and-targets + db-systems-and-targets))) + + (for-each + (match-lambda + ((system . target) + (exec-query + conn + " +DELETE FROM build_servers_build_config +WHERE build_server_id = $1 + AND system = $2 + AND target = $3" + (list string-build-server-id + system + target)))) + systems-and-targets-to-delete) + + (for-each + (match-lambda + ((system . target) + (exec-query + conn + " +INSERT INTO build_servers_build_config +VALUES ($1, $2, $3)" + (list string-build-server-id + system + target)))) + systems-and-targets-to-insert))) + + (with-postgresql-connection + "specify-build-servers" + (lambda (conn) + (with-postgresql-transaction + conn + (lambda (conn) + (let* ((existing-ids + (map first (select-build-servers conn))) + (target-ids + (map (lambda (repo) + (or (assq-ref repo 'id) + (error "build server missing id"))) + build-servers)) + (build-servers-to-delete + (lset-difference equal? + existing-ids + target-ids))) + (for-each + (lambda (id-to-remove) + (simple-format (current-error-port) + "deleting build server ~A\n" + id-to-remove) + (exec-query + conn + "DELETE FROM build_servers WHERE id = $1" + (list (number->string id-to-remove)))) + build-servers-to-delete) + + (for-each + (lambda (build-server) + (let* ((related-table-keys '(systems-and-targets + token-seeds)) + (build-servers-without-related-data + (filter-map + (lambda (pair) + (if (memq (car pair) related-table-keys) + #f + pair)) + build-server)) + (fields (map car build-servers-without-related-data)) + (field-vals (map cdr build-servers-without-related-data))) + (update-or-insert + conn + "build_servers" + fields + field-vals) + + (specify-token-seeds + conn + (assq-ref build-server 'id) + (or (assq-ref build-server 'token-seeds) + '())) + + (specify-build-config + conn + (assq-ref build-server 'id) + (or (assq-ref build-server 'systems-and-targets) + '())))) + build-servers))))))) diff --git a/guix-data-service/model/build.scm b/guix-data-service/model/build.scm index 1240453..acf745a 100644 --- a/guix-data-service/model/build.scm +++ b/guix-data-service/model/build.scm @@ -136,12 +136,14 @@ WHERE builds.id = $1" (exec-query conn " +WITH derivation_output_details_ids (id) AS ( + SELECT unnest(derivation_output_details_ids) AS id + FROM derivation_output_details_sets + WHERE derivation_output_details_sets.id = $1 +) SELECT derivation_output_details.path FROM derivation_output_details -INNER JOIN derivation_output_details_sets - ON ARRAY[derivation_output_details.id] && - derivation_output_details_sets.derivation_output_details_ids -WHERE derivation_output_details_sets.id = $1" +WHERE derivation_output_details.id IN (SELECT id FROM derivation_output_details_ids)" (list output-details-set-id)) (exec-query conn @@ -281,13 +283,14 @@ FROM builds INNER JOIN build_servers ON build_servers.id = builds.build_server_id INNER JOIN latest_build_status ON latest_build_status.build_id = builds.id -INNER JOIN derivation_output_details_sets - ON builds.derivation_output_details_set_id = - derivation_output_details_sets.id -INNER JOIN derivation_output_details - ON ARRAY[derivation_output_details.id] <@ - derivation_output_details_sets.derivation_output_details_ids -WHERE derivation_output_details.path = $1 +WHERE builds.derivation_output_details_set_id = ( + SELECT derivation_output_details_sets.id + FROM derivation_output_details_sets + INNER JOIN derivation_output_details + ON ARRAY[derivation_output_details.id] <@ + derivation_output_details_sets.derivation_output_details_ids + WHERE derivation_output_details.path = $1 +) ORDER BY latest_build_status.timestamp DESC") (exec-query-with-null-handling conn query (list output))) @@ -507,19 +510,20 @@ WHERE derivations.file_name = $1" derivation-output-details-lists build-server-build-ids) (let ((build-ids - (insert-missing-data-and-return-all-ids - conn - "builds" - '(build_server_id derivation_file_name build_server_build_id) - (map (lambda (derivation-file-name build-server-build-id) - (list build-server-id - derivation-file-name - (if (string? build-server-build-id) - build-server-build-id - '()))) - derivation-file-names - build-server-build-ids) - #:delete-duplicates? #t))) + (vector->list + (insert-missing-data-and-return-all-ids + conn + "builds" + '(build_server_id derivation_file_name build_server_build_id) + (list->vector + (map (lambda (derivation-file-name build-server-build-id) + (list build-server-id + derivation-file-name + (if (string? build-server-build-id) + build-server-build-id + '()))) + derivation-file-names + build-server-build-ids)))))) (for-each (lambda (build-id derivation-output-details) diff --git a/guix-data-service/model/channel-instance.scm b/guix-data-service/model/channel-instance.scm index 84fc901..2cce2da 100644 --- a/guix-data-service/model/channel-instance.scm +++ b/guix-data-service/model/channel-instance.scm @@ -22,36 +22,28 @@ #:use-module (json) #:use-module (guix utils) #:use-module (guix-data-service model utils) - #:use-module (guix-data-service model derivation) #:export (insert-channel-instances channel-instances-exist-for-guix-revision? select-channel-instances-for-guix-revision)) (define (insert-channel-instances conn guix-revision-id - derivations-by-system) - (let ((derivation-ids - (derivation-file-names->derivation-ids - conn - (list->vector - (map cdr derivations-by-system))))) - - (exec-query - conn - (string-append - " + derivation-ids-by-system) + (exec-query + conn + (string-append + " INSERT INTO channel_instances (guix_revision_id, system, derivation_id) VALUES " - (string-join - (map (lambda (system derivation-id) - (simple-format #f "(~A, '~A', ~A)" - guix-revision-id - system - derivation-id)) - (map car derivations-by-system) - (vector->list derivation-ids)) - ", ")))) + (string-join + (map (lambda (derivation-id-and-system) + (simple-format #f "(~A, '~A', ~A)" + guix-revision-id + (car derivation-id-and-system) + (cdr derivation-id-and-system))) + derivation-ids-by-system) + ", "))) #t) (define (channel-instances-exist-for-guix-revision? conn commit-hash) diff --git a/guix-data-service/model/channel-news.scm b/guix-data-service/model/channel-news.scm index 6bc6842..4bb5625 100644 --- a/guix-data-service/model/channel-news.scm +++ b/guix-data-service/model/channel-news.scm @@ -76,62 +76,21 @@ SELECT channel_news_entries.commit, conn "channel_news_entry_text" '(lang text) - (map (match-lambda - ((lang . text) - (list lang text))) - text))) + (list->vector + (map (match-lambda + ((lang . text) + (list lang text))) + text)))) (define (insert-channel-news-entry conn commit tag) - (match (exec-query - conn - (string-append - "INSERT INTO channel_news_entries (commit, tag) VALUES (" - (value->quoted-string-or-null commit) - "," - (value->quoted-string-or-null tag) - ") RETURNING id")) - (((id)) - (string->number id)))) + (insert-and-return-id + conn + "channel_news_entries" + '(commit tag) + (list (or commit NULL) + (or tag NULL)))) (define (insert-channel-news-entries conn channel-news-entries) - (define select-channel-news-entries - " -SELECT channel_news_entries.id, - channel_news_entries.commit, - channel_news_entries.tag, - ( - SELECT ARRAY_AGG( - channel_news_entry_titles.channel_news_entry_text_id - ORDER BY channel_news_entry_titles.channel_news_entry_text_id - ) - FROM channel_news_entry_titles - WHERE channel_news_entry_id = channel_news_entries.id - ) AS title_text, - ( - SELECT ARRAY_AGG( - channel_news_entry_bodies.channel_news_entry_text_id - ORDER BY channel_news_entry_bodies.channel_news_entry_text_id - ) - FROM channel_news_entry_bodies - WHERE channel_news_entry_id = channel_news_entries.id - ) AS body_text -FROM channel_news_entries -ORDER BY id") - - (define existing - (exec-query->vhash conn - select-channel-news-entries - (match-lambda - ((_ commit tag title-ids body-ids) - (list commit - tag - (map string->number - (parse-postgresql-array-string title-ids)) - (map string->number - (parse-postgresql-array-string body-ids))))) - (lambda (result) - (string->number (first result))))) - (map (lambda (entry) (let ((commit (channel-news-entry-commit entry)) @@ -145,36 +104,29 @@ ORDER BY id") conn (channel-news-entry-body entry)) <))) - (or (and=> (vhash-assoc (list (or commit '()) - (or tag '()) - title-ids - body-ids) - existing) - (match-lambda - ((value . key) - key))) - (let ((channel-news-entry-id - (insert-channel-news-entry conn commit tag))) - (for-each - (lambda (table ids) - (exec-query - conn - (string-append - "INSERT INTO " table - " VALUES " - (string-join - (map (lambda (id) - (simple-format #f "(~A, ~A)" - channel-news-entry-id - id)) - ids) - ", ")))) - '("channel_news_entry_titles" - "channel_news_entry_bodies") - (list title-ids - body-ids)) + (let ((channel-news-entry-id + (insert-channel-news-entry conn commit tag))) + (for-each + (lambda (table ids) + (exec-query + conn + (string-append + "INSERT INTO " table + " VALUES " + (string-join + (map (lambda (id) + (simple-format #f "(~A, ~A)" + channel-news-entry-id + id)) + (vector->list ids)) + ", ") + " ON CONFLICT DO NOTHING"))) + '("channel_news_entry_titles" + "channel_news_entry_bodies") + (list title-ids + body-ids)) - channel-news-entry-id)))) + channel-news-entry-id))) channel-news-entries)) (define (insert-channel-news-entries-for-guix-revision @@ -194,5 +146,6 @@ ORDER BY id") (simple-format #f "(~A,~A,~A)" guix-revision-id id index)) channel-news-entry-ids (iota (length channel-news-entries))) - ", "))))) + ", ") + " ON CONFLICT DO NOTHING")))) #t) diff --git a/guix-data-service/model/derivation.scm b/guix-data-service/model/derivation.scm index 170be49..a19bfca 100644 --- a/guix-data-service/model/derivation.scm +++ b/guix-data-service/model/derivation.scm @@ -21,15 +21,13 @@ #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module (ice-9 exceptions) #:use-module (ice-9 binary-ports) #:use-module (rnrs bytevectors) - #:use-module (gcrypt hash) #:use-module (squee) #:use-module (json) #:use-module (guix base16) #:use-module (guix base32) - #:use-module (guix serialization) - #:use-module (lzlib) #:use-module (guix inferior) #:use-module (guix memoization) #:use-module (guix derivations) @@ -58,6 +56,13 @@ select-fixed-output-package-derivations-in-revision select-derivation-outputs-in-revision fix-derivation-output-details-hash-encoding + fix-derivation-inputs + insert-derivation-sources + insert-derivation-source-file-nar + insert-placeholder-derivation-source-file-nar + update-derivation-source-file-nar + insert-derivation-outputs + insert-derivation-inputs derivation-output-details->derivation-output-details-ids derivation-output-details-ids->derivation-output-details-set-id select-derivations-by-revision-name-and-version @@ -66,11 +71,15 @@ select-existing-derivations select-derivations-by-id select-derivations-and-build-status - derivation-file-names->derivation-ids update-derivation-inputs-statistics vacuum-derivation-inputs-table update-derivation-outputs-statistics - vacuum-derivation-outputs-table)) + vacuum-derivation-outputs-table + + &missing-derivation-output-error + missing-derivation-output-error? + missing-derivation-output-error-name + missing-derivation-output-error-path)) (define (valid-targets conn) '("arm-linux-gnueabihf" @@ -198,7 +207,7 @@ ORDER BY systems.system DESC, (define* (select-package-derivations-in-revision conn commit-hash #:key - systems + system targets minimum-builds maximum-builds @@ -214,19 +223,25 @@ ORDER BY systems.system DESC, (string-join `(,@(filter-map (lambda (field values) - (if values - (string-append - field " IN (" - (string-join (map (lambda (value) - (simple-format #f "'~A'" value)) - values) - ",") - ")") - #f)) - '("systems.system" - "target") - (list systems - targets)) + (cond + ((list? values) + (string-append + field " IN (" + (string-join (map (lambda (value) + (simple-format #f "'~A'" value)) + values) + ",") + ")")) + ((number? values) + (string-append + field " = " (number->string values))) + (else + #f))) + '("package_derivations.system_id" "target") + (list + (and=> system (lambda (system) + (system->system-id conn system))) + targets)) ,@(if minimum-builds (list (string-append @@ -346,7 +361,6 @@ EXISTS ( (string-append " SELECT derivations.file_name, - systems.system, package_derivations.target" (if include-builds? ", @@ -371,8 +385,6 @@ SELECT derivations.file_name, "") " FROM derivations -INNER JOIN systems - ON derivations.system_id = systems.id INNER JOIN derivations_by_output_details_set ON derivations.id = derivations_by_output_details_set.derivation_id INNER JOIN package_derivations @@ -400,7 +412,7 @@ ORDER BY derivations.file_name ""))) (map (match-lambda - ((file_name system target builds) + ((file_name target builds) (list file_name system target @@ -408,7 +420,7 @@ ORDER BY derivations.file_name (eq? #f builds)) #() (json-string->scm builds)))) - ((file_name system target) + ((file_name target) (list file_name system target))) (exec-query conn query @@ -711,7 +723,7 @@ LIMIT $1")) (map (match-lambda ((derivation_file_name latest_build) `((derivation_file_name . ,derivation_file_name) - (latest_build . ,(if (null? latest_build) + (latest_build . ,(if (NULL? latest_build) 'null (map (match-lambda ((key . value) @@ -897,7 +909,7 @@ ORDER BY derivation_output_details.path hash hash_algorithm (string=? recursive "t") - (if (null? nars_json) + (if (NULL? nars_json) #() (json-string->scm nars_json)))) ((package_name package_version @@ -969,6 +981,28 @@ LOCK TABLE ONLY derivation_output_details ;; Recurse in case there are more to fix (loop (find-old-derivations-and-hashes conn)))))))) +(define (fix-derivation-inputs conn drv) + (define (derivation-missing-inputs? conn drv-id) + (let ((inputs (select-derivation-inputs-by-derivation-id + conn + drv-id))) + ;; TODO Detect missing inputs, as well as them all missing + (null? inputs))) + + (with-postgresql-transaction + conn + (lambda (conn) + (match (select-derivation-by-file-name conn (derivation-file-name drv)) + ((drv-id rest ...) + (if (derivation-missing-inputs? conn drv-id) + (begin + (insert-derivation-inputs + conn + (vector drv-id) + (vector drv)) + #t) + #f)))))) + (define (derivation-output-details->derivation-output-details-ids conn derivation-output-details) @@ -977,76 +1011,30 @@ LOCK TABLE ONLY derivation_output_details conn "derivation_output_details" '(path hash_algorithm hash recursive) - (map (lambda (details) - (list (assq-ref details 'path) - (or (non-empty-string-or-false - (assq-ref details 'hash_algorithm)) - NULL) - (or (non-empty-string-or-false - (assq-ref details 'hash)) - NULL) - (assq-ref details 'recursive))) - derivation-output-details))) + (list->vector + (map (lambda (details) + (list (assq-ref details 'path) + (or (non-empty-string-or-false + (assq-ref details 'hash_algorithm)) + NULL) + (or (non-empty-string-or-false + (assq-ref details 'hash)) + NULL) + (assq-ref details 'recursive))) + derivation-output-details)))) (define (derivation-output-details-ids->derivation-output-details-set-id conn derivation-output-details-ids) - (define sorted-derivation-output-details-ids - (sort derivation-output-details-ids <)) - - (define (select-derivation-output-details-sets-id) - (match (exec-query - conn - (string-append - " -SELECT id -FROM derivation_output_details_sets -WHERE derivation_output_details_ids = ARRAY[" - (string-join (map number->string - sorted-derivation-output-details-ids) - ",") - "]")) - (((id)) - (string->number id)) - (_ #f))) - - (define (insert-into-derivation-output-details-sets) - (match (exec-query - conn - (string-append - " -INSERT INTO derivation_output_details_sets (derivation_output_details_ids) -VALUES (ARRAY[" - (string-join (map number->string - sorted-derivation-output-details-ids) - ",") - "]) -RETURNING id")) - (((id)) - (string->number id)))) - - (or (select-derivation-output-details-sets-id) - (insert-into-derivation-output-details-sets))) + (insert-and-return-id + conn + "derivation_output_details_sets" + '(derivation_output_details_ids) + (list (sort derivation-output-details-ids <)))) (define (insert-derivation-outputs conn derivation-id names-and-derivation-outputs) - (define (insert-into-derivation-outputs output-names - derivation-output-details-ids) - (string-append "INSERT INTO derivation_outputs " - "(derivation_id, name, derivation_output_details_id) VALUES " - (string-join - (map (lambda (output-name derivation-output-details-id) - (simple-format - #f "(~A, '~A', ~A)" - derivation-id - output-name - derivation-output-details-id)) - output-names - derivation-output-details-ids) - ",") - ";")) - (define (insert-into-derivations-by-output-details-set derivation_output_details_set_id) (exec-query @@ -1054,42 +1042,53 @@ RETURNING id")) " INSERT INTO derivations_by_output_details_set (derivation_id, derivation_output_details_set_id) -VALUES ($1, $2)" +VALUES ($1, $2) +ON CONFLICT DO NOTHING" (list (number->string derivation-id) (number->string derivation_output_details_set_id)))) - (let* ((derivation-outputs (map cdr names-and-derivation-outputs)) - (derivation-output-paths (map derivation-output-path - derivation-outputs)) - (derivation-output-names - (map car names-and-derivation-outputs)) - - (derivation-output-details-ids - (derivation-output-details->derivation-output-details-ids - conn - (map - (match-lambda - (($ <derivation-output> path hash-algo hash recursive?) - `((path . ,path) - (hash_algorithm . ,(or (and=> hash-algo symbol->string) - NULL)) - (hash . ,(or (and=> hash bytevector->base16-string) - NULL)) - (recursive . ,recursive?)))) - derivation-outputs)))) - - (exec-query conn - (insert-into-derivation-outputs - derivation-output-names - derivation-output-details-ids)) - - (insert-into-derivations-by-output-details-set - (derivation-output-details-ids->derivation-output-details-set-id - conn - derivation-output-details-ids)) - +(let* ((derivation-outputs + (map cdr names-and-derivation-outputs)) + (derivation-output-paths + (map derivation-output-path + derivation-outputs)) + (derivation-output-details-ids + (derivation-output-details->derivation-output-details-ids + conn + (map + (match-lambda + (($ <derivation-output> path hash-algo hash recursive?) + `((path . ,path) + (hash_algorithm . ,(or (and=> hash-algo symbol->string) + NULL)) + (hash . ,(or (and=> hash bytevector->base16-string) + NULL)) + (recursive . ,recursive?)))) + derivation-outputs)))) + + (insert-missing-data + conn + "derivation_outputs" + '(derivation_id name derivation_output_details_id) + (let ((vec + (list->vector + (map car names-and-derivation-outputs)))) + (vector-map! + (lambda (_ output-name derivation-output-details-id) + (list derivation-id + output-name + derivation-output-details-id)) + vec + derivation-output-details-ids) + vec)) + + (insert-into-derivations-by-output-details-set + (derivation-output-details-ids->derivation-output-details-set-id + conn derivation-output-details-ids)) + derivation-output-details-ids)) + (define (select-derivation-by-file-name-hash conn file-name-hash) (define query (string-append @@ -1136,6 +1135,12 @@ VALUES ($1, $2)" (vector->list (json-string->scm env_vars))) system)))) +(define-exception-type &missing-derivation-output-error &error + make-derivation-output-error + missing-derivation-output-error? + (name missing-derivation-output-error-name) + (path missing-derivation-output-error-path)) + (define (select-derivation-outputs-by-derivation-id conn id) (define query (string-append @@ -1409,26 +1414,24 @@ WHERE derivation_source_files.store_path = $1" (define (insert-derivation-inputs conn derivation-ids derivations) (let ((query-parts - (append-map! - (lambda (derivation-id derivation) - (append-map! - (match-lambda - (($ <derivation-input> derivation-or-path sub-derivations) - (let ((path - (match derivation-or-path - ((? derivation? d) - ;; The first field changed to a derivation (from the file - ;; name) in 5cf4b26d52bcea382d98fb4becce89be9ee37b55 - (derivation-file-name d)) - ((? string? s) - s)))) - (map (lambda (sub-derivation) - (string-append "(" - (number->string derivation-id) - ", '" path - "', '" sub-derivation "')")) - sub-derivations)))) + (vector-fold + (lambda (_ result derivation-id derivation) + (fold + (lambda (drv-input result) + (match drv-input + (($ <derivation-input> (? derivation? d) sub-derivations) + (fold (lambda (sub-derivation result) + (cons + (string-append + "(" (number->string derivation-id) + ", '" (derivation-file-name d) + "', '" sub-derivation "')") + result)) + result + sub-derivations)))) + result (derivation-inputs derivation))) + '() derivation-ids derivations))) @@ -1443,22 +1446,15 @@ SELECT vals.derivation_id, derivation_outputs.id FROM (VALUES " (string-join query-parts-chunk ", ") ") AS vals (derivation_id, file_name, output_name) -INNER JOIN derivations +LEFT JOIN derivations ON derivations.file_name = vals.file_name -INNER JOIN derivation_outputs +LEFT JOIN derivation_outputs ON derivation_outputs.derivation_id = derivations.id - AND vals.output_name = derivation_outputs.name"))) + AND derivation_outputs.name = vals.output_name +ON CONFLICT DO NOTHING"))) 1000 query-parts))) -(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-sources derivation-source-file-ids) (string-append @@ -1468,54 +1464,28 @@ INNER JOIN derivation_outputs (map (lambda (derivation-source-file-id) (simple-format #f "(~A, ~A)" derivation-id derivation-source-file-id)) - derivation-source-file-ids) + (vector->list derivation-source-file-ids)) ",") - ";")) + "ON CONFLICT DO NOTHING;")) (let ((sources-ids (insert-missing-data-and-return-all-ids conn "derivation_source_files" '(store_path) - (map list sources)))) + (list->vector + (map list sources))))) (exec-query conn (insert-into-derivation-sources sources-ids)) sources-ids)) -(define (insert-derivation-source-file-nar conn id source-file) - (define missing? - (match (exec-query - conn - "SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1" - (list (number->string id))) - (() #t) - (_ #f))) - - (when missing? - (let* ((nar-bytevector (call-with-values - (lambda () - (open-bytevector-output-port)) - (lambda (port get-bytevector) - (write-file source-file port) - (get-bytevector)))) - (data-string (bytevector->base16-string - (call-with-values - (lambda () - (open-bytevector-output-port)) - (lambda (port get-bytevector) - (call-with-lzip-output-port port - (lambda (port) - (put-bytevector port nar-bytevector)) - #:level 9) - (get-bytevector))))) - (hash (bytevector->nix-base32-string - (sha256 nar-bytevector))) - (uncompressed-size (bytevector-length nar-bytevector))) - (exec-query - conn - " +(define (insert-derivation-source-file-nar conn id + hash bytevector uncompressed-size) + (exec-query + conn + " INSERT INTO derivation_source_file_nars ( derivation_source_file_id, compression, @@ -1523,13 +1493,47 @@ INSERT INTO derivation_source_file_nars ( hash, uncompressed_size, data -) VALUES ($1, $2, $3, $4, $5, $6)" - (list (number->string id) - "lzip" - "sha256" - hash - (number->string uncompressed-size) - (string-append "\\x" data-string)))))) +) VALUES ($1, $2, $3, $4, $5, $6) +ON CONFLICT DO NOTHING" + (list (number->string id) + "lzip" + "sha256" + hash + (number->string uncompressed-size) + (string-append "\\x" (bytevector->base16-string bytevector))))) + +(define (insert-placeholder-derivation-source-file-nar conn id) + (exec-query + conn + " +INSERT INTO derivation_source_file_nars ( + derivation_source_file_id, + compression, + hash_algorithm, + hash, + uncompressed_size, + data +) VALUES ($1, $2, $3, $4, $5, $6) +ON CONFLICT DO NOTHING" + (list (number->string id) + "lzip" + "sha256" + "placeholder" + "0" + ""))) + +(define (update-derivation-source-file-nar conn id + hash bytevector uncompressed-size) + (exec-query + conn + " +UPDATE derivation_source_file_nars +SET hash = $1, uncompressed_size = $2, data = $3 +WHERE derivation_source_file_id = $4" + (list hash + (number->string uncompressed-size) + (string-append "\\x" (bytevector->base16-string bytevector)) + (number->string id)))) (define* (backfill-derivation-source-file-nars conn #:key (batch-size 10000) @@ -1561,130 +1565,6 @@ LIMIT $1" batch) (when loop? (loop (missing-batch)))))) -(define (insert-missing-derivations conn - derivation-ids-hash-table - derivations) - (define (ensure-input-derivations-exist input-derivation-file-names) - (unless (null? input-derivation-file-names) - (simple-format - #t "debug: ensure-input-derivations-exist: processing ~A derivations\n" - (length input-derivation-file-names)) - - (update-derivation-ids-hash-table! conn - derivation-ids-hash-table - (list->vector - input-derivation-file-names)) - (simple-format - #t - "debug: ensure-input-derivations-exist: checking for missing input derivations\n") - (let ((missing-derivations-filenames - (filter (lambda (derivation-file-name) - (not (hash-ref derivation-ids-hash-table - derivation-file-name))) - input-derivation-file-names))) - - (unless (null? missing-derivations-filenames) - (simple-format - #f - "debug: ensure-input-derivations-exist: inserting missing input derivations\n") - ;; Ensure all the input derivations exist - (insert-missing-derivations - conn - derivation-ids-hash-table - (map read-derivation-from-file - missing-derivations-filenames)))))) - - (define (insert-into-derivations dervs) - (string-append - "INSERT INTO derivations " - "(file_name, builder, args, env_vars, system_id) 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->system-id conn system)))) - dervs) - ",") - " RETURNING id" - ";")) - - (simple-format - #t "debug: insert-missing-derivations: inserting ~A derivations\n" - (length derivations)) - (let ((derivation-ids - (append-map - (lambda (chunk) - (map (lambda (result) - (string->number (car result))) - (exec-query conn (insert-into-derivations chunk)))) - (chunk derivations 500)))) - - (simple-format - #t "debug: insert-missing-derivations: updating hash table\n") - (for-each (lambda (derivation derivation-id) - (hash-set! derivation-ids-hash-table - (derivation-file-name derivation) - derivation-id)) - derivations - derivation-ids) - - (simple-format - #t "debug: insert-missing-derivations: inserting outputs\n") - (for-each (lambda (derivation-id derivation) - (insert-derivation-outputs conn - derivation-id - (derivation-outputs derivation))) - derivation-ids - derivations) - - (simple-format - #t "debug: insert-missing-derivations: inserting sources\n") - (for-each (lambda (derivation-id derivation) - (let ((sources (derivation-sources derivation))) - (unless (null? sources) - (let ((sources-ids - (insert-derivation-sources conn - derivation-id - sources))) - (map (lambda (id source-file) - (insert-derivation-source-file-nar conn - id - source-file)) - sources-ids - sources))))) - derivation-ids - derivations) - - (simple-format - #t "debug: insert-missing-derivations: ensure-input-derivations-exist\n") - - (ensure-input-derivations-exist (deduplicate-strings - (map derivation-input-path - (append-map derivation-inputs - derivations)))) - - (with-time-logging - (simple-format - #f "insert-missing-derivations: inserting inputs for ~A derivations" - (length derivations)) - (insert-derivation-inputs conn - derivation-ids - derivations)) - - derivation-ids)) - (define (select-derivations-by-id conn ids) (define query (string-append "SELECT id, file_name " @@ -1769,80 +1649,42 @@ WHERE " criteria ";")) '() sorted-derivations)) -(define (update-derivation-ids-hash-table! conn - derivation-ids-hash-table - file-names) - (define file-names-count (vector-length file-names)) - - (simple-format #t "debug: update-derivation-ids-hash-table!: ~A file-names\n" - file-names-count) - (let ((missing-file-names - (vector-fold - (lambda (_ result file-name) - (if (and file-name - (hash-ref derivation-ids-hash-table - file-name)) - result - (cons file-name result))) - '() - file-names))) - - (simple-format - #t "debug: update-derivation-ids-hash-table!: lookup ~A file-names, ~A not cached\n" - file-names-count (length missing-file-names)) - - (unless (null? missing-file-names) - (for-each - (lambda (chunk) - (for-each - (match-lambda - ((id file-name) - (hash-set! derivation-ids-hash-table - file-name - (string->number id)))) - (exec-query conn (select-existing-derivations chunk)))) - (chunk! missing-file-names 1000))))) - -(define (derivation-file-names->derivation-ids conn derivation-file-names) - (define derivations-count - (vector-length derivation-file-names)) - - (define (insert-source-files-missing-nars derivation-ids) - (define (derivation-ids->next-related-derivation-ids! ids seen-ids) - (delete-duplicates/sort! - (append-map! - (lambda (ids-chunk) - (let ((query - (string-append - " +(define (insert-source-files-missing-nars conn derivation-ids) + (define (derivation-ids->next-related-derivation-ids! ids seen-ids) + (delete-duplicates/sort! + (append-map! + (lambda (ids-chunk) + (let ((query + (string-append + " SELECT derivation_outputs.derivation_id FROM derivation_inputs INNER JOIN derivation_outputs ON derivation_outputs.id = derivation_inputs.derivation_output_id WHERE derivation_inputs.derivation_id IN (" - (string-join (map number->string ids) ",") - ")"))) - - (filter-map - (lambda (row) - (let ((number - (string->number - (car row)))) - (if (hash-ref seen-ids number) - #f - (begin - (hash-set! seen-ids number #t) - - number)))) - (exec-query conn query)))) - (chunk! ids 500)) - < - =)) - - (define (derivation-ids->missing-sources ids) - (define query - (string-append - " + (string-join (map number->string ids) ",") + ")"))) + + (filter-map + (lambda (row) + (let ((number + (string->number + (car row)))) + (if (hash-ref seen-ids number) + #f + (begin + (hash-set! seen-ids number #t) + + number)))) + (exec-query conn query)))) + (chunk! ids 500)) + < + =)) + + (define (derivation-ids->missing-sources ids) + (define query + (string-append + " SELECT derivation_sources.derivation_source_file_id, derivation_source_files.store_path FROM derivation_sources LEFT JOIN derivation_source_file_nars @@ -1852,114 +1694,42 @@ INNER JOIN derivation_source_files ON derivation_sources.derivation_source_file_id = derivation_source_files.id WHERE derivation_sources.derivation_id IN (" - (string-join (map number->string ids) ", ") - ") + (string-join (map number->string ids) ", ") + ") AND derivation_source_file_nars.derivation_source_file_id IS NULL")) - (map (lambda (row) - (list (string->number (first row)) - (second row))) - (exec-query conn query))) - - (let ((seen-ids (make-hash-table))) - (let loop ((next-related-derivation-ids - (derivation-ids->next-related-derivation-ids! - (list-copy derivation-ids) - seen-ids))) - (unless (null? next-related-derivation-ids) - (let ((missing-sources - (append-map! derivation-ids->missing-sources - (chunk next-related-derivation-ids - 10000)))) - - (unless (null? missing-sources) - (with-time-logging - (simple-format #f "inserting ~A missing source files" - (length missing-sources)) - (for-each (match-lambda - ((derivation-source-file-id store-path) - (insert-derivation-source-file-nar - conn - derivation-source-file-id - store-path))) - missing-sources)))) - - (loop - (derivation-ids->next-related-derivation-ids! - next-related-derivation-ids - seen-ids)))))) - - (if (= 0 derivations-count) - #() - (let* ((derivation-ids-hash-table (make-hash-table - ;; Account for more derivations in - ;; the graph - (* 2 derivations-count)))) - (simple-format - #t "debug: derivation-file-names->derivation-ids: processing ~A derivations\n" - derivations-count) - - (update-derivation-ids-hash-table! conn - derivation-ids-hash-table - derivation-file-names) - - (let ((missing-derivation-filenames - (deduplicate-strings - (vector-fold - (lambda (_ result derivation-file-name) - (if (not derivation-file-name) - result - (if (hash-ref derivation-ids-hash-table - derivation-file-name) - result - (cons derivation-file-name result)))) - '() - derivation-file-names)))) - - (chunk-for-each! - (lambda (missing-derivation-filenames-chunk) - (let ((missing-derivations-chunk - (with-time-logging - (simple-format #f "reading ~A missing derivations" - (length missing-derivation-filenames-chunk)) - (map read-derivation-from-file - ;; Do the filter again, since processing the last - ;; chunk might have inserted some of the - ;; derivations in this chunk - (filter (lambda (derivation-file-name) - (not (hash-ref derivation-ids-hash-table - derivation-file-name))) - missing-derivation-filenames-chunk))))) - - (unless (null? missing-derivations-chunk) - (insert-missing-derivations conn - derivation-ids-hash-table - missing-derivations-chunk)))) - 1000 - missing-derivation-filenames) - - (let ((all-ids - (vector-map - (lambda (_ derivation-file-name) - (if derivation-file-name - (or (hash-ref derivation-ids-hash-table - derivation-file-name) - (error "missing derivation id")) - #f)) - derivation-file-names))) - - (with-time-logging "insert-source-files-missing-nars" - (insert-source-files-missing-nars - ;; TODO Avoid this conversion - (vector-fold - (lambda (_ result x) - (if x - (cons x result) - result)) - '() - all-ids))) - - all-ids))))) + (map (lambda (row) + (list (string->number (first row)) + (second row))) + (exec-query conn query))) + + (let ((seen-ids (make-hash-table))) + (let loop ((next-related-derivation-ids + (derivation-ids->next-related-derivation-ids! + (list-copy derivation-ids) + seen-ids))) + (unless (null? next-related-derivation-ids) + (let ((missing-sources + (append-map! derivation-ids->missing-sources + (chunk next-related-derivation-ids + 10000)))) + + (unless (null? missing-sources) + (with-time-logging + (simple-format #f "inserting ~A missing source files" + (length missing-sources)) + (for-each (match-lambda + ((derivation-source-file-id store-path) + (insert-derivation-source-file-nar + conn + derivation-source-file-id + store-path))) + missing-sources)))) + + (loop + (derivation-ids->next-related-derivation-ids! + next-related-derivation-ids + seen-ids)))))) (define (update-derivation-inputs-statistics conn) (let ((query diff --git a/guix-data-service/model/git-branch.scm b/guix-data-service/model/git-branch.scm index a800e8f..c4b56c0 100644 --- a/guix-data-service/model/git-branch.scm +++ b/guix-data-service/model/git-branch.scm @@ -47,16 +47,12 @@ WHERE git_repository_id = $1 (define (insert-git-branch-entry conn git-repository-id name) - (match (exec-query - conn - " -INSERT INTO git_branches (git_repository_id, name) -VALUES ($1, $2) -RETURNING id" - (list (number->string git-repository-id) - name)) - (((id)) - (string->number id)))) + (insert-and-return-id + conn + "git_branches" + '(git_repository_id name) + (list git-repository-id + name))) (define (git-branches-for-commit conn commit) (define query diff --git a/guix-data-service/model/git-commit.scm b/guix-data-service/model/git-commit.scm index 0e8f773..e8b00ff 100644 --- a/guix-data-service/model/git-commit.scm +++ b/guix-data-service/model/git-commit.scm @@ -43,5 +43,5 @@ ON CONFLICT DO NOTHING" conn "SELECT 1 FROM git_commits WHERE commit = $1" (list commit)) - (#f #f) + (() #f) (_ #t))) diff --git a/guix-data-service/model/git-repository.scm b/guix-data-service/model/git-repository.scm index 5c605f8..b5f9fbe 100644 --- a/guix-data-service/model/git-repository.scm +++ b/guix-data-service/model/git-repository.scm @@ -20,9 +20,11 @@ #:use-module (ice-9 match) #:use-module (json) #:use-module (squee) + #:use-module (guix-data-service database) #:use-module (guix-data-service model utils) #:export (all-git-repositories select-git-repository + specify-git-repositories git-repository-query-substitutes? git-repository-id->url select-includes-and-excluded-branches-for-git-repository @@ -68,6 +70,46 @@ WHERE id = $1" (string=? fetch_with_authentication "t") (and=> poll-interval string->number))))) +(define (specify-git-repositories repositories) + (with-postgresql-connection + "specify-git-repositories" + (lambda (conn) + (with-postgresql-transaction + conn + (lambda (conn) + (let* ((existing-ids + (map first (all-git-repositories conn))) + (target-ids + (map (lambda (repo) + (or (assq-ref repo 'id) + (error "repository missing id"))) + repositories)) + (repositories-to-delete + (lset-difference equal? + existing-ids + target-ids))) + (for-each + (lambda (id-to-remove) + (simple-format (current-error-port) + "deleting repository ~A\n" + id-to-remove) + (exec-query + conn + "DELETE FROM git_repositories WHERE id = $1" + (list (number->string id-to-remove)))) + repositories-to-delete) + + (for-each + (lambda (repo) + (let ((fields (map car repo)) + (field-vals (map cdr repo))) + (update-or-insert + conn + "git_repositories" + fields + field-vals))) + repositories))))))) + (define (git-repository-query-substitutes? conn id) (match (exec-query conn @@ -97,7 +139,7 @@ WHERE id = $1" item)) lst)) - (match (exec-query + (match (exec-query-with-null-handling conn " SELECT included_branches, excluded_branches @@ -105,13 +147,11 @@ FROM git_repositories WHERE id = $1" (list (number->string id))) (((included_branches excluded_branches)) (values - (if (or (eq? #f included_branches) - (string-null? included_branches)) - '() + (if (NULL? included_branches) + included_branches (make-regexes (parse-postgresql-array-string included_branches))) - (if (or (eq? excluded_branches #f) - (string-null? excluded_branches)) + (if (NULL? excluded_branches) '() (make-regexes (parse-postgresql-array-string excluded_branches))))))) diff --git a/guix-data-service/model/guix-revision-package-derivation.scm b/guix-data-service/model/guix-revision-package-derivation.scm index 63c23e5..6a1f7c4 100644 --- a/guix-data-service/model/guix-revision-package-derivation.scm +++ b/guix-data-service/model/guix-revision-package-derivation.scm @@ -20,6 +20,8 @@ #:use-module (ice-9 threads) #:use-module (squee) #:use-module (guix-data-service database) + #:use-module (guix-data-service utils) + #:use-module (guix-data-service model system) #:export (insert-guix-revision-package-derivations insert-guix-revision-package-derivation-distribution-counts @@ -46,17 +48,9 @@ (define (insert-guix-revision-package-derivation-distribution-counts conn - guix-revision-id) - (define system-ids-and-targets - (exec-query - conn - " -SELECT DISTINCT system_id, target -FROM package_derivations -INNER JOIN guix_revision_package_derivations - ON package_derivations.id = guix_revision_package_derivations.package_derivation_id -WHERE revision_id = $1" - (list guix-revision-id))) + guix-revision-id + system-id + target) (define (get-count-for-next-level system-id target level-counts) (define next-level @@ -154,17 +148,12 @@ VALUES ($1, $2, $3, $4, $5)" (number->string level) (number->string count)))) - (for-each - (match-lambda - ((system-id target) - - (let loop ((level-counts '())) - (let ((level (length level-counts)) - (count (get-count-for-next-level system-id target level-counts))) - (unless (= count 0) - (insert-level-count system-id target level count) - (loop (append level-counts (list count)))))))) - system-ids-and-targets)) + (let loop ((level-counts '())) + (let ((level (length level-counts)) + (count (get-count-for-next-level system-id target level-counts))) + (unless (= count 0) + (insert-level-count system-id target level count) + (loop (append level-counts (list count))))))) (define (backfill-guix-revision-package-derivation-distribution-counts conn) (define revision-ids @@ -182,13 +171,40 @@ ORDER BY id DESC"))) (for-each (lambda (revision-id) - (simple-format #t "backfilling guix_revision_package_derivation_distribution_counts for revision ~A\n" revision-id) - (with-postgresql-transaction - conn - (lambda (conn) - (insert-guix-revision-package-derivation-distribution-counts - conn - revision-id)))) + (with-exception-handler + (lambda (exn) + (simple-format + #t "exception backfilling guix_revision_package_derivation_distribution_counts for revision ~A: ~A\n" + revision-id exn)) + (lambda () + (with-time-logging + (simple-format + #f "backfilling guix_revision_package_derivation_distribution_counts for revision ~A" + revision-id) + (let ((system-ids-and-targets + (exec-query + conn + " +SELECT DISTINCT system_id, target +FROM package_derivations +INNER JOIN guix_revision_package_derivations + ON package_derivations.id = guix_revision_package_derivations.package_derivation_id +WHERE revision_id = $1" + (list revision-id)))) + + (with-postgresql-transaction + conn + (lambda (conn) + (for-each + (match-lambda + ((system-id target) + (insert-guix-revision-package-derivation-distribution-counts + conn + revision-id + system-id + target))) + system-ids-and-targets)))))) + #:unwind? #t)) revision-ids)) (define* (get-sql-to-select-package-and-related-derivations-for-revision diff --git a/guix-data-service/model/guix-revision.scm b/guix-data-service/model/guix-revision.scm index 8bb20da..21e20a5 100644 --- a/guix-data-service/model/guix-revision.scm +++ b/guix-data-service/model/guix-revision.scm @@ -56,8 +56,7 @@ FROM guix_revisions WHERE commit = $1 AND git_repository_id = $2" (list commit git-repository-id)) - (((id)) - id) + (((id)) (string->number id)) (() #f))) (define (insert-guix-revision conn git-repository-id commit) @@ -67,7 +66,7 @@ INSERT INTO guix_revisions (git_repository_id, commit) VALUES ($1, $2) RETURNING id") (match (exec-query conn insert (list git-repository-id commit)) - (((id)) id))) + (((id)) (string->number id)))) (define (guix-commit-exists? conn commit) (define query diff --git a/guix-data-service/model/license-set.scm b/guix-data-service/model/license-set.scm index cff68b7..fe4272b 100644 --- a/guix-data-service/model/license-set.scm +++ b/guix-data-service/model/license-set.scm @@ -17,6 +17,7 @@ (define-module (guix-data-service model license-set) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) #:use-module (ice-9 vlist) #:use-module (squee) #:use-module (guix-data-service utils) @@ -24,78 +25,12 @@ #:use-module (guix-data-service model license) #:export (inferior-packages->license-set-ids)) -(define select-license-sets - " -SELECT id, license_ids -FROM license_sets") - -(define (insert-license-sets license-id-lists) - (string-append - "INSERT INTO license_sets (license_ids) VALUES " - (string-join - (map (lambda (license-ids) - (string-append - "('{" - (string-join - (map number->string - (sort license-ids <)) - ", ") - "}')")) - license-id-lists) - ", ") - " RETURNING id")) - (define (inferior-packages->license-set-ids conn license-id-lists) - (let* ((existing-license-sets - (exec-query->vhash conn - select-license-sets - (lambda (results) - (if (string=? (second results) "{}") - '() - (map - string->number - (string-split - (string-drop-right - (string-drop (second results) 1) - 1) - #\,)))) - (lambda (result) - (string->number (first result))))) ;; id - (missing-license-sets - (delete-duplicates/sort! - ;; Use filter! with list-copy, as filter may return a list that - ;; shares a portion of the input list, and therefore could be at - ;; risk of being modified when deleting duplicates - (filter! (lambda (license-set-license-ids) - (not (vhash-assoc license-set-license-ids - existing-license-sets))) - (list-copy license-id-lists)) - (lambda (full-a full-b) - (let loop ((a full-a) - (b full-b)) - (cond - ((null? a) #f) - ((null? b) #t) - (else - (< (car a) (car b)))))))) - (new-license-set-entries - (if (null? missing-license-sets) - '() - (map (lambda (result) - (string->number (first result))) - (exec-query conn - (insert-license-sets missing-license-sets))))) - (new-entries-id-lookup-vhash - (two-lists->vhash missing-license-sets - new-license-set-entries))) - - (map (lambda (license-id-list) - (cdr - (or (vhash-assoc license-id-list - existing-license-sets) - (vhash-assoc license-id-list - new-entries-id-lookup-vhash) - (begin - (error "missing license set entry" - license-id-list))))) - license-id-lists))) + (insert-missing-data-and-return-all-ids + conn + "license_sets" + '(license_ids) + (vector-map + (lambda (_ license-ids) + (list (sort license-ids <))) + license-id-lists))) diff --git a/guix-data-service/model/license.scm b/guix-data-service/model/license.scm index ebca0eb..f16634d 100644 --- a/guix-data-service/model/license.scm +++ b/guix-data-service/model/license.scm @@ -17,10 +17,12 @@ (define-module (guix-data-service model license) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (squee) #:use-module (guix inferior) + #:use-module (guix-data-service database) #:use-module (guix-data-service model utils) #:export (inferior-packages->license-id-lists inferior-packages->license-data)) @@ -49,7 +51,7 @@ (current-error-port) "error: unknown license value ~A for package ~A" x package) - '())) + #f)) values)) (x (simple-format @@ -69,17 +71,21 @@ ;; save non string values as NULL NULL)) - (insert-missing-data-and-return-all-ids - conn - "licenses" - `(name uri comment) - (map (lambda (license-tuples) - (map - (match-lambda - ((name uri comment) - (list name - (string-or-null uri) - (string-or-null comment)))) - license-tuples)) - license-data) - #:sets-of-data? #t)) + (vector-map + (lambda (_ license-tuples) + (if (null? license-tuples) + #() + (insert-missing-data-and-return-all-ids + conn + "licenses" + `(name uri comment) + (list->vector + (filter-map + (match-lambda + ((name uri comment) + (list name + (string-or-null uri) + (string-or-null comment))) + (#f #f)) + license-tuples))))) + license-data)) diff --git a/guix-data-service/model/lint-checker.scm b/guix-data-service/model/lint-checker.scm index be3cfc6..4ee6521 100644 --- a/guix-data-service/model/lint-checker.scm +++ b/guix-data-service/model/lint-checker.scm @@ -17,6 +17,7 @@ (define-module (guix-data-service model lint-checker) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:use-module (squee) #:use-module (guix-data-service model utils) @@ -24,8 +25,7 @@ lint-warning-count-by-lint-checker-for-revision insert-guix-revision-lint-checkers lint-checkers-for-revision - lint-checker-description-data->lint-checker-description-set-id - insert-lint-checker-description-set)) + lint-checker-description-data->lint-checker-description-set-id)) (define (lint-checkers->lint-checker-ids conn lint-checkers-data) (insert-missing-data-and-return-all-ids @@ -40,48 +40,23 @@ conn "lint_checker_descriptions" '(locale description) - (map (match-lambda - ((locale . description) - (list locale description))) - descriptions-by-locale))) - -(define (insert-lint-checker-description-set conn lint-description-ids) - (let ((query - (string-append - "INSERT INTO lint_checker_description_sets (description_ids) VALUES " - (string-append - "('{" - (string-join - (map number->string - (sort lint-description-ids <)) - ", ") - "}')") - " RETURNING id"))) - (match (exec-query conn query) - (((id)) id)))) + (list->vector + (map (match-lambda + ((locale . description) + (list locale description))) + descriptions-by-locale)))) (define (lint-checker-description-data->lint-checker-description-set-id conn descriptions-by-locale) - (let* ((lint-checker-description-ids - (lint-checker-description-data->lint-checker-description-ids - conn - descriptions-by-locale)) - (lint-checker-description-set-id - (exec-query - conn - (string-append - "SELECT id FROM lint_checker_description_sets" - " WHERE description_ids = ARRAY[" - (string-join (map number->string - (sort lint-checker-description-ids <)) ", ") - "]")))) - (string->number - (match lint-checker-description-set-id - (((id)) id) - (() - (insert-lint-checker-description-set conn lint-checker-description-ids)))))) - + (insert-and-return-id + conn + "lint_checker_description_sets" + '(description_ids) + (list + (lint-checker-description-data->lint-checker-description-ids + conn + descriptions-by-locale)))) (define (lint-warning-count-by-lint-checker-for-revision conn commit-hash) (define query @@ -125,7 +100,7 @@ ORDER BY count DESC") "(~A, ~A)" lint-checker-id guix-revision-id)) - lint-checker-ids) + (vector->list lint-checker-ids)) ", ")))) (define (lint-checkers-for-revision conn commit-hash) diff --git a/guix-data-service/model/lint-warning-message.scm b/guix-data-service/model/lint-warning-message.scm index 72a8617..c44ba8a 100644 --- a/guix-data-service/model/lint-warning-message.scm +++ b/guix-data-service/model/lint-warning-message.scm @@ -16,6 +16,7 @@ ;;; <http://www.gnu.org/licenses/>. (define-module (guix-data-service model lint-warning-message) + #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:use-module (squee) #:use-module (guix-data-service database) @@ -30,49 +31,24 @@ conn "lint_warning_messages" '(locale message) - (map (match-lambda - ((locale . message) - (list locale message))) - messages-by-locale))) - -(define (insert-lint-warning-message-set conn lint-message-ids) - (let ((query - (string-append - "INSERT INTO lint_warning_message_sets (message_ids) VALUES " - (string-append - "('{" - (string-join - (map number->string - (sort lint-message-ids <)) - ", ") - "}')") - " RETURNING id"))) - - (match (exec-query conn query) - (((id)) id)))) + (let ((v (list->vector messages-by-locale))) + (vector-map! (lambda (_ data) + (match data + ((locale . message) + (list locale message)))) + v) + v))) (define (lint-warning-message-data->lint-warning-message-set-id conn messages-by-locale) - - (let* ((lint-warning-message-ids - (lint-warning-message-data->lint-warning-message-ids - conn messages-by-locale)) - (lint-message-set-id - (exec-query - conn - (string-append - "SELECT id FROM lint_warning_message_sets " - "WHERE message_ids = ARRAY[" - (string-join (map number->string - (sort lint-warning-message-ids <)) ", ") - "]")))) - - (string->number - (match lint-message-set-id - (((id)) id) - (() - (insert-lint-warning-message-set conn lint-warning-message-ids)))))) + (insert-and-return-id + conn + "lint_warning_message_sets" + '(message_ids) + (list (lint-warning-message-data->lint-warning-message-ids + conn + messages-by-locale)))) (define (lint-warning-message-locales-for-revision conn commit-hash) (exec-query diff --git a/guix-data-service/model/lint-warning.scm b/guix-data-service/model/lint-warning.scm index eff332f..69241f3 100644 --- a/guix-data-service/model/lint-warning.scm +++ b/guix-data-service/model/lint-warning.scm @@ -40,22 +40,22 @@ (define (insert-guix-revision-lint-warnings conn guix-revision-id lint-warning-ids) - (if (null? lint-warning-ids) - '() - (exec-query - conn - (string-append - "INSERT INTO guix_revision_lint_warnings (lint_warning_id, guix_revision_id) " - "VALUES " - (string-join - (map (lambda (lint-warning-id) - (simple-format - #f - "(~A, ~A)" - lint-warning-id - guix-revision-id)) - lint-warning-ids) - ", "))))) + (unless (= 0 (vector-length lint-warning-ids)) + (exec-query + conn + (string-append + "INSERT INTO guix_revision_lint_warnings (lint_warning_id, guix_revision_id) " + "VALUES " + (string-join + (map (lambda (lint-warning-id) + (simple-format + #f + "(~A, ~A)" + lint-warning-id + guix-revision-id)) + (vector->list lint-warning-ids)) + ", ") + " ON CONFLICT DO NOTHING")))) (define* (lint-warnings-for-guix-revision conn commit-hash #:key diff --git a/guix-data-service/model/location.scm b/guix-data-service/model/location.scm index 6e010da..123354f 100644 --- a/guix-data-service/model/location.scm +++ b/guix-data-service/model/location.scm @@ -19,35 +19,14 @@ #:use-module (ice-9 match) #:use-module (guix utils) #:use-module (squee) + #:use-module (guix-data-service model utils) #:export (location->location-id)) -(define select-existing-location - (string-append - "SELECT id " - "FROM locations " - "WHERE file = $1 AND line = $2 AND column_number = $3")) - -(define insert-location - (string-append - "INSERT INTO locations " - "(file, line, column_number) VALUES " - "($1, $2, $3) " - "RETURNING id")) - (define (location->location-id conn location) - (match location - (($ <location> file line column) - (string->number - (match (exec-query conn - select-existing-location - (list file - (number->string line) - (number->string column))) - (((id)) id) - (() - (caar - (exec-query conn - insert-location - (list file - (number->string line) - (number->string column)))))))))) + (insert-and-return-id + conn + "locations" + '(file line column_number) + (match location + (($ <location> file line column) + (list file line column))))) diff --git a/guix-data-service/model/nar.scm b/guix-data-service/model/nar.scm index 0e3b3e6..c66e6d2 100644 --- a/guix-data-service/model/nar.scm +++ b/guix-data-service/model/nar.scm @@ -57,11 +57,12 @@ narinfos)) (let ((nar-ids - (insert-missing-data-and-return-all-ids - conn - "nars" - '(store_path hash_algorithm hash size system deriver) - data))) + (vector->list + (insert-missing-data-and-return-all-ids + conn + "nars" + '(store_path hash_algorithm hash size system deriver) + (list->vector data))))) (let ((reference-data (concatenate @@ -176,49 +177,45 @@ VALUES ($1, $2)") #\;) ((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)))))))))))) + (insert-and-return-id + 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) + (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 + (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 + (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 @@ -232,13 +229,11 @@ VALUES ($1, $2)") (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))))))) + (insert-and-return-id + conn + "narinfo_signature_public_keys" + '(sexp_json) + (list public-key-json-string)))) (define (select-package-output-availability-for-revision conn revision-commit) (define query @@ -380,7 +375,7 @@ ORDER BY COUNT(*) DESC") (match status ("t" 'matching) ("f" 'not-matching) - (() 'unknown)) + ((? NULL? x) 'unknown)) (string->number count)))) (exec-query-with-null-handling conn query (list revision-commit))))) diff --git a/guix-data-service/model/package-derivation-by-guix-revision-range.scm b/guix-data-service/model/package-derivation-by-guix-revision-range.scm index 9ce527e..cc9f864 100644 --- a/guix-data-service/model/package-derivation-by-guix-revision-range.scm +++ b/guix-data-service/model/package-derivation-by-guix-revision-range.scm @@ -48,7 +48,7 @@ WHERE git_branch_id = $1 AND WHERE revision_id = $2 )" (list (number->string git-branch-id) - guix-revision-id))))) + (number->string guix-revision-id)))))) (define (insert-guix-revision-package-derivation-entries conn git-repository-id @@ -185,7 +185,7 @@ PARTITION OF package_derivations_by_guix_revision_range FOR VALUES IN (" query (list git-repository-id (number->string git-branch-id) - guix-revision-id)))) + (number->string guix-revision-id))))) (define (update-package-derivations-table conn git-repository-id diff --git a/guix-data-service/model/package-derivation.scm b/guix-data-service/model/package-derivation.scm index 2008409..fc7dca7 100644 --- a/guix-data-service/model/package-derivation.scm +++ b/guix-data-service/model/package-derivation.scm @@ -49,12 +49,13 @@ derivation-ids)) (if (null? data-4-tuples) - '() + #() (insert-missing-data-and-return-all-ids conn "package_derivations" '(package_id derivation_id system_id target) - data-4-tuples))) + (list->vector + data-4-tuples)))) (define (count-packages-derivations-in-revision conn commit-hash) (define query diff --git a/guix-data-service/model/package-metadata.scm b/guix-data-service/model/package-metadata.scm index 6eca089..f1ffdbf 100644 --- a/guix-data-service/model/package-metadata.scm +++ b/guix-data-service/model/package-metadata.scm @@ -18,6 +18,7 @@ (define-module (guix-data-service model package-metadata) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-43) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (squee) @@ -29,6 +30,7 @@ #:use-module (guix i18n) #:use-module (guix inferior) #:use-module (guix-data-service utils) + #:use-module (guix-data-service database) #:use-module (guix-data-service model location) #:use-module (guix-data-service model utils) #:export (select-package-metadata-by-revision-name-and-version @@ -204,27 +206,6 @@ WHERE packages.id IN ( (json-string->scm license-json))))) (exec-query conn query (list revision-commit-hash name version locale)))) -(define (insert-package-metadata metadata-rows) - (string-append "INSERT INTO package_metadata " - "(synopsis, description, home_page, location_id, license_set_id) " - "VALUES " - (string-join - (map (match-lambda - ((synopsis description home_page - location-id license-set-id) - (string-append - "(" - (value->quoted-string-or-null synopsis) "," - (value->quoted-string-or-null description) "," - (value->quoted-string-or-null home_page) "," - location-id "," - license-set-id - ")"))) - metadata-rows) - ",") - " RETURNING id" - ";")) - (define (inferior-packages->translated-package-descriptions-and-synopsis inferior inferior-package) @@ -292,73 +273,17 @@ WHERE packages.id IN ( (prevent-inlining-for-tests inferior-packages->translated-package-descriptions-and-synopsis) -(define (insert-package-synopsis-set conn package-synopsis-ids) - (let ((query - (string-append - "INSERT INTO package_synopsis_sets (synopsis_ids) VALUES " - (string-append - "('{" - (string-join - (map number->string - (sort package-synopsis-ids <)) - ", ") - "}')") - " RETURNING id"))) - (match (exec-query conn query) - (((id)) id)))) - -(define (package-synopsis-data->package-synopsis-set-id - conn package-synopsis-ids) - (let ((package-synopsis-set-id - (exec-query - conn - (string-append - "SELECT id FROM package_synopsis_sets" - " WHERE synopsis_ids = ARRAY[" - (string-join (map number->string - (sort package-synopsis-ids <)) ", ") - "]")))) - (string->number - (match package-synopsis-set-id - (((id)) id) - (() - (insert-package-synopsis-set conn package-synopsis-ids)))))) - -(define (insert-package-description-set conn package-description-ids) - (let ((query - (string-append - "INSERT INTO package_description_sets (description_ids) VALUES " - (string-append - "('{" - (string-join - (map number->string - (sort package-description-ids <)) - ", ") - "}')") - " RETURNING id"))) - (match (exec-query conn query) - (((id)) id)))) - -(define (package-description-data->package-description-set-id - conn package-description-ids) - (let* ((package-description-set-id - (exec-query - conn - (string-append - "SELECT id FROM package_description_sets" - " WHERE description_ids = ARRAY[" - (string-join (map number->string - (sort package-description-ids <)) ", ") - "]")))) - (string->number - (match package-description-set-id - (((id)) id) - (() - (insert-package-description-set conn package-description-ids)))))) - (define (inferior-packages->package-metadata-ids conn package-metadata license-set-ids) + (define (vector-zip . vecs) + (let ((result (make-vector (vector-length (first vecs))))) + (apply vector-map! + (lambda (i . vals) + (cdr vals)) + (cons result vecs)) + result)) + (insert-missing-data-and-return-all-ids conn "package_metadata" @@ -368,105 +293,82 @@ WHERE packages.id IN ( package_description_set_id package_synopsis_set_id) - (zip - (map (match-lambda - ((home-page rest ...) - (if (string? home-page) - home-page - NULL))) - package-metadata) + (vector-zip + (vector-map (match-lambda* + ((_ (home-page rest ...)) + (if (string? home-page) + home-page + NULL))) + package-metadata) (with-time-logging "preparing location ids" - (map (match-lambda - ((_ location rest ...) - (if location - (location->location-id - conn - location) - NULL))) - package-metadata)) + (vector-map (match-lambda* + ((_ (_ location rest ...)) + (if location + (location->location-id + conn + location) + NULL))) + package-metadata)) license-set-ids (with-time-logging "preparing package description set ids" - (map (lambda (package-description-ids) - (package-description-data->package-description-set-id - conn - package-description-ids)) - (with-time-logging "preparing package description ids" - (insert-missing-data-and-return-all-ids - conn - "package_descriptions" - '(locale description) - (map (match-lambda - ((_ _ package-description-data _) - (map (match-lambda - ((locale . description) - (list locale description))) - package-description-data))) - package-metadata) - #:delete-duplicates? #t - #:sets-of-data? #t)))) + (vector-map (match-lambda* + ((_ (_ _ package-description-data _)) + (let ((package-description-ids + (insert-missing-data-and-return-all-ids + conn + "package_descriptions" + '(locale description) + (let ((vec (list->vector package-description-data))) + (vector-map! + (match-lambda* + ((_ (locale . description)) + (list locale + ;; \u0000 has appeared in package + ;; descriptions (#71968), so strip it + ;; out here to avoid PostgreSQL throwing + ;; an error + (string-delete-null description)))) + vec) + vec)))) + (insert-and-return-id + conn + "package_description_sets" + '(description_ids) + (list (sort! package-description-ids <)))))) + package-metadata)) (with-time-logging "preparing package synopsis set ids" - (map (lambda (package-synopsis-ids) - (package-synopsis-data->package-synopsis-set-id - conn - package-synopsis-ids)) - (insert-missing-data-and-return-all-ids - conn - "package_synopsis" - '(locale synopsis) - (map (match-lambda - ((_ _ _ package-synopsis-data) - (map (match-lambda - ((locale . synopsis) - (list locale synopsis))) - package-synopsis-data))) - package-metadata) - #:delete-duplicates? #t - #:sets-of-data? #t)))) - ;; There can be duplicated entires in package-metadata, for example where - ;; you have one package definition which interits from another, and just - ;; overrides the version and the source, the package_metadata entries for - ;; both definitions will be the same. - #:delete-duplicates? #t - ;; There is so much package metadata that it's worth creating a temporary - ;; table - #:use-temporary-table? #t)) + (vector-map (match-lambda* + ((_ (_ _ _ package-synopsis-data)) + (let ((package-synopsis-ids + (insert-missing-data-and-return-all-ids + conn + "package_synopsis" + '(locale synopsis) + (let ((vec + (list->vector package-synopsis-data))) + (vector-map! + (match-lambda* + ((_ (locale . synopsis)) + (list locale synopsis))) + vec) + vec)))) + (insert-and-return-id + conn + "package_synopsis_sets" + '(synopsis_ids) + (list (sort! package-synopsis-ids <)))))) + package-metadata))))) (define (package-description-and-synopsis-locale-options-guix-revision conn revision-id) + ;; TODO This no longer uses the revision-id, as that's too expensive. Maybe + ;; some caching is needed. (exec-query conn " -WITH package_metadata_ids AS ( - SELECT packages.package_metadata_id AS id - FROM packages - WHERE packages.id IN ( - SELECT package_derivations.package_id - FROM package_derivations - INNER JOIN guix_revision_package_derivations - ON package_derivations.id = guix_revision_package_derivations.package_derivation_id - WHERE guix_revision_package_derivations.revision_id = $1 - ) -), synopsis_locales AS ( - SELECT package_synopsis.locale - FROM package_metadata - INNER JOIN package_synopsis_sets - ON package_synopsis_sets.id = package_metadata.package_synopsis_set_id - INNER JOIN package_synopsis - ON package_synopsis.id = ANY (package_synopsis_sets.synopsis_ids) - WHERE package_metadata.id IN (SELECT id FROM package_metadata_ids) -), description_locales AS ( - SELECT package_descriptions.locale - FROM package_metadata - INNER JOIN package_description_sets - ON package_description_sets.id = package_metadata.package_description_set_id - INNER JOIN package_descriptions - ON package_descriptions.id = ANY (package_description_sets.description_ids) - WHERE package_metadata.id IN (SELECT id FROM package_metadata_ids) -) -SELECT locale FROM synopsis_locales +SELECT locale FROM package_synopsis UNION -SELECT locale FROM description_locales" - (list revision-id))) +SELECT locale FROM package_descriptions")) (define (synopsis-counts-by-locale conn revision-id) (define synopsis-counts @@ -576,8 +478,8 @@ INNER JOIN ( OR translated_package_descriptions.locale = 'en_US.UTF-8') WHERE package_metadata.id IN (" (string-join - (map number->string - package-metadata-ids) ", ") ")" + (map number->string (vector->list package-metadata-ids)) + ", ") ")" " ORDER BY package_metadata.id, locale, CASE WHEN translated_package_synopsis.locale = diff --git a/guix-data-service/model/package.scm b/guix-data-service/model/package.scm index 8d62ef3..395cbd4 100644 --- a/guix-data-service/model/package.scm +++ b/guix-data-service/model/package.scm @@ -250,23 +250,6 @@ WHERE packages.id IN ( (exec-query conn query (list commit-hash))) -(define (insert-into-package-entries package-entries) - (string-append - " -INSERT INTO packages (name, version, package_metadata_id) VALUES " - (string-join - (map - (match-lambda - ((name version package_metadata_id) - (simple-format #f "('~A', '~A', ~A)" - name - version - package_metadata_id))) - package-entries) - ",") - " -RETURNING id")) - (define (inferior-packages->package-ids conn package-entries) (insert-missing-data-and-return-all-ids conn diff --git a/guix-data-service/model/system-test.scm b/guix-data-service/model/system-test.scm index fe2fb83..ab438b7 100644 --- a/guix-data-service/model/system-test.scm +++ b/guix-data-service/model/system-test.scm @@ -23,7 +23,6 @@ #:use-module (guix utils) #:use-module (guix-data-service model utils) #:use-module (guix-data-service model location) - #:use-module (guix-data-service model derivation) #:export (insert-system-tests-for-guix-revision select-system-tests-for-guix-revision @@ -39,7 +38,7 @@ "system_tests" '(name description location_id) (map (match-lambda - ((name description derivation-file-names-by-system location-data) + ((name description derivation-ids-by-system location-data) (list name description (location->location-id @@ -48,20 +47,13 @@ system-test-data))) (data (append-map - (lambda (system-test-id derivation-file-names-by-system) - (let ((systems - (map car derivation-file-names-by-system)) - (derivation-ids - (derivation-file-names->derivation-ids - conn - (map cdr derivation-file-names-by-system)))) - (map (lambda (system derivation-id) - (list guix-revision-id - system-test-id - derivation-id - system)) - systems - derivation-ids))) + (lambda (system-test-id derivation-ids-by-system) + (map (lambda (system-and-derivation-id) + (list guix-revision-id + system-test-id + (cdr system-and-derivation-id) + (car system-and-derivation-id))) + derivation-ids-by-system)) system-test-ids (map third system-test-data)))) diff --git a/guix-data-service/model/system.scm b/guix-data-service/model/system.scm index e64e7f5..d6efa46 100644 --- a/guix-data-service/model/system.scm +++ b/guix-data-service/model/system.scm @@ -22,6 +22,7 @@ #:use-module (squee) #:use-module (guix-data-service model utils) #:export (system->system-id + lookup-system-id list-systems)) (define system->system-id-cache @@ -33,17 +34,32 @@ (let ((cached-value (hash-ref system->system-id-cache system))) (or cached-value - (match (insert-missing-data-and-return-all-ids + (let ((id (insert-and-return-id + conn + "systems" + '(system) + (list system)))) + (hash-set! system->system-id-cache + system + id) + (set! systems-cache #f) + id)))) + +(define (lookup-system-id conn system) + (let ((cached-value (hash-ref system->system-id-cache + system))) + (or cached-value + (match (exec-query conn - "systems" - '(system) - `((,system))) - ((id) - (hash-set! system->system-id-cache - system - id) - (set! systems-cache #f) - id))))) + "SELECT id FROM systems WHERE system = $1" + (list system)) + (((id-string)) + (let ((id (string->number id-string))) + (hash-set! system->system-id-cache + system + id) + id)) + (() #f))))) (define (list-systems conn) (if systems-cache diff --git a/guix-data-service/model/utils.scm b/guix-data-service/model/utils.scm index c05f20d..707c697 100644 --- a/guix-data-service/model/utils.scm +++ b/guix-data-service/model/utils.scm @@ -17,26 +17,34 @@ (define-module (guix-data-service model utils) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 receive) #:use-module (squee) #:use-module (guix-data-service database) #:use-module (guix-data-service utils) - #:export (NULL + #:export (string-delete-null quote-string value->quoted-string-or-null non-empty-string-or-false - exec-query->vhash - two-lists->vhash parse-postgresql-array-string deduplicate-strings group-list-by-first-n-fields group-to-alist group-to-alist/vector - insert-missing-data-and-return-all-ids)) + insert-missing-data-and-return-all-ids + insert-missing-data + update-or-insert + bulk-select + insert-and-return-id + prepare-insert-and-return-id)) -(define NULL '()) +(define (char-null? c) + (char=? c #\null)) + +(define (string-delete-null s) + (string-delete char-null? s)) (define (quote-string s) (string-append "$STR$" s "$STR$")) @@ -44,7 +52,7 @@ (define (value->quoted-string-or-null value) (if (string? value) (string-append "$STR$" value "$STR$") - "NULL")) + NULL)) (define (non-empty-string-or-false s) (if (string? s) @@ -53,22 +61,6 @@ s) #f)) -(define* (exec-query->vhash conn query field-function value-function - #:key (vhash vlist-null)) - (fold (lambda (row result) - (vhash-cons (field-function row) - (value-function row) - result)) - vhash - (exec-query-with-null-handling conn query))) - -(define (two-lists->vhash l1 l2) - (fold (lambda (key value result) - (vhash-cons key value result)) - vlist-null - l1 - l2)) - (define (parse-postgresql-array-string s) (if (string=? s "{}") '() @@ -145,322 +137,504 @@ WHERE table_name = $1" (string=? is_nullable "YES")))) results)))) +(define %field-can-be-null-cache + (make-hash-table)) + +(define (field-can-be-null? conn table-name field) + (let ((cache-key (cons table-name field))) + (match (hash-get-handle %field-can-be-null-cache + cache-key) + ((_ . res) res) + (#f + (let ((schema-details + (table-schema conn table-name))) + (match (find (lambda (column-data) + (string=? field + (car column-data))) + schema-details) + ((column-name data-type is-nullable?) + (hash-set! %field-can-be-null-cache + cache-key + is-nullable?) + is-nullable?) + (#f + (simple-format + (current-error-port) + "error: couldn't find data for ~A in ~A\n" + field + schema-details) + (error "error: field-can-be-null?")))))))) + +(define value->sql + (match-lambda + ((? string? s) + (string-append "$STR$" s "$STR$")) + ((? NULL?) + "NULL") + ((? symbol? s) + (value->sql (symbol->string s))) + ((? number? n) + (number->string n)) + ((? boolean? b) + (if b "TRUE" "FALSE")) + ((? vector? v) + (string-append + "ARRAY[" (string-join (map value->sql (vector->list v)) ",") "]")) + ((cast . value) + (string-append + (value->sql value) "::" cast)) + (v + (error + (simple-format #f "error: unknown type for value: ~A" v))))) + +(define value->sql-literal + (match-lambda + ((? string? s) s) + ((? NULL?) + "NULL") + ((? symbol? s) (symbol->string s)) + ((? number? n) + (number->string n)) + ((? boolean? b) + (if b "t" "f")) + ((? vector? v) + (string-append + "{" (string-join (map value->sql-literal (vector->list v)) ",") "}")) + ((cast . value) + (string-append + (value->sql-literal value) "::" cast)) + (v + (error + (simple-format #f "error: unknown type for value: ~A" v))))) + +(define* (bulk-select conn + table-name + fields + data + #:key (id-proc string->number)) + (define field-strings + (map symbol->string fields)) + + (define query + (string-append + " +SELECT vals.bulk_select_index, id +FROM " table-name " +JOIN (VALUES " +(string-join + (if (vector? data) + (vector-fold + (lambda (index result field-values) + (cons + (string-append + "(" + (number->string index) ", " + (string-join (map value->sql field-values) ",") + ")") + result)) + '() + data) + (map + (lambda (index field-values) + (string-append + "(" + (number->string index) ", " + (string-join (map value->sql field-values) ",") + ")")) + (iota (length data)) + data)) + ", ") +")\n AS vals (bulk_select_index, " (string-join field-strings ", ") ") " +"ON " +(string-join + (map (lambda (field) + (string-concatenate + `("(" + ,table-name "." ,field " = vals." ,field + ,@(if (field-can-be-null? conn table-name field) + `(" OR (" ,table-name "." ,field " IS NULL AND" + " vals." ,field " IS NULL" + ")") + '()) + ")"))) + field-strings) + " AND\n "))) + + (let ((result (make-vector (if (vector? data) + (vector-length data) + (length data)) + #f))) + (for-each + (match-lambda + ((index id) + (vector-set! result (string->number index) + (id-proc id)))) + (exec-query conn query)) + + result)) + +(define* (bulk-insert + conn + table-name + fields + data + #:key (id-proc string->number)) + (define field-strings + (map symbol->string fields)) + + (define query + (string-append + " +INSERT INTO " table-name " (" (string-join field-strings ", ") ") VALUES +" (string-join + (map (lambda (field-values) + (string-append + "(" + (string-join + (map (lambda (value) + (value->sql value)) + field-values) + ", ") + ")")) + data) + ", ") " +ON CONFLICT DO NOTHING +RETURNING id")) + + (if (null? data) + #() + (let* ((query-result (exec-query conn query)) + (expected-ids (length data)) + (returned-ids (length query-result))) + (if (= expected-ids returned-ids) + (let ((result + (make-vector returned-ids))) + (fold + (lambda (row index) + (match row + ((id) + (vector-set! result index + (id-proc id)))) + (1+ index)) + 0 + query-result) + result) + ;; Can't match up the ids to the data, so just query for them + (bulk-select conn + table-name + fields + data + #:id-proc id-proc))))) + +(define* (insert-missing-data + conn + table-name + fields + data) + (define field-strings + (map symbol->string fields)) + + (let* ((result + (bulk-select + conn + table-name + fields + data)) + (missing-data-indexes + (vector-fold + (lambda (i missing-data-indexes id-or-f) + (if id-or-f + missing-data-indexes + (cons i missing-data-indexes))) + '() + result))) + + (bulk-insert + conn + table-name + fields + (map (lambda (index) + (vector-ref data index)) + missing-data-indexes)) + + *unspecified*)) + (define* (insert-missing-data-and-return-all-ids conn table-name fields data - #:key - sets-of-data? - delete-duplicates? - use-temporary-table?) + #:key (id-proc string->number)) (define field-strings (map symbol->string fields)) - (define value->sql - (match-lambda - ((? string? s) - (string-append "$STR$" s "$STR$")) - ((? symbol? s) - (string-append "$STR$" - (symbol->string s) - "$STR$")) - ((? number? n) - (number->string n)) - ((? boolean? b) - (if b "TRUE" "FALSE")) - ((? null?) - "NULL") - ((cast . value) - (string-append - (value->sql value) "::" cast)) - (v - (error - (simple-format #f "error: unknown type for value: ~A" v))))) - - (define (delete-duplicates* data) - (delete-duplicates/sort! - (list-copy data) - (lambda (full-a full-b) - (let loop ((a full-a) - (b full-b)) - (if (null? a) - #f - (let ((a-val (match (car a) - ((_ . val) val) - ((? symbol? val) (symbol->string val)) - (val val))) - (b-val (match (car b) - ((_ . val) val) - ((? symbol? val) (symbol->string val)) - (val val)))) - (cond - ((null? a-val) - (if (null? b-val) - (loop (cdr a) (cdr b)) - #t)) - ((null? b-val) - #f) - (else - (match a-val - ((? string? v) - (if (string=? a-val b-val) - (loop (cdr a) (cdr b)) - (string<? a-val b-val))) - ((? number? v) - (if (= a-val b-val) - (loop (cdr a) (cdr b)) - (< a-val b-val))) - ((? boolean? v) - (if (eq? a-val b-val) - (loop (cdr a) (cdr b)) - a-val))))))))))) - - (define schema-details - (table-schema conn table-name)) - - (define (field-can-be-null? field) - (match (find (lambda (column-data) - (string=? field - (car column-data))) - schema-details) - ((column-name data-type is-nullable?) is-nullable?) - (#f - (simple-format - (current-error-port) - "error: couldn't find data for ~A in ~A\n" - field - schema-details) - (error "error: field-can-be-null?")))) - - (define (select-query data) + (let* ((result + (bulk-select + conn + table-name + fields + data + #:id-proc id-proc)) + (missing-data-indexes + (vector-fold + (lambda (i missing-data-indexes id-or-f) + (if id-or-f + missing-data-indexes + (cons i missing-data-indexes))) + '() + result)) + (new-ids + (bulk-insert + conn + table-name + fields + (map (lambda (index) + (vector-ref data index)) + missing-data-indexes) + #:id-proc id-proc))) + + (fold + (lambda (missing-data-index index) + (let ((new-id (vector-ref new-ids index))) + (vector-set! result missing-data-index new-id)) + (1+ index)) + 0 + missing-data-indexes) + + (values result new-ids))) + +(define* (update-or-insert conn + table-name + fields + field-vals + #:key (id-fields '(id))) + (define id-field-strings + (map symbol->string id-fields)) + + (define id-field-values + (map (lambda (id-field) + (any (lambda (field val) + (if (eq? field id-field) + (value->sql-literal val) + #f)) + fields + field-vals)) + id-fields)) + + (define field-strings + (map symbol->string fields)) + + (define select (string-append - "SELECT id,\n" - (string-join (map (lambda (field) - (string-append table-name "." field)) - field-strings) - ",\n") - " FROM " table-name - " JOIN (VALUES " - (string-join - (map - (lambda (field-values) - (string-append - "(" - (string-join (map value->sql field-values) ",") - ")")) - data) - ", ") - ")\n AS vals (" (string-join field-strings ", ") ") " - "ON " - (string-join - (map (lambda (field) - (string-concatenate - `("(" - ,table-name "." ,field " = vals." ,field - ,@(if (field-can-be-null? field) - `(" OR (" ,table-name "." ,field " IS NULL AND" - " vals." ,field " IS NULL" - ")") - '()) - ")"))) - field-strings) - " AND\n "))) - - (define (temp-table-select-query temp-table-name) + " +SELECT " (string-join field-strings ", ") " FROM " table-name " +WHERE " +(string-join + (filter-map + (lambda (i field) + (simple-format #f "(~A = $~A)" field i)) + (iota (length id-fields) 1) + id-field-strings) + " AND\n ") +";")) + + (define insert (string-append - "SELECT " table-name ".id, " - (string-join (map (lambda (field) - (string-append table-name "." field)) - field-strings) - ", ") - " FROM " table-name - " INNER JOIN " temp-table-name - " ON " - (string-join - (map (lambda (field) - (string-concatenate - `("(" - ,table-name "." ,field " = " ,temp-table-name "." ,field - ,@(if (field-can-be-null? field) - `(" OR (" - ,table-name "." ,field " IS NULL" - " AND " - ,temp-table-name "." ,field " IS NULL" - ")") - '()) - ")"))) - field-strings) - " AND "))) - - (define* (insert-sql missing-data - #:key - (table-name table-name)) + " +INSERT INTO " table-name " (" (string-join field-strings ", ") ") +VALUES (" (string-join + (map (lambda (i) + (simple-format #f "$~A" i)) + (iota (length fields) 1)) + ", ") ") +ON CONFLICT DO NOTHING +RETURNING " (string-join id-field-strings ", ") ";")) + + (define (update fields-to-update) + (define update-field-strings + (map symbol->string fields-to-update)) + (string-append - "INSERT INTO " table-name " (\n" - (string-join field-strings ",\n") - ") VALUES " - (string-join - (map (lambda (field-values) + " +UPDATE " table-name " +SET " (string-join + (map (lambda (field i) + (simple-format #f "~A = $~A" field i)) + update-field-strings + (iota (length update-field-strings) 1)) + ", ") " +WHERE " +(string-join + (filter-map + (lambda (i field) + (simple-format #f "(~A = $~A)" field i)) + (iota (length id-fields) (+ 1 (length fields-to-update))) + id-field-strings) + " AND\n "))) + + (let ((sql-field-values + (map value->sql-literal field-vals))) + (match (exec-query + conn + select + id-field-values) + ((db-field-values) + (let* ((normalised-field-values + (map value->sql-literal + db-field-values)) + (fields-to-update + (filter-map + (lambda (field db-val target-val) + ;; TODO This might incorrectly detect differences + (if (equal? db-val target-val) + #f + field)) + fields + normalised-field-values + sql-field-values)) + (update-field-values + (filter-map + (lambda (field val) + (if (memq field fields-to-update) + val + #f)) + fields + sql-field-values))) + (unless (null? fields-to-update) + (exec-query + conn + (update fields-to-update) + (append update-field-values + id-field-values))))) + (() + (exec-query + conn + insert + sql-field-values)))) + *unspecified*) + +(define* (insert-and-return-id conn + table-name + fields + field-vals + #:key (id-proc string->number)) + (define field-strings + (map symbol->string fields)) + + (define select + (string-append + " +SELECT id FROM " table-name " +WHERE " +(string-join + (map (lambda (i field) + (string-append + "(" field " = $" i + (if (field-can-be-null? conn table-name field) (string-append - "(" - (string-join - (map (lambda (value) - (value->sql value)) - field-values) - ", ") - ")")) - missing-data) - ", ") - " RETURNING id")) - - (define (format-json json) - ;; PostgreSQL formats JSON strings differently to guile-json, so use - ;; PostgreSQL to do the formatting - (caar - (exec-query - conn - (string-append - "SELECT $STR$" json "$STR$::jsonb")))) - - (define (normalise-values data) - (map (match-lambda - ((? boolean? b) - (if b "t" "f")) - ((? number? n) - (number->string n)) - ((? symbol? s) - (symbol->string s)) - ((? string? s) - s) - ((? null? n) - ;; exec-query-with-null-handling specifies NULL values as '() - n) - ((cast . value) - (if (string=? cast "jsonb") - (format-json value) - value)) - (unknown - (error (simple-format #f "normalise-values: error: ~A\n" unknown)))) - data)) - - (let* ((existing-entries - (if use-temporary-table? - (let ((temp-table-name - (string-append "temp_" table-name)) - (data - (if sets-of-data? - (delete-duplicates* (concatenate data)) - (if delete-duplicates? - (delete-duplicates* data) - data)))) - ;; Create a temporary table to store the data - (exec-query - conn - (string-append "CREATE TEMPORARY TABLE " - temp-table-name - " (LIKE " - table-name - " INCLUDING ALL)")) - (exec-query - conn - (string-append - "ANALYZE " temp-table-name)) - - ;; Populate the temporary table - (if (null? data) - '() - (with-time-logging (string-append "populating " temp-table-name) - (exec-query conn - (insert-sql data - #:table-name temp-table-name)))) - ;; Use the temporary table to find the existing values - (let ((result - (with-time-logging - (string-append "querying the " temp-table-name) - (exec-query->vhash - conn - (temp-table-select-query temp-table-name) - cdr - (lambda (result) - (string->number (first result))))))) - - (exec-query conn (string-append "DROP TABLE " temp-table-name)) - result)) - - ;; If not using a temporary table, just do a single SELECT query - (if (null? data) - '() - (fold - (lambda (data-chunk result) - (exec-query->vhash conn - (select-query data-chunk) - cdr - (lambda (result) - (string->number (first result))) - #:vhash result)) - vlist-null - (chunk (if sets-of-data? - (delete-duplicates* - (concatenate data)) - data) - 3000))))) - (missing-entries - (let loop ((lst (if sets-of-data? - (concatenate data) - data)) - (result '())) - (if (null? lst) - (if delete-duplicates? - (delete-duplicates* result) - result) - (let ((field-values (car lst))) - (if (vhash-assoc - ;; Normalise at this point, so that the proper value - ;; to insert is carried forward - (normalise-values field-values) - existing-entries) - (loop (cdr lst) - result) - (loop (cdr lst) - (cons field-values result))))))) - (new-entries - (if (null? missing-entries) - '() - (append-map! - (lambda (missing-entries-chunk) - (map (lambda (result) - (string->number (first result))) - (exec-query conn - (insert-sql missing-entries-chunk)))) - (chunk missing-entries 3000)))) - - (new-entries-lookup-vhash - (two-lists->vhash missing-entries - new-entries)) - (all-ids - (if sets-of-data? - (map (lambda (field-value-lists) - ;; Normalise the result at this point, ensuring that the id's - ;; in the set are sorted - (sort - (map (lambda (field-values) - (cdr - (or (vhash-assoc (normalise-values field-values) - existing-entries) - (vhash-assoc field-values - new-entries-lookup-vhash) - (error "missing entry" field-values)))) - field-value-lists) - <)) - data) - (map (lambda (field-values) - (cdr - (or (vhash-assoc (normalise-values field-values) - existing-entries) - (vhash-assoc field-values - new-entries-lookup-vhash) - (error "missing entry" field-values)))) - data)))) - (values all-ids - new-entries))) + " OR (" field " IS NULL AND $" i " IS NULL)") + "") + ")")) + (map number->string + (iota (length fields) 1)) + field-strings) + " AND\n ") +";")) + + (define insert + (string-append + " +INSERT INTO " table-name " (" (string-join field-strings ", ") ") +VALUES (" (string-join + (map (lambda (i) + (simple-format #f "$~A" i)) + (iota (length fields) 1)) + ", ") ") +ON CONFLICT DO NOTHING +RETURNING id;")) + + (let ((sql-field-values + (map value->sql-literal field-vals))) + (id-proc + (match (exec-query + conn + select + sql-field-values) + (((id)) id) + (() + (match (exec-query + conn + insert + sql-field-values) + (((id)) id) + (() + (match (exec-query + conn + select + sql-field-values) + (((id)) id))))))))) + +(define (prepare-insert-and-return-id conn + table-name + fields + types) + (define field-strings + (map symbol->string fields)) + + (define prepared-insert-select + (string-append + " +PREPARE " table-name "PreparedInsertSelect + (" (string-join (map symbol->string types) ",") ") AS +SELECT id FROM " table-name " +WHERE " +(string-join + (map (lambda (i field) + (string-append + "(" field " = $" i + (if (field-can-be-null? conn table-name field) + (string-append + " OR (" field " IS NULL AND $" i " IS NULL)") + "") + ")")) + (map number->string + (iota (length fields) 1)) + field-strings) + " AND\n ") +";")) + + (define prepared-insert + (string-append + " +PREPARE " table-name "PreparedInsert + (" (string-join (map symbol->string types) ",") ") AS +INSERT INTO " table-name " (\n" (string-join field-strings ",\n") ") +VALUES (" (string-join + (map (lambda (i) + (simple-format #f "$~A" i)) + (iota (length fields) 1)) + ", ") ") +ON CONFLICT DO NOTHING +RETURNING id;")) + + (exec-query conn prepared-insert) + (exec-query conn prepared-insert-select) + + (lambda (conn field-vals) + (match (exec-query + conn + (string-append + " +EXECUTE " table-name "PreparedInsert(" + (string-join (map value->sql field-vals) ", ") + ");")) + (((id)) id) + (() + (match (exec-query + conn + (string-append + " +EXECUTE " table-name "PreparedInsertSelect(" +(string-join (map value->sql field-vals) ", ") +");")) + (((id)) id)))))) |