Christopher Baines
544f122ff5
Rather than just counting builds where the derivation matches, select builds based on the derivation outputs, which accounts for different but equivalent derivations.
892 lines
32 KiB
Scheme
892 lines
32 KiB
Scheme
(define-module (guix-data-service model derivation)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (ice-9 vlist)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (squee)
|
|
#:use-module (json)
|
|
#:use-module (guix base32)
|
|
#:use-module (guix inferior)
|
|
#:use-module (guix memoization)
|
|
#:use-module (guix derivations)
|
|
#:use-module (guix-data-service model utils)
|
|
#:export (valid-systems
|
|
count-derivations
|
|
select-derivation-by-file-name
|
|
select-derivation-outputs-by-derivation-id
|
|
select-derivation-sources-by-derivation-id
|
|
select-derivation-source-file-by-store-path
|
|
select-derivation-by-output-filename
|
|
select-derivations-using-output
|
|
select-derivations-in-revision
|
|
select-derivations-by-revision-name-and-version
|
|
select-derivation-inputs-by-derivation-id
|
|
select-existing-derivations
|
|
select-derivations-by-id
|
|
select-derivations-and-build-status
|
|
insert-into-derivations
|
|
derivation-file-names->derivation-ids))
|
|
|
|
(define (valid-systems conn)
|
|
(map car
|
|
(exec-query
|
|
conn
|
|
"SELECT DISTINCT system FROM derivations ORDER BY 1")))
|
|
|
|
(define (count-derivations conn)
|
|
(first
|
|
(exec-query
|
|
conn
|
|
"SELECT COUNT(*) FROM derivations")))
|
|
|
|
(define (select-existing-derivations file-names)
|
|
(string-append "SELECT id, file_name "
|
|
"FROM derivations "
|
|
"WHERE file_name IN "
|
|
"(" (string-join (map (lambda (file-name)
|
|
(simple-format #f "'~A'" file-name))
|
|
file-names)
|
|
",")
|
|
");"))
|
|
|
|
(define (select-from-derivation-output-details paths)
|
|
(string-append
|
|
"SELECT id, path FROM derivation_output_details "
|
|
"WHERE path IN ("
|
|
(string-join (map quote-string paths)
|
|
",")
|
|
")"))
|
|
|
|
(define (select-derivation-by-output-filename conn filename)
|
|
(define query
|
|
(string-append
|
|
"SELECT derivations.file_name, derivation_outputs.id "
|
|
"FROM derivation_output_details "
|
|
"INNER JOIN derivation_outputs"
|
|
" ON derivation_output_details.id = derivation_outputs.derivation_output_details_id "
|
|
"INNER JOIN derivations"
|
|
" ON derivation_outputs.derivation_id = derivations.id "
|
|
"WHERE derivation_output_details.path = $1"))
|
|
|
|
(exec-query conn query (list filename)))
|
|
|
|
(define (select-derivations-using-output conn output-id)
|
|
(define query
|
|
(string-append
|
|
"SELECT derivations.file_name "
|
|
"FROM derivations "
|
|
"INNER JOIN derivation_inputs"
|
|
" ON derivation_inputs.derivation_id = derivations.id "
|
|
"WHERE derivation_output_id = $1 "
|
|
"ORDER BY derivations.file_name "
|
|
"LIMIT 100 "))
|
|
|
|
(exec-query conn query (list output-id)))
|
|
|
|
(define (select-derivations-by-revision-name-and-version
|
|
conn revision-commit-hash name version)
|
|
(define query "
|
|
SELECT derivations.system, package_derivations.target, derivations.file_name,
|
|
latest_build_status.status
|
|
FROM derivations
|
|
INNER JOIN package_derivations
|
|
ON derivations.id = package_derivations.derivation_id
|
|
INNER JOIN packages
|
|
ON package_derivations.package_id = packages.id
|
|
INNER JOIN guix_revision_package_derivations
|
|
ON package_derivations.id = guix_revision_package_derivations.package_derivation_id
|
|
INNER JOIN guix_revisions
|
|
ON guix_revision_package_derivations.revision_id = guix_revisions.id
|
|
LEFT OUTER JOIN builds ON derivations.file_name = builds.derivation_file_name
|
|
LEFT OUTER JOIN (
|
|
SELECT DISTINCT ON (build_id) *
|
|
FROM build_status
|
|
ORDER BY build_id, timestamp DESC
|
|
) AS latest_build_status
|
|
ON builds.id = latest_build_status.build_id
|
|
WHERE guix_revisions.commit = $1
|
|
AND packages.name = $2
|
|
AND packages.version = $3
|
|
ORDER BY derivations.system DESC,
|
|
package_derivations.target DESC,
|
|
derivations.file_name")
|
|
|
|
(exec-query conn query (list revision-commit-hash name version)))
|
|
|
|
(define* (select-derivations-in-revision conn
|
|
commit-hash
|
|
#:key
|
|
systems
|
|
targets
|
|
minimum-builds
|
|
maximum-builds
|
|
limit-results
|
|
after-name)
|
|
(define criteria
|
|
(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))
|
|
'("derivations.system"
|
|
"target")
|
|
(list systems
|
|
targets))
|
|
,@(if minimum-builds
|
|
(list
|
|
(string-append
|
|
"
|
|
(
|
|
SELECT COUNT(*)
|
|
FROM builds
|
|
WHERE builds.derivation_output_details_set_id =
|
|
derivations_by_output_details_set.derivation_output_details_set_id
|
|
) >= "
|
|
(number->string minimum-builds)))
|
|
'())
|
|
,@(if maximum-builds
|
|
(list
|
|
(string-append
|
|
"
|
|
(
|
|
SELECT COUNT(*)
|
|
FROM builds
|
|
WHERE builds.derivation_output_details_set_id =
|
|
derivations_by_output_details_set.derivation_output_details_set_id
|
|
) <= "
|
|
(number->string maximum-builds)))
|
|
'()))
|
|
" AND "))
|
|
|
|
(define query
|
|
(string-append
|
|
"
|
|
SELECT derivations.file_name,
|
|
derivations.system,
|
|
package_derivations.target,
|
|
(
|
|
SELECT JSON_AGG(
|
|
json_build_object(
|
|
'build_server_id', builds.build_server_id,
|
|
'status', latest_build_status.status,
|
|
'timestamp', latest_build_status.timestamp,
|
|
'build_for_equivalent_derivation',
|
|
builds.derivation_file_name != derivations.file_name
|
|
)
|
|
ORDER BY latest_build_status.timestamp
|
|
)
|
|
FROM builds
|
|
INNER JOIN (
|
|
SELECT DISTINCT ON (build_id) *
|
|
FROM build_status
|
|
ORDER BY build_id, timestamp DESC
|
|
) AS latest_build_status
|
|
ON builds.id = latest_build_status.build_id
|
|
WHERE builds.derivation_output_details_set_id =
|
|
derivations_by_output_details_set.derivation_output_details_set_id
|
|
) AS builds,
|
|
(
|
|
SELECT
|
|
JSON_AGG(
|
|
json_build_object(
|
|
'output_name', derivation_outputs.name,
|
|
'output_path', derivation_output_details.path,
|
|
'nars',
|
|
(
|
|
SELECT JSON_AGG(
|
|
json_build_object(
|
|
'build_server_id', narinfo_fetch_records.build_server_id,
|
|
'hash_algorithm', nars.hash_algorithm,
|
|
'hash', nars.hash,
|
|
'size', nars.size
|
|
)
|
|
)
|
|
FROM nars
|
|
INNER JOIN narinfo_signatures
|
|
ON nars.id = narinfo_signatures.nar_id
|
|
INNER JOIN narinfo_signature_data
|
|
ON narinfo_signature_data.id = narinfo_signatures.narinfo_signature_data_id
|
|
INNER JOIN narinfo_fetch_records
|
|
ON narinfo_signature_data.id = narinfo_fetch_records.narinfo_signature_data_id
|
|
WHERE nars.store_path = derivation_output_details.path
|
|
)
|
|
)
|
|
)
|
|
FROM derivation_output_details
|
|
INNER JOIN derivation_outputs
|
|
ON derivation_output_details.id = derivation_outputs.derivation_output_details_id
|
|
WHERE derivation_outputs.derivation_id = derivations.id
|
|
) AS outputs
|
|
FROM derivations
|
|
INNER JOIN derivations_by_output_details_set
|
|
ON derivations.id = derivations_by_output_details_set.derivation_id
|
|
INNER JOIN package_derivations
|
|
ON derivations.id = package_derivations.derivation_id
|
|
INNER JOIN guix_revision_package_derivations
|
|
ON package_derivations.id = guix_revision_package_derivations.package_derivation_id
|
|
INNER JOIN guix_revisions
|
|
ON guix_revision_package_derivations.revision_id = guix_revisions.id
|
|
INNER JOIN packages
|
|
ON package_derivations.package_id = packages.id
|
|
WHERE guix_revisions.commit = $1
|
|
"
|
|
(if after-name
|
|
" AND derivations.file_name > $2"
|
|
"")
|
|
(if (string-null? criteria)
|
|
""
|
|
(string-append " AND " criteria))
|
|
"
|
|
ORDER BY derivations.file_name
|
|
"
|
|
(if limit-results
|
|
(string-append
|
|
" LIMIT " (number->string limit-results))
|
|
"")))
|
|
|
|
(map (match-lambda
|
|
((file_name system target builds outputs)
|
|
(list file_name
|
|
system
|
|
target
|
|
(if (string-null? builds)
|
|
#()
|
|
(json-string->scm builds))
|
|
(if (string-null? outputs)
|
|
#()
|
|
(json-string->scm outputs)))))
|
|
(exec-query conn
|
|
query
|
|
`(,commit-hash
|
|
,@(if after-name
|
|
(list after-name)
|
|
'())))))
|
|
|
|
(define (insert-derivation-outputs conn
|
|
derivation-id
|
|
names-and-derivation-outputs)
|
|
(define (insert-into-derivation-output-details derivation-outputs)
|
|
(string-append
|
|
"INSERT INTO derivation_output_details "
|
|
"(path, hash_algorithm, hash, recursive) VALUES "
|
|
(string-join
|
|
(map
|
|
(match-lambda
|
|
(($ <derivation-output> path hash-algo hash recursive?)
|
|
(string-append
|
|
"("
|
|
(string-join
|
|
(list (quote-string path)
|
|
(value->quoted-string-or-null
|
|
(and=> hash-algo symbol->string))
|
|
(value->quoted-string-or-null
|
|
(and=> hash bytevector->nix-base32-string))
|
|
(if recursive? "TRUE" "FALSE"))
|
|
",")
|
|
")")))
|
|
derivation-outputs)
|
|
",")
|
|
" RETURNING id"
|
|
";"))
|
|
|
|
(define (insert-into-derivation-outputs output-names
|
|
derivation-output-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 (select-derivation-output-details-sets-id derivation-output-details-ids)
|
|
(match (exec-query
|
|
conn
|
|
(string-append
|
|
"
|
|
SELECT id
|
|
FROM derivation_output_details_sets
|
|
WHERE derivation_output_details_ids = ARRAY["
|
|
(string-join (map number->string
|
|
derivation-output-details-ids)
|
|
",")
|
|
"]"))
|
|
(((id))
|
|
(string->number id))
|
|
(_ #f)))
|
|
|
|
(define (insert-into-derivation-output-details-sets
|
|
derivation-output-details-ids)
|
|
(match (exec-query
|
|
conn
|
|
(string-append
|
|
"
|
|
INSERT INTO derivation_output_details_sets (derivation_output_details_ids)
|
|
VALUES (ARRAY["
|
|
(string-join (map number->string derivation-output-details-ids)
|
|
",")
|
|
"])
|
|
RETURNING id"))
|
|
(((id))
|
|
(string->number id))))
|
|
|
|
(define (insert-into-derivations-by-output-details-set
|
|
derivation_output_details_set_id)
|
|
(exec-query
|
|
conn
|
|
"
|
|
INSERT INTO derivations_by_output_details_set
|
|
(derivation_id, derivation_output_details_set_id)
|
|
VALUES ($1, $2)"
|
|
(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))
|
|
|
|
(existing-derivation-output-details-entries
|
|
(exec-query->vhash
|
|
conn
|
|
(select-from-derivation-output-details
|
|
derivation-output-paths)
|
|
second ;; path
|
|
first)) ;; id
|
|
|
|
(missing-entries (filter
|
|
(lambda (derivation-output)
|
|
(not (vhash-assoc
|
|
(derivation-output-path derivation-output)
|
|
existing-derivation-output-details-entries)))
|
|
derivation-outputs))
|
|
|
|
(new-derivation-output-details-ids
|
|
(if (null? missing-entries)
|
|
'()
|
|
(map car
|
|
(exec-query
|
|
conn
|
|
(insert-into-derivation-output-details missing-entries)))))
|
|
|
|
(new-entries-id-lookup-vhash
|
|
(two-lists->vhash (map derivation-output-path missing-entries)
|
|
new-derivation-output-details-ids))
|
|
|
|
(derivation-output-details-ids
|
|
(map (lambda (path)
|
|
(string->number
|
|
(cdr
|
|
(or (vhash-assoc path
|
|
existing-derivation-output-details-entries)
|
|
(vhash-assoc path
|
|
new-entries-id-lookup-vhash)
|
|
(error "missing derivation output details entry")))))
|
|
derivation-output-paths))
|
|
|
|
(derivation-output-names
|
|
(map car names-and-derivation-outputs)))
|
|
|
|
(exec-query conn
|
|
(insert-into-derivation-outputs derivation-output-names
|
|
derivation-output-details-ids))
|
|
|
|
(insert-into-derivations-by-output-details-set
|
|
(or
|
|
(select-derivation-output-details-sets-id derivation-output-details-ids)
|
|
(insert-into-derivation-output-details-sets derivation-output-details-ids)))
|
|
|
|
derivation-output-details-ids))
|
|
|
|
(define (select-derivation-by-file-name conn file-name)
|
|
(define query
|
|
(string-append
|
|
"SELECT id, file_name, builder, args, to_json(env_vars), system "
|
|
"FROM derivations "
|
|
"WHERE file_name = $1"))
|
|
|
|
(match (exec-query conn query (list file-name))
|
|
(()
|
|
#f)
|
|
(((id file_name builder args env_vars system))
|
|
(list (string->number id)
|
|
file-name
|
|
builder
|
|
(parse-postgresql-array-string args)
|
|
(map (match-lambda
|
|
(#(key value)
|
|
`((key . ,key)
|
|
(value . ,value))))
|
|
(vector->list (json-string->scm env_vars)))
|
|
system))))
|
|
|
|
(define select-derivation-output-id
|
|
(mlambda (conn name path)
|
|
(match (exec-query
|
|
conn
|
|
(string-append
|
|
"SELECT derivation_outputs.id FROM derivation_outputs "
|
|
"INNER JOIN derivations ON "
|
|
"derivation_outputs.derivation_id = derivations.id "
|
|
"WHERE derivations.file_name = '" path "' "
|
|
"AND derivation_outputs.name = '" name "';"))
|
|
(((id))
|
|
id)
|
|
(()
|
|
(error (simple-format
|
|
#f "cannot find derivation-output with name ~A and path ~A"
|
|
name path))))))
|
|
|
|
(define (select-derivation-outputs-by-derivation-id conn id)
|
|
(define query
|
|
(string-append
|
|
"SELECT derivation_outputs.name, derivation_output_details.path, "
|
|
"derivation_output_details.hash_algorithm, derivation_output_details.hash, "
|
|
"derivation_output_details.recursive "
|
|
"FROM derivation_outputs "
|
|
"INNER JOIN derivation_output_details ON "
|
|
"derivation_outputs.derivation_output_details_id = derivation_output_details.id "
|
|
"WHERE derivation_id = $1"))
|
|
|
|
(map
|
|
(match-lambda
|
|
((name path hash_algorithm hash recursive)
|
|
(list name
|
|
path
|
|
hash_algorithm
|
|
hash
|
|
(string=? recursive "t"))))
|
|
(exec-query conn query (list (number->string id)))))
|
|
|
|
(define (select-derivation-inputs-by-derivation-id conn id)
|
|
(define query
|
|
(string-append
|
|
"
|
|
SELECT derivations.file_name, derivation_outputs.name,
|
|
derivation_output_details.path
|
|
FROM derivation_inputs
|
|
INNER JOIN derivation_outputs
|
|
ON derivation_outputs.id = derivation_inputs.derivation_output_id
|
|
INNER JOIN derivation_output_details
|
|
ON derivation_outputs.derivation_output_details_id = derivation_output_details.id
|
|
INNER JOIN derivations
|
|
ON derivation_outputs.derivation_id = derivations.id
|
|
WHERE derivation_inputs.derivation_id = $1
|
|
ORDER BY derivations.file_name"))
|
|
|
|
(exec-query conn query (list (number->string id))))
|
|
|
|
(define (select-derivation-sources-by-derivation-id conn id)
|
|
(define query
|
|
(string-append
|
|
"
|
|
SELECT derivation_source_files.store_path
|
|
FROM derivation_source_files
|
|
INNER JOIN derivation_sources
|
|
ON derivation_source_files.id = derivation_sources.derivation_source_file_id
|
|
WHERE derivation_sources.derivation_id = $1
|
|
ORDER BY 1"))
|
|
|
|
(map first
|
|
(exec-query conn query (list (number->string id)))))
|
|
|
|
(define (select-derivation-source-file-by-store-path conn store-path)
|
|
(define query
|
|
"
|
|
SELECT id
|
|
FROM derivation_source_files
|
|
WHERE store_path = $1")
|
|
|
|
(map car (exec-query conn query (list store-path))))
|
|
|
|
(define (insert-derivation-inputs conn derivation-id derivation-inputs)
|
|
(define (insert-into-derivation-inputs output-ids)
|
|
(string-append "INSERT INTO derivation_inputs "
|
|
"(derivation_id, derivation_output_id) VALUES "
|
|
(string-join
|
|
(map (lambda (output-id)
|
|
(simple-format
|
|
#f "(~A, ~A)"
|
|
derivation-id output-id))
|
|
output-ids)
|
|
",")
|
|
";"))
|
|
|
|
(unless (null? derivation-inputs)
|
|
(exec-query
|
|
conn
|
|
(insert-into-derivation-inputs
|
|
(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)
|
|
(select-derivation-output-id conn
|
|
sub-derivation
|
|
path))
|
|
sub-derivations))))
|
|
derivation-inputs)))))
|
|
|
|
(define (select-from-derivation-source-files store-paths)
|
|
(string-append
|
|
"SELECT id, store_path FROM derivation_source_files "
|
|
"WHERE store_path IN ("
|
|
(string-join (map quote-string store-paths)
|
|
",")
|
|
");"))
|
|
|
|
(define (insert-derivation-sources conn derivation-id sources)
|
|
(define (insert-into-derivation-source-files store-paths)
|
|
(string-append
|
|
"INSERT INTO derivation_source_files (store_path) VALUES "
|
|
(string-join
|
|
(map (lambda (store-path)
|
|
(simple-format
|
|
#f "('~A')" store-path))
|
|
store-paths)
|
|
",")
|
|
" RETURNING id"
|
|
";"))
|
|
|
|
(define (insert-into-derivation-sources derivation-source-file-ids)
|
|
(string-append
|
|
"INSERT INTO derivation_sources "
|
|
"(derivation_id, derivation_source_file_id) VALUES "
|
|
(string-join
|
|
(map (lambda (derivation-source-file-id)
|
|
(simple-format
|
|
#f "(~A, ~A)" derivation-id derivation-source-file-id))
|
|
derivation-source-file-ids)
|
|
",")
|
|
";"))
|
|
|
|
(let* ((existing-derivation-store-paths
|
|
(exec-query->vhash
|
|
conn
|
|
(select-from-derivation-source-files sources)
|
|
second ;; store_path
|
|
first)) ;; id
|
|
|
|
(missing-entries (filter
|
|
(lambda (store-path)
|
|
(not (vhash-assoc store-path
|
|
existing-derivation-store-paths)))
|
|
sources))
|
|
|
|
(new-derivation-source-file-entries
|
|
(if (null? missing-entries)
|
|
'()
|
|
(exec-query conn
|
|
(insert-into-derivation-source-files missing-entries))))
|
|
|
|
(new-entries-id-lookup-vhash
|
|
(two-lists->vhash missing-entries
|
|
new-derivation-source-file-entries))
|
|
|
|
(sources-ids
|
|
(map (lambda (store-path)
|
|
(cdr
|
|
(or (vhash-assoc store-path
|
|
existing-derivation-store-paths)
|
|
(vhash-assoc store-path
|
|
new-entries-id-lookup-vhash)
|
|
(error "missing derivation source files entry"))))
|
|
sources)))
|
|
|
|
(exec-query conn
|
|
(insert-into-derivation-sources sources-ids))))
|
|
|
|
(define (insert-missing-derivations conn
|
|
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))
|
|
(let* ((existing-derivation-entries
|
|
(derivation-file-names->vhash conn
|
|
derivation-ids-hash-table
|
|
input-derivation-file-names))
|
|
|
|
(missing-derivations-filenames
|
|
(filter (lambda (derivation-file-name)
|
|
(not (vhash-assoc derivation-file-name
|
|
existing-derivation-entries)))
|
|
input-derivation-file-names)))
|
|
|
|
(unless (null? missing-derivations-filenames)
|
|
;; 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)
|
|
(string-append
|
|
"INSERT INTO derivations "
|
|
"(file_name, builder, args, env_vars, system) VALUES "
|
|
(string-join
|
|
(map (match-lambda
|
|
(($ <derivation> outputs inputs sources
|
|
system builder args env-vars file-name)
|
|
(simple-format
|
|
#f "('~A', '~A', ARRAY[~A]::varchar[], ARRAY[~A], '~A')"
|
|
file-name
|
|
builder
|
|
(string-join (map quote-string args) ",")
|
|
(string-join (map (match-lambda
|
|
((key . value)
|
|
(string-append
|
|
"['" key '"', $$"
|
|
value "$$ ]")))
|
|
env-vars)
|
|
",")
|
|
system)))
|
|
derivations)
|
|
",")
|
|
" RETURNING id"
|
|
";"))
|
|
|
|
(simple-format
|
|
#t "debug: insert-missing-derivations: inserting ~A derivations\n"
|
|
(length derivations))
|
|
(let ((derivation-ids
|
|
(map (lambda (result)
|
|
(string->number (car result)))
|
|
(exec-query conn (insert-into-derivations)))))
|
|
|
|
(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)
|
|
(insert-derivation-sources conn
|
|
derivation-id
|
|
(derivation-sources derivation)))
|
|
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))))
|
|
|
|
(simple-format
|
|
#t "debug: insert-missing-derivations: inserting inputs\n")
|
|
(for-each (lambda (derivation-id derivation)
|
|
(insert-derivation-inputs conn
|
|
derivation-id
|
|
(derivation-inputs derivation)))
|
|
|
|
derivation-ids
|
|
derivations)
|
|
|
|
derivation-ids))
|
|
|
|
(define (select-derivations-by-id conn ids)
|
|
(define query
|
|
(string-append "SELECT id, file_name "
|
|
"FROM derivations "
|
|
"WHERE id IN "
|
|
"(" (string-join (map (lambda (id)
|
|
(simple-format #f "'~A'" id))
|
|
ids)
|
|
",")
|
|
");"))
|
|
|
|
(exec-query conn query))
|
|
|
|
(define* (select-derivations-and-build-status conn #:key
|
|
file-names
|
|
systems
|
|
targets
|
|
build-statuses)
|
|
(define criteria
|
|
(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))
|
|
'("derivations.file_name"
|
|
"derivations.system"
|
|
"target"
|
|
"latest_build_status.status")
|
|
(list (deduplicate-strings file-names)
|
|
systems
|
|
targets
|
|
build-statuses))
|
|
" AND "))
|
|
|
|
(define query
|
|
(string-append
|
|
"
|
|
SELECT
|
|
derivations.file_name,
|
|
derivations.system,
|
|
package_derivations.target,
|
|
latest_build_status.status
|
|
FROM derivations
|
|
INNER JOIN package_derivations
|
|
ON derivations.id = package_derivations.derivation_id
|
|
LEFT OUTER JOIN builds
|
|
ON derivations.file_name = builds.derivation_file_name
|
|
LEFT OUTER JOIN (
|
|
SELECT DISTINCT ON (build_id) *
|
|
FROM build_status
|
|
ORDER BY build_id, timestamp DESC
|
|
) AS latest_build_status
|
|
ON builds.id = latest_build_status.build_id
|
|
WHERE " criteria ";"))
|
|
|
|
(exec-query conn query))
|
|
|
|
(define (deduplicate-derivations derivations)
|
|
(define sorted-derivations
|
|
(sort derivations
|
|
(lambda (a b)
|
|
(string<? (derivation-file-name a)
|
|
(derivation-file-name b)))))
|
|
|
|
(pair-fold
|
|
(match-lambda*
|
|
(((x) result)
|
|
(cons x result))
|
|
(((x y rest ...) result)
|
|
(if (string=? (derivation-file-name x)
|
|
(derivation-file-name y))
|
|
result
|
|
(cons x result))))
|
|
'()
|
|
sorted-derivations))
|
|
|
|
(define (derivation-file-names->vhash conn derivation-ids-hash-table file-names)
|
|
(simple-format #t "debug: derivation-file-names->vhash: ~A file-names\n"
|
|
(length file-names))
|
|
(match (fold (match-lambda*
|
|
((file-name (result . missing-file-names))
|
|
(let ((cached-id (hash-ref derivation-ids-hash-table
|
|
file-name)))
|
|
(if cached-id
|
|
(cons (vhash-cons file-name cached-id result)
|
|
missing-file-names)
|
|
(cons result
|
|
(cons file-name missing-file-names))))))
|
|
(cons vlist-null '())
|
|
file-names)
|
|
((result)
|
|
(simple-format
|
|
#t "debug: derivation-file-names->vhash: lookup ~A file-names, all found\n"
|
|
(length file-names))
|
|
result)
|
|
((result . missing-file-names)
|
|
(simple-format
|
|
#t "debug: derivation-file-names->vhash: lookup ~A file-names, ~A not cached\n"
|
|
(length file-names) (length missing-file-names))
|
|
(let ((result-for-missing-file-names
|
|
(exec-query->vhash
|
|
conn
|
|
(select-existing-derivations missing-file-names)
|
|
second ;; file_name
|
|
(lambda (result)
|
|
(string->number (first result)))))) ;; id
|
|
(simple-format
|
|
#t "debug: derivation-file-names->vhash: adding ~A entries to the cache\n"
|
|
(vlist-length result-for-missing-file-names))
|
|
(vhash-fold (lambda (key value _)
|
|
(hash-set! derivation-ids-hash-table key value))
|
|
'()
|
|
result-for-missing-file-names)
|
|
|
|
(vhash-fold
|
|
(lambda (key value combined)
|
|
(vhash-cons key value combined))
|
|
result
|
|
result-for-missing-file-names)))))
|
|
|
|
(define (derivation-file-names->derivation-ids conn derivation-file-names)
|
|
(if (null? derivation-file-names)
|
|
'()
|
|
(let* ((derivations-count (length derivation-file-names))
|
|
(derivation-ids-hash-table (make-hash-table derivations-count)))
|
|
(simple-format
|
|
#t "debug: derivation-file-names->derivation-ids: processing ~A derivations\n"
|
|
derivations-count)
|
|
(let* ((existing-derivation-entries
|
|
(derivation-file-names->vhash conn
|
|
derivation-ids-hash-table
|
|
derivation-file-names))
|
|
|
|
(missing-derivations
|
|
(map read-derivation-from-file
|
|
(deduplicate-strings
|
|
(filter (lambda (derivation-file-name)
|
|
(not (vhash-assoc derivation-file-name
|
|
existing-derivation-entries)))
|
|
derivation-file-names))))
|
|
|
|
(new-derivation-entries
|
|
(if (null? missing-derivations)
|
|
'()
|
|
(insert-missing-derivations conn
|
|
derivation-ids-hash-table
|
|
missing-derivations)))
|
|
|
|
(new-entries-id-lookup-vhash
|
|
(two-lists->vhash (map derivation-file-name missing-derivations)
|
|
new-derivation-entries)))
|
|
|
|
(map (lambda (derivation-file-name)
|
|
(cdr
|
|
(or (vhash-assoc derivation-file-name
|
|
existing-derivation-entries)
|
|
(vhash-assoc derivation-file-name
|
|
new-entries-id-lookup-vhash)
|
|
(error "missing derivation id"))))
|
|
derivation-file-names)))))
|