cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Rework loading revision data

Browse source 
These changes were motivated by switching to a mechanism of loading data that
isn't dependent on the big advisory lock that prevents more than one revision
from being processed at a time.

Since INSERT ... RETURNING id; is used, this can block if another transaction
inserts the same data, and then cause an error when that transaction
commits. The solution is to use ON CONFLICT DO NOTHING, but you have to handle
the case when the INSERT doesn't return an id since the other transaction has
inserted it.

This commit rewrites insert-missing-data-and-return-all-ids to do as described
above, as well as being more efficient in how existing data is detected and to
use more vectors. Other utilities for inserting data are added as well.
This commit is contained in:
Christopher Baines 2024-12-05 20:56:23 +00:00
parent b128e9bd7a
commit 5ed98343d7
25 changed files with 874 additions and 1149 deletions
Download patch file Download diff file Expand all files Collapse all files

277
guix-data-service/jobs/load-new-guix-revision.scm
View file

@ -846,95 +846,84 @@
conn conn
(inferior-packages->license-id-lists (inferior-packages->license-id-lists
conn conn
;; TODO Don't needlessly convert (assq-ref inferior-packages-data 'license-data)))))
(vector->list
(assq-ref inferior-packages-data 'license-data))))))
(all-package-metadata-ids (all-package-metadata-ids
new-package-metadata-ids new-package-metadata-ids
(with-time-logging "inserting package metadata entries" (with-time-logging "inserting package metadata entries"
(inferior-packages->package-metadata-ids (inferior-packages->package-metadata-ids
conn conn
;; TODO Don't needlessly convert (assq-ref inferior-packages-data 'metadata)
(vector->list
(assq-ref inferior-packages-data 'metadata))
package-license-set-ids))) package-license-set-ids)))
(replacement-package-ids (replacement-package-ids
(vector-map (vector-map
(lambda (_ package-index-or-false) (lambda (_ package-index-or-false)
(if package-index-or-false (if package-index-or-false
(first (vector-ref
(inferior-packages->package-ids (inferior-packages->package-ids
conn conn
(list (list (vector-ref names package-index-or-false) (vector
(vector-ref versions package-index-or-false) (list (vector-ref names package-index-or-false)
(list-ref all-package-metadata-ids (vector-ref versions package-index-or-false)
package-index-or-false) (vector-ref all-package-metadata-ids
(cons "integer" NULL))))) package-index-or-false)
(cons "integer" NULL))))
0)
(cons "integer" NULL))) (cons "integer" NULL)))
(assq-ref inferior-packages-data 'replacements)))) (assq-ref inferior-packages-data 'replacements))))
(unless (null? new-package-metadata-ids) (unless (= 0 (vector-length new-package-metadata-ids))
(with-time-logging "inserting package metadata tsvector entries" (with-time-logging "inserting package metadata tsvector entries"
(insert-package-metadata-tsvector-entries (insert-package-metadata-tsvector-entries
conn new-package-metadata-ids))) conn new-package-metadata-ids)))
(with-time-logging "getting package-ids (without replacements)" (with-time-logging "getting package-ids (without replacements)"
(list->vector (inferior-packages->package-ids
(inferior-packages->package-ids conn
conn ;; Similar to zip, but generating a vector of lists
;; TODO Do this more efficiently (vector-map (lambda (index . vals) vals)
(zip (vector->list names) names
(vector->list versions) versions
all-package-metadata-ids all-package-metadata-ids
(vector->list replacement-package-ids))))))) replacement-package-ids)))))
(define (insert-lint-warnings conn (define (insert-lint-warnings conn
package-ids package-ids
lint-checker-ids lint-checker-ids
lint-warnings-data) lint-warnings-data)
(lint-warnings-data->lint-warning-ids (concatenate!
conn (filter-map
(append-map!
(lambda (lint-checker-id warnings-per-package) (lambda (lint-checker-id warnings-per-package)
(if warnings-per-package (if warnings-per-package
(vector-fold (vector-fold
(lambda (_ result package-id warnings) (lambda (_ result package-id warnings)
(append! (if (null? warnings)
result result
(map (cons
(match-lambda (lint-warnings-data->lint-warning-ids
((location-data messages-by-locale) conn
(let ((location-id (list->vector
(location->location-id (map
conn (match-lambda
(apply location location-data))) ((location-data messages-by-locale)
(lint-warning-message-set-id (let ((location-id
(lint-warning-message-data->lint-warning-message-set-id (location->location-id
conn conn
messages-by-locale))) (apply location location-data)))
(list lint-checker-id (lint-warning-message-set-id
package-id (lint-warning-message-data->lint-warning-message-set-id
location-id conn
lint-warning-message-set-id)))) messages-by-locale)))
(fold (lambda (location-and-messages result) (list lint-checker-id
;; TODO Sort to delete duplicates, rather than use member package-id
(if (member location-and-messages result) location-id
(begin lint-warning-message-set-id))))
(apply warnings)))
simple-format result)))
(current-error-port)
"warning: skipping duplicate lint warning ~A ~A\n"
location-and-messages)
result)
(append! result
(list location-and-messages))))
'()
warnings))))
'() '()
package-ids package-ids
warnings-per-package) warnings-per-package)
'())) #f))
lint-checker-ids (vector->list lint-checker-ids)
lint-warnings-data))) lint-warnings-data)))
(define (update-derivation-ids-hash-table! conn (define (update-derivation-ids-hash-table! conn
@ -977,30 +966,25 @@
#:key (log-tag "unspecified")) #:key (log-tag "unspecified"))
(define (insert-into-derivations conn drvs) (define (insert-into-derivations conn drvs)
(string-append (insert-missing-data-and-return-all-ids
"INSERT INTO derivations " conn
"(file_name, builder, args, env_vars, system_id) VALUES " "derivations"
(string-join '(file_name builder args env_vars system_id)
(map (match-lambda (vector-map (match-lambda*
(($ <derivation> outputs inputs sources ((_ ($ <derivation> outputs inputs sources
system builder args env-vars file-name) system builder args env-vars file-name))
(simple-format (list file-name
#f "('~A', '~A', ARRAY[~A]::varchar[], ARRAY[~A], '~A')" builder
file-name (cons "varchar[]"
builder (list->vector args))
(string-join (map quote-string args) ",") (cons "varchar[][]"
(string-join (map (match-lambda (list->vector
((key . value) (map (match-lambda
(string-append ((key . value)
"['" key '"', $$" (vector key value)))
value "$$ ]"))) env-vars)))
env-vars) (system->system-id conn system))))
",") drvs)))
(system->system-id conn system))))
drvs)
",")
" RETURNING id"
";"))
(define (insert-derivations) (define (insert-derivations)
(with-resource-from-pool postgresql-connection-pool conn (with-resource-from-pool postgresql-connection-pool conn
@ -1021,45 +1005,41 @@
(let ((derivations (let ((derivations
;; Do this while holding the PostgreSQL connection to ;; Do this while holding the PostgreSQL connection to
;; avoid conflicts with other fibers ;; avoid conflicts with other fibers
(delete-duplicates (list->vector
(filter-map (lambda (derivation) (delete-duplicates
(if (hash-ref derivation-ids-hash-table (filter-map (lambda (derivation)
(derivation-file-name (if (hash-ref derivation-ids-hash-table
derivation)) (derivation-file-name
#f derivation))
derivation)) #f
unfiltered-derivations)))) derivation))
(if (null? derivations) unfiltered-derivations)))))
(values '() '()) (if (= 0 (vector-length derivations))
(values #() #())
(begin (begin
(simple-format (simple-format
(current-error-port) (current-error-port)
"insert-missing-derivations: inserting ~A derivations (~A)\n" "insert-missing-derivations: inserting ~A derivations (~A)\n"
(length derivations) (vector-length derivations)
log-tag) log-tag)
(let ((derivation-ids (let ((derivation-ids
(append-map! (insert-into-derivations conn derivations)))
(lambda (chunk)
(map (lambda (result)
(string->number (car result)))
(exec-query conn (insert-into-derivations conn chunk))))
(chunk derivations 500))))
;; Do this while holding the connection so that other ;; Do this while holding the connection so that other
;; fibers don't also try inserting the same derivations ;; fibers don't also try inserting the same derivations
(with-time-logging (with-time-logging
(string-append "insert-missing-derivations: updating hash table (" log-tag ")") (string-append "insert-missing-derivations: updating hash table (" log-tag ")")
(for-each (lambda (derivation derivation-id) (vector-for-each (lambda (_ derivation derivation-id)
(hash-set! derivation-ids-hash-table (hash-set! derivation-ids-hash-table
(derivation-file-name derivation) (derivation-file-name derivation)
derivation-id)) derivation-id))
derivations derivations
derivation-ids)) derivation-ids))
(simple-format (simple-format
(current-error-port) (current-error-port)
"insert-missing-derivations: finished inserting ~A derivations (~A)\n" "insert-missing-derivations: finished inserting ~A derivations (~A)\n"
(length derivations) (vector-length derivations)
log-tag) log-tag)
(values derivations (values derivations
@ -1137,10 +1117,10 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
hash hash
compressed-nar-bytevector compressed-nar-bytevector
uncompressed-size)))))))) uncompressed-size))))))))
sources-ids (vector->list sources-ids)
sources))))) sources)))))
derivation-ids (vector->list derivation-ids)
derivations))) (vector->list derivations))))
(let ((derivations (let ((derivations
derivation-ids derivation-ids
@ -1154,12 +1134,13 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(string-append "insert-missing-derivations: inserting outputs (" (string-append "insert-missing-derivations: inserting outputs ("
log-tag ")") log-tag ")")
(with-resource-from-pool postgresql-connection-pool conn (with-resource-from-pool postgresql-connection-pool conn
(for-each (lambda (derivation-id derivation) (vector-for-each
(insert-derivation-outputs conn (lambda (_ derivation-id derivation)
derivation-id (insert-derivation-outputs conn
(derivation-outputs derivation))) derivation-id
derivation-ids (derivation-outputs derivation)))
derivations))) derivation-ids
derivations)))
(with-time-logging (with-time-logging
(string-append (string-append
@ -1169,7 +1150,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(map (map
derivation-input-derivation derivation-input-derivation
(append-map derivation-inputs (append-map derivation-inputs
derivations)))) (vector->list derivations)))))
(unless (null? input-derivations) (unless (null? input-derivations)
;; Ensure all the input derivations exist ;; Ensure all the input derivations exist
(for-each (for-each
@ -1182,12 +1163,14 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
#:log-tag log-tag)) #:log-tag log-tag))
(chunk! input-derivations 1000)))))) (chunk! input-derivations 1000))))))
(string-append "insert-missing-derivations: done parallel (" log-tag ")") (simple-format
(current-error-port)
"debug: insert-missing-derivations: done parallel (~A)\n" log-tag)
(with-resource-from-pool postgresql-connection-pool conn (with-resource-from-pool postgresql-connection-pool conn
(with-time-logging (with-time-logging
(simple-format (simple-format
#f "insert-missing-derivations: inserting inputs for ~A derivations (~A)" #f "insert-missing-derivations: inserting inputs for ~A derivations (~A)"
(length derivations) (vector-length derivations)
log-tag) log-tag)
(insert-derivation-inputs conn (insert-derivation-inputs conn
derivation-ids derivation-ids
@ -1913,25 +1896,28 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(define inferior-lint-checkers-data (define inferior-lint-checkers-data
(call-with-inferior (call-with-inferior
(lambda (inferior inferior-store) (lambda (inferior inferior-store)
(inferior-lint-checkers inferior)))) (list->vector
(inferior-lint-checkers inferior)))))
(when inferior-lint-checkers-data (when inferior-lint-checkers-data
(letpar& ((lint-checker-ids (letpar& ((lint-checker-ids
(with-resource-from-pool postgresql-connection-pool conn (with-resource-from-pool postgresql-connection-pool conn
(lint-checkers->lint-checker-ids (lint-checkers->lint-checker-ids
conn conn
(map (match-lambda (vector-map
((name descriptions-by-locale network-dependent) (match-lambda*
(list ((_ (name descriptions-by-locale network-dependent))
name (list
network-dependent name
;; Uses of sort may cause problems network-dependent
(call-with-worker-thread ;; Uses of sort may cause problems
utility-thread-channel (call-with-worker-thread
(lambda () utility-thread-channel
(lint-checker-description-data->lint-checker-description-set-id (lambda ()
conn descriptions-by-locale)))))) (lint-checker-description-data->lint-checker-description-set-id
inferior-lint-checkers-data)))) conn
descriptions-by-locale))))))
inferior-lint-checkers-data))))
(lint-warnings-data (lint-warnings-data
(fibers-map (fibers-map
(match-lambda (match-lambda
@ -1946,7 +1932,8 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(inferior-lint-warnings inferior (inferior-lint-warnings inferior
inferior-store inferior-store
checker-name))))))) checker-name)))))))
inferior-lint-checkers-data))) (vector->list
inferior-lint-checkers-data))))
(let ((package-ids (fibers-force package-ids-promise))) (let ((package-ids (fibers-force package-ids-promise)))
(with-resource-from-pool postgresql-connection-pool conn (with-resource-from-pool postgresql-connection-pool conn
@ -1955,20 +1942,21 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(fibers-force guix-revision-id-promise) (fibers-force guix-revision-id-promise)
lint-checker-ids) lint-checker-ids)
(let ((lint-warning-ids (let ((lint-warning-id-vectors
(insert-lint-warnings (with-time-logging "inserting lint warnings"
(insert-lint-warnings
conn
package-ids
lint-checker-ids
lint-warnings-data))))
(with-time-logging "inserting guix revision lint warnings"
(for-each
(lambda (lint-warning-ids)
(insert-guix-revision-lint-warnings
conn conn
package-ids (fibers-force guix-revision-id-promise)
lint-checker-ids lint-warning-ids))
lint-warnings-data))) lint-warning-id-vectors))))))))
(chunk-for-each!
(lambda (lint-warning-ids-chunk)
(insert-guix-revision-lint-warnings
conn
(fibers-force guix-revision-id-promise)
lint-warning-ids-chunk))
5000
lint-warning-ids)))))))
(define (extract-and-store-package-derivations) (define (extract-and-store-package-derivations)
(define packages-count (define packages-count
@ -2113,7 +2101,8 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
guix-revision-id guix-revision-id
package-derivation-ids-chunk))) package-derivation-ids-chunk)))
2000 2000
package-derivation-ids))) ;; TODO Chunk more efficiently
(vector->list package-derivation-ids))))
'finished) 'finished)
@ -2386,7 +2375,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(with-time-logging "updating builds.derivation_output_details_set_id" (with-time-logging "updating builds.derivation_output_details_set_id"
(update-builds-derivation-output-details-set-id (update-builds-derivation-output-details-set-id
conn conn
(string->number (fibers-force guix-revision-id-promise))))) (fibers-force guix-revision-id-promise))))
(begin (begin
(simple-format #t "Failed to generate store item for ~A\n" (simple-format #t "Failed to generate store item for ~A\n"
commit) commit)

27
guix-data-service/model/build.scm
View file

@ -510,19 +510,20 @@ WHERE derivations.file_name = $1"
derivation-output-details-lists derivation-output-details-lists
build-server-build-ids) build-server-build-ids)
(let ((build-ids (let ((build-ids
(insert-missing-data-and-return-all-ids (vector->list
conn (insert-missing-data-and-return-all-ids
"builds" conn
'(build_server_id derivation_file_name build_server_build_id) "builds"
(map (lambda (derivation-file-name build-server-build-id) '(build_server_id derivation_file_name build_server_build_id)
(list build-server-id (list->vector
derivation-file-name (map (lambda (derivation-file-name build-server-build-id)
(if (string? build-server-build-id) (list build-server-id
build-server-build-id derivation-file-name
'()))) (if (string? build-server-build-id)
derivation-file-names build-server-build-id
build-server-build-ids) '())))
#:delete-duplicates? #t))) derivation-file-names
build-server-build-ids))))))
(for-each (for-each
(lambda (build-id derivation-output-details) (lambda (build-id derivation-output-details)

117
guix-data-service/model/channel-news.scm
View file

@ -76,62 +76,21 @@ SELECT channel_news_entries.commit,
conn conn
"channel_news_entry_text" "channel_news_entry_text"
'(lang text) '(lang text)
(map (match-lambda (list->vector
((lang . text) (map (match-lambda
(list lang text))) ((lang . text)
text))) (list lang text)))
text))))
(define (insert-channel-news-entry conn commit tag) (define (insert-channel-news-entry conn commit tag)
(match (exec-query (insert-and-return-id
conn conn
(string-append "channel_news_entries"
"INSERT INTO channel_news_entries (commit, tag) VALUES (" '(commit tag)
(value->quoted-string-or-null commit) (list (or commit NULL)
"," (or tag NULL))))
(value->quoted-string-or-null tag)
") RETURNING id"))
(((id))
(string->number id))))
(define (insert-channel-news-entries conn channel-news-entries) (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 (map
(lambda (entry) (lambda (entry)
(let ((commit (channel-news-entry-commit entry)) (let ((commit (channel-news-entry-commit entry))
@ -145,36 +104,29 @@ ORDER BY id")
conn conn
(channel-news-entry-body entry)) (channel-news-entry-body entry))
<))) <)))
(or (and=> (vhash-assoc (list (or commit '()) (let ((channel-news-entry-id
(or tag '()) (insert-channel-news-entry conn commit tag)))
title-ids (for-each
body-ids) (lambda (table ids)
existing) (exec-query
(match-lambda conn
((value . key) (string-append
key))) "INSERT INTO " table
(let ((channel-news-entry-id " VALUES "
(insert-channel-news-entry conn commit tag))) (string-join
(for-each (map (lambda (id)
(lambda (table ids) (simple-format #f "(~A, ~A)"
(exec-query channel-news-entry-id
conn id))
(string-append (vector->list ids))
"INSERT INTO " table ", ")
" VALUES " " ON CONFLICT DO NOTHING")))
(string-join '("channel_news_entry_titles"
(map (lambda (id) "channel_news_entry_bodies")
(simple-format #f "(~A, ~A)" (list title-ids
channel-news-entry-id body-ids))
id))
ids)
", "))))
'("channel_news_entry_titles"
"channel_news_entry_bodies")
(list title-ids
body-ids))
channel-news-entry-id)))) channel-news-entry-id)))
channel-news-entries)) channel-news-entries))
(define (insert-channel-news-entries-for-guix-revision (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)) (simple-format #f "(~A,~A,~A)" guix-revision-id id index))
channel-news-entry-ids channel-news-entry-ids
(iota (length channel-news-entries))) (iota (length channel-news-entries)))
", "))))) ", ")
" ON CONFLICT DO NOTHING"))))
#t) #t)

132
guix-data-service/model/derivation.scm
View file

@ -982,76 +982,30 @@ LOCK TABLE ONLY derivation_output_details
conn conn
"derivation_output_details" "derivation_output_details"
'(path hash_algorithm hash recursive) '(path hash_algorithm hash recursive)
(map (lambda (details) (list->vector
(list (assq-ref details 'path) (map (lambda (details)
(or (non-empty-string-or-false (list (assq-ref details 'path)
(assq-ref details 'hash_algorithm)) (or (non-empty-string-or-false
NULL) (assq-ref details 'hash_algorithm))
(or (non-empty-string-or-false NULL)
(assq-ref details 'hash)) (or (non-empty-string-or-false
NULL) (assq-ref details 'hash))
(assq-ref details 'recursive))) NULL)
derivation-output-details))) (assq-ref details 'recursive)))
derivation-output-details))))
(define (derivation-output-details-ids->derivation-output-details-set-id (define (derivation-output-details-ids->derivation-output-details-set-id
conn conn
derivation-output-details-ids) derivation-output-details-ids)
(define sorted-derivation-output-details-ids (insert-and-return-id
(sort derivation-output-details-ids <)) conn
"derivation_output_details_sets"
(define (select-derivation-output-details-sets-id) '(derivation_output_details_ids)
(match (exec-query (list (sort derivation-output-details-ids <))))
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)))
(define (insert-derivation-outputs conn (define (insert-derivation-outputs conn
derivation-id derivation-id
names-and-derivation-outputs) 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 (define (insert-into-derivations-by-output-details-set
derivation_output_details_set_id) derivation_output_details_set_id)
(exec-query (exec-query
@ -1059,13 +1013,16 @@ RETURNING id"))
" "
INSERT INTO derivations_by_output_details_set INSERT INTO derivations_by_output_details_set
(derivation_id, derivation_output_details_set_id) (derivation_id, derivation_output_details_set_id)
VALUES ($1, $2)" VALUES ($1, $2)
ON CONFLICT DO NOTHING"
(list (number->string derivation-id) (list (number->string derivation-id)
(number->string derivation_output_details_set_id)))) (number->string derivation_output_details_set_id))))
(let* ((derivation-outputs (map cdr names-and-derivation-outputs)) (let* ((derivation-outputs
(derivation-output-paths (map derivation-output-path (map cdr names-and-derivation-outputs))
derivation-outputs)) (derivation-output-paths
(map derivation-output-path
derivation-outputs))
(derivation-output-names (derivation-output-names
(map car names-and-derivation-outputs)) (map car names-and-derivation-outputs))
@ -1083,10 +1040,17 @@ VALUES ($1, $2)"
(recursive . ,recursive?)))) (recursive . ,recursive?))))
derivation-outputs)))) derivation-outputs))))
(exec-query conn (insert-missing-data
(insert-into-derivation-outputs conn
derivation-output-names "derivation_outputs"
derivation-output-details-ids)) '(derivation_id name derivation_output_details_id)
(list->vector
(map (lambda (output-name derivation-output-details-id)
(list derivation-id
output-name
derivation-output-details-id))
derivation-output-names
(vector->list derivation-output-details-ids))))
(insert-into-derivations-by-output-details-set (insert-into-derivations-by-output-details-set
(derivation-output-details-ids->derivation-output-details-set-id (derivation-output-details-ids->derivation-output-details-set-id
@ -1434,8 +1398,8 @@ WHERE derivation_source_files.store_path = $1"
"', '" sub-derivation "')")) "', '" sub-derivation "')"))
sub-derivations)))) sub-derivations))))
(derivation-inputs derivation))) (derivation-inputs derivation)))
derivation-ids (vector->list derivation-ids)
derivations))) (vector->list derivations))))
(chunk-for-each! (chunk-for-each!
(lambda (query-parts-chunk) (lambda (query-parts-chunk)
@ -1452,18 +1416,11 @@ INNER JOIN derivations
ON derivations.file_name = vals.file_name ON derivations.file_name = vals.file_name
INNER JOIN derivation_outputs INNER JOIN derivation_outputs
ON derivation_outputs.derivation_id = derivations.id ON derivation_outputs.derivation_id = derivations.id
AND vals.output_name = derivation_outputs.name"))) AND vals.output_name = derivation_outputs.name
ON CONFLICT DO NOTHING")))
1000 1000
query-parts))) 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-derivation-sources conn derivation-id sources)
(define (insert-into-derivation-sources derivation-source-file-ids) (define (insert-into-derivation-sources derivation-source-file-ids)
(string-append (string-append
@ -1473,16 +1430,17 @@ INNER JOIN derivation_outputs
(map (lambda (derivation-source-file-id) (map (lambda (derivation-source-file-id)
(simple-format (simple-format
#f "(~A, ~A)" derivation-id derivation-source-file-id)) #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 (let ((sources-ids
(insert-missing-data-and-return-all-ids (insert-missing-data-and-return-all-ids
conn conn
"derivation_source_files" "derivation_source_files"
'(store_path) '(store_path)
(map list sources)))) (list->vector
(map list sources)))))
(exec-query conn (exec-query conn
(insert-into-derivation-sources sources-ids)) (insert-into-derivation-sources sources-ids))
@ -1501,7 +1459,8 @@ INSERT INTO derivation_source_file_nars (
hash, hash,
uncompressed_size, uncompressed_size,
data data
) VALUES ($1, $2, $3, $4, $5, $6)" ) VALUES ($1, $2, $3, $4, $5, $6)
ON CONFLICT DO NOTHING"
(list (number->string id) (list (number->string id)
"lzip" "lzip"
"sha256" "sha256"
@ -1520,7 +1479,8 @@ INSERT INTO derivation_source_file_nars (
hash, hash,
uncompressed_size, uncompressed_size,
data data
) VALUES ($1, $2, $3, $4, $5, $6)" ) VALUES ($1, $2, $3, $4, $5, $6)
ON CONFLICT DO NOTHING"
(list (number->string id) (list (number->string id)
"lzip" "lzip"
"sha256" "sha256"

16
guix-data-service/model/git-branch.scm
View file

@ -47,16 +47,12 @@ WHERE git_repository_id = $1
(define (insert-git-branch-entry conn (define (insert-git-branch-entry conn
git-repository-id git-repository-id
name) name)
(match (exec-query (insert-and-return-id
conn conn
" "git_branches"
INSERT INTO git_branches (git_repository_id, name) '(git_repository_id name)
VALUES ($1, $2) (list git-repository-id
RETURNING id" name)))
(list (number->string git-repository-id)
name))
(((id))
(string->number id))))
(define (git-branches-for-commit conn commit) (define (git-branches-for-commit conn commit)
(define query (define query

5
guix-data-service/model/guix-revision.scm
View file

@ -56,8 +56,7 @@ FROM guix_revisions
WHERE commit = $1 WHERE commit = $1
AND git_repository_id = $2" AND git_repository_id = $2"
(list commit git-repository-id)) (list commit git-repository-id))
(((id)) (((id)) (string->number id))
id)
(() #f))) (() #f)))
(define (insert-guix-revision conn git-repository-id commit) (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") VALUES ($1, $2) RETURNING id")
(match (exec-query conn insert (list git-repository-id commit)) (match (exec-query conn insert (list git-repository-id commit))
(((id)) id))) (((id)) (string->number id))))
(define (guix-commit-exists? conn commit) (define (guix-commit-exists? conn commit)
(define query (define query

88
guix-data-service/model/license-set.scm
View file

@ -17,6 +17,7 @@
(define-module (guix-data-service model license-set) (define-module (guix-data-service model license-set)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-43)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (squee) #:use-module (squee)
#:use-module (guix-data-service utils) #:use-module (guix-data-service utils)
@ -24,83 +25,12 @@
#:use-module (guix-data-service model license) #:use-module (guix-data-service model license)
#:export (inferior-packages->license-set-ids)) #: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) (define (inferior-packages->license-set-ids conn license-id-lists)
(let* ((existing-license-sets (insert-missing-data-and-return-all-ids
(exec-query->vhash conn conn
select-license-sets "license_sets"
(lambda (results) '(license_ids)
(if (string=? (second results) "{}") (vector-map
'() (lambda (_ license-ids)
(map (list (sort license-ids <)))
string->number license-id-lists)))
(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
(let ((a1 (car a))
(b1 (car b)))
(if (= a1 b1)
(loop (cdr a)
(cdr b))
(< a1 b1)))))))))
(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)))

36
guix-data-service/model/license.scm
View file

@ -17,6 +17,7 @@
(define-module (guix-data-service model license) (define-module (guix-data-service model license)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-43)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (squee) #:use-module (squee)
@ -50,7 +51,7 @@
(current-error-port) (current-error-port)
"error: unknown license value ~A for package ~A" "error: unknown license value ~A for package ~A"
x package) x package)
'())) #f))
values)) values))
(x (x
(simple-format (simple-format
@ -70,18 +71,21 @@
;; save non string values as NULL ;; save non string values as NULL
NULL)) NULL))
(insert-missing-data-and-return-all-ids (vector-map
conn (lambda (_ license-tuples)
"licenses" (if (null? license-tuples)
`(name uri comment) #()
(map (lambda (license-tuples) (insert-missing-data-and-return-all-ids
(map conn
(match-lambda "licenses"
((name uri comment) `(name uri comment)
(list name (list->vector
(string-or-null uri) (filter-map
(string-or-null comment)))) (match-lambda
license-tuples)) ((name uri comment)
license-data) (list name
#:delete-duplicates? #t (string-or-null uri)
#:sets-of-data? #t)) (string-or-null comment)))
(#f #f))
license-tuples)))))
license-data))

57
guix-data-service/model/lint-checker.scm
View file

@ -17,6 +17,7 @@
(define-module (guix-data-service model lint-checker) (define-module (guix-data-service model lint-checker)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-43)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (squee) #:use-module (squee)
#:use-module (guix-data-service model utils) #:use-module (guix-data-service model utils)
@ -24,8 +25,7 @@
lint-warning-count-by-lint-checker-for-revision lint-warning-count-by-lint-checker-for-revision
insert-guix-revision-lint-checkers insert-guix-revision-lint-checkers
lint-checkers-for-revision lint-checkers-for-revision
lint-checker-description-data->lint-checker-description-set-id lint-checker-description-data->lint-checker-description-set-id))
insert-lint-checker-description-set))
(define (lint-checkers->lint-checker-ids conn lint-checkers-data) (define (lint-checkers->lint-checker-ids conn lint-checkers-data)
(insert-missing-data-and-return-all-ids (insert-missing-data-and-return-all-ids
@ -40,48 +40,23 @@
conn conn
"lint_checker_descriptions" "lint_checker_descriptions"
'(locale description) '(locale description)
(map (match-lambda (list->vector
((locale . description) (map (match-lambda
(list locale description))) ((locale . description)
descriptions-by-locale))) (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))))
(define (lint-checker-description-data->lint-checker-description-set-id (define (lint-checker-description-data->lint-checker-description-set-id
conn conn
descriptions-by-locale) descriptions-by-locale)
(let* ((lint-checker-description-ids (insert-and-return-id
(lint-checker-description-data->lint-checker-description-ids conn
conn "lint_checker_description_sets"
descriptions-by-locale)) '(description_ids)
(lint-checker-description-set-id (list
(exec-query (lint-checker-description-data->lint-checker-description-ids
conn conn
(string-append descriptions-by-locale))))
"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))))))
(define (lint-warning-count-by-lint-checker-for-revision conn commit-hash) (define (lint-warning-count-by-lint-checker-for-revision conn commit-hash)
(define query (define query
@ -125,7 +100,7 @@ ORDER BY count DESC")
"(~A, ~A)" "(~A, ~A)"
lint-checker-id lint-checker-id
guix-revision-id)) guix-revision-id))
lint-checker-ids) (vector->list lint-checker-ids))
", ")))) ", "))))
(define (lint-checkers-for-revision conn commit-hash) (define (lint-checkers-for-revision conn commit-hash)

53
guix-data-service/model/lint-warning-message.scm
View file

@ -16,6 +16,7 @@
;;; <http://www.gnu.org/licenses/>. ;;; <http://www.gnu.org/licenses/>.
(define-module (guix-data-service model lint-warning-message) (define-module (guix-data-service model lint-warning-message)
#:use-module (srfi srfi-43)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (squee) #:use-module (squee)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
@ -30,48 +31,24 @@
conn conn
"lint_warning_messages" "lint_warning_messages"
'(locale message) '(locale message)
(map (match-lambda (let ((v (list->vector messages-by-locale)))
((locale . message) (vector-map! (lambda (_ data)
(list locale message))) (match data
messages-by-locale))) ((locale . message)
(list locale message))))
v)
v)))
(define (lint-warning-message-data->lint-warning-message-set-id (define (lint-warning-message-data->lint-warning-message-set-id
conn conn
messages-by-locale) messages-by-locale)
(insert-and-return-id
(let* ((lint-warning-message-ids conn
(lint-warning-message-data->lint-warning-message-ids "lint_warning_message_sets"
conn messages-by-locale)) '(message_ids)
(select-query (list (lint-warning-message-data->lint-warning-message-ids
(string-append conn
"SELECT id FROM lint_warning_message_sets " messages-by-locale))))
"WHERE message_ids = ARRAY["
(string-join (map number->string
(sort lint-warning-message-ids <)) ", ")
"]")))
(string->number
(match (exec-query conn select-query)
(((id)) id)
(()
(match (exec-query
conn
(string-append
"
INSERT INTO lint_warning_message_sets (message_ids) VALUES "
(string-append
"('{"
(string-join
(map number->string
(sort lint-warning-message-ids <))
", ")
"}')") "
ON CONFLICT DO NOTHING RETURNING id"))
(((id)) id)
(()
(match (exec-query conn select-query)
(((id)) id)))))))))
(define (lint-warning-message-locales-for-revision conn commit-hash) (define (lint-warning-message-locales-for-revision conn commit-hash)
(exec-query (exec-query

32
guix-data-service/model/lint-warning.scm
View file

@ -40,22 +40,22 @@
(define (insert-guix-revision-lint-warnings conn (define (insert-guix-revision-lint-warnings conn
guix-revision-id guix-revision-id
lint-warning-ids) lint-warning-ids)
(if (null? lint-warning-ids) (unless (= 0 (vector-length lint-warning-ids))
'() (exec-query
(exec-query conn
conn (string-append
(string-append "INSERT INTO guix_revision_lint_warnings (lint_warning_id, guix_revision_id) "
"INSERT INTO guix_revision_lint_warnings (lint_warning_id, guix_revision_id) " "VALUES "
"VALUES " (string-join
(string-join (map (lambda (lint-warning-id)
(map (lambda (lint-warning-id) (simple-format
(simple-format #f
#f "(~A, ~A)"
"(~A, ~A)" lint-warning-id
lint-warning-id guix-revision-id))
guix-revision-id)) (vector->list lint-warning-ids))
lint-warning-ids) ", ")
", "))))) " ON CONFLICT DO NOTHING"))))
(define* (lint-warnings-for-guix-revision conn commit-hash (define* (lint-warnings-for-guix-revision conn commit-hash
#:key #:key

15
guix-data-service/model/location.scm
View file

@ -23,11 +23,10 @@
#:export (location->location-id)) #:export (location->location-id))
(define (location->location-id conn location) (define (location->location-id conn location)
(car (insert-and-return-id
(insert-missing-data-and-return-all-ids conn
conn "locations"
"locations" '(file line column_number)
'(file line column_number) (match location
(match location (($ <location> file line column)
(($ <location> file line column) (list file line column)))))
(list (list file line column)))))))

105
guix-data-service/model/nar.scm
View file

@ -57,11 +57,12 @@
narinfos)) narinfos))
(let ((nar-ids (let ((nar-ids
(insert-missing-data-and-return-all-ids (vector->list
conn (insert-missing-data-and-return-all-ids
"nars" conn
'(store_path hash_algorithm hash size system deriver) "nars"
data))) '(store_path hash_algorithm hash size system deriver)
(list->vector data)))))
(let ((reference-data (let ((reference-data
(concatenate (concatenate
@ -176,49 +177,45 @@ VALUES ($1, $2)")
#\;) #\;)
((version host-name signature-data) ((version host-name signature-data)
(first (insert-and-return-id
(insert-missing-data-and-return-all-ids conn
conn "narinfo_signature_data"
"narinfo_signature_data" '(version host_name data_hash data_hash_algorithm
'(version host_name data_hash data_hash_algorithm data_json sig_val_json narinfo_signature_public_key_id
data_json sig_val_json narinfo_signature_public_key_id narinfo_body narinfo_signature_line)
narinfo_body narinfo_signature_line) (append (list (string->number version)
(list host-name)
(append (list (string->number version) (let* ((data-sexp
host-name) (find (match-lambda
(let* ((data-sexp ((component data ...)
(find (match-lambda (if (eq? component 'data)
((component data ...) data
(if (eq? component 'data) #f))
data (_ #f))
#f)) signature-sexp))
(_ #f)) (hash-sexp
signature-sexp)) (third data-sexp))
(hash-sexp (hash-algorithm
(third data-sexp)) (second hash-sexp))
(hash-algorithm (hash
(second hash-sexp)) (third hash-sexp)))
(hash (list
(third hash-sexp))) (bytevector->base16-string hash)
(list hash-algorithm
(bytevector->base16-string hash) (sexp->json-string data-sexp)))
hash-algorithm (let ((sig-val-sexp
(cons "jsonb" (find (match-lambda
(sexp->json-string data-sexp)))) ((component data ...)
(let ((sig-val-sexp (if (eq? component 'sig-val)
(find (match-lambda data
((component data ...) #f))
(if (eq? component 'sig-val) (_ #f))
data signature-sexp)))
#f)) (list
(_ #f)) (sexp->json-string sig-val-sexp)))
signature-sexp))) (list public-key-id
(list body
(cons "jsonb" signature-line))))))))))
(sexp->json-string sig-val-sexp))))
(list public-key-id
body
signature-line))))))))))))
(define (narinfo-signature->public-key-id conn signature) (define (narinfo-signature->public-key-id conn signature)
(let* ((public-key-sexp (let* ((public-key-sexp
@ -232,13 +229,11 @@ VALUES ($1, $2)")
(public-key-json-string (public-key-json-string
(sexp->json-string public-key-sexp))) (sexp->json-string public-key-sexp)))
(first (insert-and-return-id
(insert-missing-data-and-return-all-ids conn
conn "narinfo_signature_public_keys"
"narinfo_signature_public_keys" '(sexp_json)
'(sexp_json) (list public-key-json-string))))
(list (list (cons "jsonb"
public-key-json-string)))))))
(define (select-package-output-availability-for-revision conn revision-commit) (define (select-package-output-availability-for-revision conn revision-commit)
(define query (define query

4
guix-data-service/model/package-derivation-by-guix-revision-range.scm
View file

@ -48,7 +48,7 @@ WHERE git_branch_id = $1 AND
WHERE revision_id = $2 WHERE revision_id = $2
)" )"
(list (number->string git-branch-id) (list (number->string git-branch-id)
guix-revision-id))))) (number->string guix-revision-id))))))
(define (insert-guix-revision-package-derivation-entries conn (define (insert-guix-revision-package-derivation-entries conn
git-repository-id git-repository-id
@ -185,7 +185,7 @@ PARTITION OF package_derivations_by_guix_revision_range FOR VALUES IN ("
query query
(list git-repository-id (list git-repository-id
(number->string git-branch-id) (number->string git-branch-id)
guix-revision-id)))) (number->string guix-revision-id)))))
(define (update-package-derivations-table conn (define (update-package-derivations-table conn
git-repository-id git-repository-id

5
guix-data-service/model/package-derivation.scm
View file

@ -49,12 +49,13 @@
derivation-ids)) derivation-ids))
(if (null? data-4-tuples) (if (null? data-4-tuples)
'() #()
(insert-missing-data-and-return-all-ids (insert-missing-data-and-return-all-ids
conn conn
"package_derivations" "package_derivations"
'(package_id derivation_id system_id target) '(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 (count-packages-derivations-in-revision conn commit-hash)
(define query (define query

203
guix-data-service/model/package-metadata.scm
View file

@ -205,27 +205,6 @@ WHERE packages.id IN (
(json-string->scm license-json))))) (json-string->scm license-json)))))
(exec-query conn query (list revision-commit-hash name version locale)))) (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 (define (inferior-packages->translated-package-descriptions-and-synopsis inferior
inferior-package) inferior-package)
@ -293,73 +272,12 @@ WHERE packages.id IN (
(prevent-inlining-for-tests inferior-packages->translated-package-descriptions-and-synopsis) (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 (define (inferior-packages->package-metadata-ids conn
package-metadata package-metadata
license-set-ids) license-set-ids)
(define package-metadata-list
(vector->list package-metadata))
(insert-missing-data-and-return-all-ids (insert-missing-data-and-return-all-ids
conn conn
"package_metadata" "package_metadata"
@ -369,68 +287,63 @@ WHERE packages.id IN (
package_description_set_id package_description_set_id
package_synopsis_set_id) package_synopsis_set_id)
(zip (list->vector
(map (match-lambda (zip
((home-page rest ...) (map (match-lambda
(if (string? home-page) ((home-page rest ...)
home-page (if (string? home-page)
NULL))) home-page
package-metadata) NULL)))
(with-time-logging "preparing location ids" package-metadata-list)
(map (match-lambda (with-time-logging "preparing location ids"
((_ location rest ...) (map (match-lambda
(if location ((_ location rest ...)
(location->location-id (if location
conn (location->location-id
location) conn
NULL))) location)
package-metadata)) NULL)))
license-set-ids package-metadata-list))
(with-time-logging "preparing package description set ids" (vector->list license-set-ids)
(map (lambda (package-description-ids) (with-time-logging "preparing package description set ids"
(package-description-data->package-description-set-id (map (lambda (package-description-ids)
conn (insert-and-return-id
package-description-ids)) conn
(with-time-logging "preparing package description ids" "package_description_sets"
(insert-missing-data-and-return-all-ids '(description_ids)
conn (list (sort package-description-ids <))))
"package_descriptions" (with-time-logging "preparing package description ids"
'(locale description)
(map (match-lambda (map (match-lambda
((_ _ package-description-data _) ((_ _ package-description-data _)
(map (match-lambda (insert-missing-data-and-return-all-ids
((locale . description) conn
(list locale description))) "package_descriptions"
package-description-data))) '(locale description)
package-metadata) (list->vector
#:delete-duplicates? #t (map (match-lambda
#:sets-of-data? #t)))) ((locale . description)
(with-time-logging "preparing package synopsis set ids" (list locale description)))
(map (lambda (package-synopsis-ids) package-description-data)))))
(package-synopsis-data->package-synopsis-set-id package-metadata-list))))
conn (with-time-logging "preparing package synopsis set ids"
package-synopsis-ids)) (map (lambda (package-synopsis-ids)
(insert-missing-data-and-return-all-ids (insert-and-return-id
conn conn
"package_synopsis" "package_synopsis_sets"
'(locale synopsis) '(synopsis_ids)
(list (sort package-synopsis-ids <))))
(map (match-lambda (map (match-lambda
((_ _ _ package-synopsis-data) ((_ _ _ package-synopsis-data)
(map (match-lambda (insert-missing-data-and-return-all-ids
((locale . synopsis) conn
(list locale synopsis))) "package_synopsis"
package-synopsis-data))) '(locale synopsis)
package-metadata) (list->vector
#:delete-duplicates? #t (map (match-lambda
#:sets-of-data? #t)))) ((locale . synopsis)
;; There can be duplicated entires in package-metadata, for example where (list locale synopsis)))
;; you have one package definition which interits from another, and just package-synopsis-data)))))
;; overrides the version and the source, the package_metadata entries for package-metadata-list)))))))
;; 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))
(define (package-description-and-synopsis-locale-options-guix-revision conn (define (package-description-and-synopsis-locale-options-guix-revision conn
revision-id) revision-id)
@ -551,8 +464,8 @@ INNER JOIN (
OR translated_package_descriptions.locale = 'en_US.UTF-8') OR translated_package_descriptions.locale = 'en_US.UTF-8')
WHERE package_metadata.id IN (" WHERE package_metadata.id IN ("
(string-join (string-join
(map number->string (map number->string (vector->list package-metadata-ids))
package-metadata-ids) ", ") ")" ", ") ")"
" "
ORDER BY package_metadata.id, locale, ORDER BY package_metadata.id, locale,
CASE WHEN translated_package_synopsis.locale = CASE WHEN translated_package_synopsis.locale =

17
guix-data-service/model/package.scm
View file

@ -250,23 +250,6 @@ WHERE packages.id IN (
(exec-query conn query (list commit-hash))) (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) (define (inferior-packages->package-ids conn package-entries)
(insert-missing-data-and-return-all-ids (insert-missing-data-and-return-all-ids
conn conn

21
guix-data-service/model/system.scm
View file

@ -34,17 +34,16 @@
(let ((cached-value (hash-ref system->system-id-cache (let ((cached-value (hash-ref system->system-id-cache
system))) system)))
(or cached-value (or cached-value
(match (insert-missing-data-and-return-all-ids (let ((id (insert-and-return-id
conn conn
"systems" "systems"
'(system) '(system)
`((,system))) (list system))))
((id) (hash-set! system->system-id-cache
(hash-set! system->system-id-cache system
system id)
id) (set! systems-cache #f)
(set! systems-cache #f) id))))
id)))))
(define (lookup-system-id conn system) (define (lookup-system-id conn system)
(let ((cached-value (hash-ref system->system-id-cache (let ((cached-value (hash-ref system->system-id-cache

649
guix-data-service/model/utils.scm
View file

@ -17,6 +17,7 @@
(define-module (guix-data-service model utils) (define-module (guix-data-service model utils)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-43)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 receive) #:use-module (ice-9 receive)
@ -26,14 +27,16 @@
#:export (quote-string #:export (quote-string
value->quoted-string-or-null value->quoted-string-or-null
non-empty-string-or-false non-empty-string-or-false
exec-query->vhash
two-lists->vhash
parse-postgresql-array-string parse-postgresql-array-string
deduplicate-strings deduplicate-strings
group-list-by-first-n-fields group-list-by-first-n-fields
group-to-alist group-to-alist
group-to-alist/vector group-to-alist/vector
insert-missing-data-and-return-all-ids)) insert-missing-data-and-return-all-ids
insert-missing-data
bulk-select
insert-and-return-id
prepare-insert-and-return-id))
(define (quote-string s) (define (quote-string s)
(string-append "$STR$" s "$STR$")) (string-append "$STR$" s "$STR$"))
@ -50,22 +53,6 @@
s) s)
#f)) #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) (define (parse-postgresql-array-string s)
(if (string=? s "{}") (if (string=? s "{}")
'() '()
@ -170,300 +157,368 @@ WHERE table_name = $1"
schema-details) schema-details)
(error "error: field-can-be-null?")))))))) (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 "TRUE" "FALSE"))
((? 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 " (\n"
(string-join field-strings ",\n")
") 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 (define* (insert-missing-data-and-return-all-ids
conn conn
table-name table-name
fields fields
data data
#:key #:key (id-proc string->number))
sets-of-data?
delete-duplicates?
use-temporary-table?)
(define field-strings (define field-strings
(map symbol->string fields)) (map symbol->string fields))
(define value->sql (let* ((result
(match-lambda (bulk-select
((? string? s) conn
(string-append "$STR$" s "$STR$")) table-name
((? NULL?) fields
"NULL") data
((? symbol? s) #:id-proc id-proc))
(string-append "$STR$" (missing-data-indexes
(symbol->string s) (vector-fold
"$STR$")) (lambda (i missing-data-indexes id-or-f)
((? number? n) (if id-or-f
(number->string n)) missing-data-indexes
((? boolean? b) (cons i missing-data-indexes)))
(if b "TRUE" "FALSE")) '()
((cast . value) result))
(string-append (new-ids
(value->sql value) "::" cast)) (bulk-insert
(v conn
(error table-name
(simple-format #f "error: unknown type for value: ~A" v))))) fields
(map (lambda (index)
(vector-ref data index))
missing-data-indexes)
#:id-proc id-proc)))
(define (delete-duplicates* data) (fold
(delete-duplicates/sort! (lambda (missing-data-index index)
(list-copy data) (let ((new-id (vector-ref new-ids index)))
(lambda (full-a full-b) (vector-set! result missing-data-index new-id))
(let loop ((a full-a) (1+ index))
(b full-b)) 0
(if (null? a) missing-data-indexes)
#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 (select-query data) (values result new-ids)))
(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 (string-append
"SELECT id,\n" "
(string-join (map (lambda (field) SELECT id FROM " table-name "
(string-append table-name "." field)) WHERE "
field-strings) (string-join
",\n") (map (lambda (i field)
" FROM " table-name (string-append
" JOIN (VALUES " "(" field " = $" i
(string-join (if (field-can-be-null? conn table-name field)
(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? conn table-name field)
`(" OR (" ,table-name "." ,field " IS NULL AND"
" vals." ,field " IS NULL"
")")
'())
")")))
field-strings)
" AND\n ")))
(define (temp-table-select-query temp-table-name)
(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? conn table-name 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))
(string-append
"INSERT INTO " table-name " (\n"
(string-join field-strings ",\n")
") VALUES "
(string-join
(map (lambda (field-values)
(string-append (string-append
"(" " OR (" field " IS NULL AND $" i " IS NULL)")
(string-join "")
(map (lambda (value) ")"))
(value->sql value)) (map number->string
field-values) (iota (length fields) 1))
", ") field-strings)
")")) " AND\n ")
missing-data) ";"))
", ")
" ON CONFLICT DO NOTHING"))
(define (format-json json) (define insert
;; PostgreSQL formats JSON strings differently to guile-json, so use (string-append
;; PostgreSQL to do the formatting "
(caar INSERT INTO " table-name " (\n" (string-join field-strings ",\n") ")
(exec-query VALUES (" (string-join
conn (map (lambda (i)
(string-append (simple-format #f "$~A" i))
"SELECT $STR$" json "$STR$::jsonb")))) (iota (length fields) 1))
", ") ")
ON CONFLICT DO NOTHING
RETURNING id;"))
(define (normalise-values data) (let ((sql-field-values
(map (match-lambda (map value->sql-literal field-vals)))
((? boolean? b) (id-proc
(if b "t" "f")) (match (exec-query
((? number? n) conn
(number->string n)) select
((? NULL? n) n) sql-field-values)
((? symbol? s) (((id)) id)
(symbol->string s)) (()
((? string? s) (match (exec-query
s) conn
((cast . value) insert
(if (string=? cast "jsonb") sql-field-values)
(format-json value) (((id)) id)
value)) (()
(unknown (match (exec-query
(error (simple-format #f "normalise-values: error: ~A\n" unknown)))) conn
data)) select
sql-field-values)
(((id)) id)))))))))
(let* ((flattened-deduplicated-data (define (prepare-insert-and-return-id conn
(if sets-of-data? table-name
(delete-duplicates* fields
(concatenate data)) types)
(if delete-duplicates? (define field-strings
(delete-duplicates* data) (map symbol->string fields))
data)))
(existing-entries
(if use-temporary-table?
(let ((temp-table-name
(string-append "temp_" table-name)))
;; 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 (define prepared-insert-select
(unless (null? flattened-deduplicated-data) (string-append
(with-time-logging (string-append "populating " temp-table-name) "
(exec-query conn PREPARE " table-name "PreparedInsertSelect
(insert-sql flattened-deduplicated-data (" (string-join (map symbol->string types) ",") ") AS
#:table-name temp-table-name)))) SELECT id FROM " table-name "
;; Use the temporary table to find the existing values WHERE "
(let ((result (string-join
(with-time-logging (map (lambda (i field)
(string-append "querying the " temp-table-name) (string-append
(exec-query->vhash "(" field " = $" i
conn (if (field-can-be-null? conn table-name field)
(temp-table-select-query temp-table-name) (string-append
cdr " OR (" field " IS NULL AND $" i " IS NULL)")
(lambda (result) "")
(string->number (first result))))))) ")"))
(map number->string
(iota (length fields) 1))
field-strings)
" AND\n ")
";"))
(exec-query conn (string-append "DROP TABLE " temp-table-name)) (define prepared-insert
result)) (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;"))
;; If not using a temporary table, just do a single SELECT query (exec-query conn prepared-insert)
(if (null? flattened-deduplicated-data) (exec-query conn prepared-insert-select)
'()
(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 flattened-deduplicated-data
3000)))))
(missing-entries
(let loop ((lst flattened-deduplicated-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)
(exec-query conn
(insert-sql missing-entries-chunk))
(map (lambda (row) (lambda (conn field-vals)
(string->number (first row))) (match (exec-query
(exec-query conn (select-query missing-entries-chunk)))) conn
(chunk missing-entries 3000)))) (string-append
"
(new-entries-lookup-vhash EXECUTE " table-name "PreparedInsert("
(two-lists->vhash missing-entries (string-join (map value->sql field-vals) ", ")
new-entries)) ");"))
(all-ids (((id)) id)
(if sets-of-data? (()
(map (lambda (field-value-lists) (match (exec-query
;; Normalise the result at this point, ensuring that the id's conn
;; in the set are sorted (string-append
(sort "
(map (lambda (field-values) EXECUTE " table-name "PreparedInsertSelect("
(cdr (string-join (map value->sql field-vals) ", ")
(or (vhash-assoc (normalise-values field-values) ");"))
existing-entries) (((id)) id))))))
(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
(delete-duplicates/sort! new-entries <))))

18
tests/model-license-set.scm
View file

@ -9,15 +9,15 @@
(test-begin "test-model-license-set") (test-begin "test-model-license-set")
(define license-data (define license-data
'((("License 1" '#((("License 1"
"https://gnu.org/licenses/test-1.html" "https://gnu.org/licenses/test-1.html"
"https://example.com/why-license-1")) "https://example.com/why-license-1"))
(("License 1" (("License 1"
"https://gnu.org/licenses/test-1.html" "https://gnu.org/licenses/test-1.html"
#f) #f)
("License 2" ("License 2"
#f #f
#f)))) #f))))
(with-postgresql-connection (with-postgresql-connection
"test-model-license-set" "test-model-license-set"

24
tests/model-license.scm
View file

@ -8,18 +8,18 @@
(test-begin "test-model-license") (test-begin "test-model-license")
(define license-data (define license-data
'((("License 1" '#((("License 1"
"https://gnu.org/licenses/test-1.html" "https://gnu.org/licenses/test-1.html"
"https://example.com/why-license-1")) "https://example.com/why-license-1"))
(("License 1" (("License 1"
"https://gnu.org/licenses/test-1.html" "https://gnu.org/licenses/test-1.html"
#f) #f)
("License 2" ("License 2"
"https://gnu.org/licenses/test-2.html" "https://gnu.org/licenses/test-2.html"
#f) #f)
("License 3" ("License 3"
#f #f
#f)))) #f))))
(with-postgresql-connection (with-postgresql-connection
"test-model-license" "test-model-license"

37
tests/model-lint-checker.scm
View file

@ -16,32 +16,23 @@
conn conn
(lambda (conn) (lambda (conn)
(define data (define data
`((name-1 #t ,(string->number (insert-lint-checker-description-set `#((name-1
conn '(37)))) #t
(name-2 #f ,(string->number (insert-lint-checker-description-set ,(lint-checker-description-data->lint-checker-description-set-id
conn '(38)))))) conn
'(("en_US" . "foo"))))
(name-2
#f
,(lint-checker-description-data->lint-checker-description-set-id
conn
'(("en_US" . "bar"))))))
(match (lint-checkers->lint-checker-ids conn data) (match (lint-checkers->lint-checker-ids conn data)
(((? number? id1) (? number? id2)) (#((? number? id1) (? number? id2))
#t)))
#:always-rollback? #t))
(test-assert "double insert"
(with-postgresql-transaction
conn
(lambda (conn)
(define data
`((name-1 #t ,(string->number (insert-lint-checker-description-set
conn '(37))))
(name-2 #f ,(string->number (insert-lint-checker-description-set
conn '(38))))))
(match (lint-checkers->lint-checker-ids conn data)
(((? number? id1) (? number? id2))
(match (lint-checkers->lint-checker-ids conn data) (match (lint-checkers->lint-checker-ids conn data)
(((? number? second-id1) (? number? second-id2)) (#((? number? second-id1) (? number? second-id2))
(and (eq? id1 second-id1) (and (= id1 second-id1)
(eq? id2 second-id2))))))) (= id2 second-id2)))))))
#:always-rollback? #t)))) #:always-rollback? #t))))
(test-end) (test-end)

12
tests/model-lint-warning-message.scm
View file

@ -20,7 +20,7 @@
conn conn
(lambda (conn) (lambda (conn)
(match (lint-warning-message-data->lint-warning-message-ids conn data) (match (lint-warning-message-data->lint-warning-message-ids conn data)
(((? number? id1) (? number? id2)) (#((? number? id1) (? number? id2))
#t))) #t)))
#:always-rollback? #t)) #:always-rollback? #t))
@ -29,11 +29,11 @@
conn conn
(lambda (conn) (lambda (conn)
(match (lint-warning-message-data->lint-warning-message-ids conn data) (match (lint-warning-message-data->lint-warning-message-ids conn data)
(((? number? id1) (? number? id2)) (#((? number? id1) (? number? id2))
(match (lint-warning-message-data->lint-warning-message-ids conn data) (match (lint-warning-message-data->lint-warning-message-ids conn data)
(((? number? second-id1) (? number? second-id2)) (#((? number? second-id1) (? number? second-id2))
(and (eq? id1 second-id1) (and (= id1 second-id1)
(eq? id2 second-id2))))))) (= id2 second-id2)))))))
#:always-rollback? #t)) #:always-rollback? #t))
(test-assert "single set insert" (test-assert "single set insert"
@ -53,7 +53,7 @@
((? number? id) ((? number? id)
(match (lint-warning-message-data->lint-warning-message-set-id conn data) (match (lint-warning-message-data->lint-warning-message-set-id conn data)
((? number? second-id) ((? number? second-id)
(eq? id second-id)))))) (= id second-id))))))
#:always-rollback? #t)))) #:always-rollback? #t))))
(test-end) (test-end)

23
tests/model-package-metadata.scm
View file

@ -34,21 +34,22 @@
mock-inferior-package-foo-2)) mock-inferior-package-foo-2))
(define mock-package-metadata (define mock-package-metadata
(map (lambda (mock-inf-pkg) (list->vector
(list (map (lambda (mock-inf-pkg)
(mock-inferior-package-home-page mock-inf-pkg) (list
(mock-inferior-package-location mock-inf-pkg) (mock-inferior-package-home-page mock-inf-pkg)
`(("en_US.UTF-8" . "Fake synopsis")) (mock-inferior-package-location mock-inf-pkg)
`(("en_US.UTF-8" . "Fake description")))) `(("en_US.UTF-8" . "Fake synopsis"))
mock-inferior-packages)) `(("en_US.UTF-8" . "Fake description"))))
mock-inferior-packages)))
(define (test-license-set-ids conn) (define (test-license-set-ids conn)
(let ((license-id-lists (let ((license-id-lists
(inferior-packages->license-id-lists (inferior-packages->license-id-lists
conn conn
'((("License 1" '#((("License 1"
"https://gnu.org/licenses/test-1.html" "https://gnu.org/licenses/test-1.html"
"https://example.com/why-license-1")))))) "https://example.com/why-license-1"))))))
(inferior-packages->license-set-ids conn license-id-lists))) (inferior-packages->license-set-ids conn license-id-lists)))
@ -73,7 +74,7 @@
conn conn
mock-package-metadata mock-package-metadata
(test-license-set-ids conn)) (test-license-set-ids conn))
((x) (number? x)))) (#(x) (number? x))))
#:always-rollback? #t)) #:always-rollback? #t))
(with-postgresql-transaction (with-postgresql-transaction

50
tests/model-package.scm
View file

@ -36,9 +36,9 @@
(let ((license-id-lists (let ((license-id-lists
(inferior-packages->license-id-lists (inferior-packages->license-id-lists
conn conn
'((("License 1" '#((("License 1"
"https://gnu.org/licenses/test-1.html" "https://gnu.org/licenses/test-1.html"
"https://example.com/why-license-1")))))) "https://example.com/why-license-1"))))))
(inferior-packages->license-set-ids conn license-id-lists))) (inferior-packages->license-set-ids conn license-id-lists)))
@ -47,13 +47,14 @@
mock-inferior-package-foo-2)) mock-inferior-package-foo-2))
(define mock-package-metadata (define mock-package-metadata
(map (lambda (mock-inf-pkg) (list->vector
(list (map (lambda (mock-inf-pkg)
(mock-inferior-package-home-page mock-inf-pkg) (list
(mock-inferior-package-location mock-inf-pkg) (mock-inferior-package-home-page mock-inf-pkg)
`(("en_US.UTF-8" . "Fake synopsis")) (mock-inferior-package-location mock-inf-pkg)
`(("en_US.UTF-8" . "Fake description")))) `(("en_US.UTF-8" . "Fake synopsis"))
mock-inferior-packages)) `(("en_US.UTF-8" . "Fake description"))))
mock-inferior-packages)))
(with-mock-inferior-packages (with-mock-inferior-packages
(lambda () (lambda ()
@ -81,11 +82,12 @@
(cons "integer" NULL)))) (cons "integer" NULL))))
(match (inferior-packages->package-ids (match (inferior-packages->package-ids
conn conn
(zip (map mock-inferior-package-name mock-inferior-packages) (list->vector
(map mock-inferior-package-version mock-inferior-packages) (zip (map mock-inferior-package-name mock-inferior-packages)
package-metadata-ids (map mock-inferior-package-version mock-inferior-packages)
package-replacement-package-ids)) (vector->list package-metadata-ids)
((x) (number? x)))))) package-replacement-package-ids)))
(#(x) (number? x))))))
#:always-rollback? #t) #:always-rollback? #t)
(with-postgresql-transaction (with-postgresql-transaction
@ -102,16 +104,18 @@
(test-equal "inferior-packages->package-ids is idempotent" (test-equal "inferior-packages->package-ids is idempotent"
(inferior-packages->package-ids (inferior-packages->package-ids
conn conn
(zip (map mock-inferior-package-name mock-inferior-packages) (list->vector
(map mock-inferior-package-version mock-inferior-packages) (zip (map mock-inferior-package-name mock-inferior-packages)
package-metadata-ids (map mock-inferior-package-version mock-inferior-packages)
package-replacement-package-ids)) (vector->list package-metadata-ids)
package-replacement-package-ids)))
(inferior-packages->package-ids (inferior-packages->package-ids
conn conn
(zip (map mock-inferior-package-name mock-inferior-packages) (list->vector
(map mock-inferior-package-version mock-inferior-packages) (zip (map mock-inferior-package-name mock-inferior-packages)
package-metadata-ids (map mock-inferior-package-version mock-inferior-packages)
package-replacement-package-ids))))) (vector->list package-metadata-ids)
package-replacement-package-ids))))))
#:always-rollback? #t))))) #:always-rollback? #t)))))
(test-end) (test-end)