Move inserting derivations in to the load-new-guix-revision module
And start to more closely integrate it. This makes it possible to start making it faster by doing more in parallel.
This commit is contained in:
parent
7f746b358b
commit
77962f7c2c
4 changed files with 502 additions and 422 deletions
|
|
@ -25,13 +25,18 @@
|
|||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (ice-9 hash-table)
|
||||
#:use-module (ice-9 suspendable-ports)
|
||||
#:use-module (ice-9 binary-ports)
|
||||
#:use-module ((ice-9 ports internal) #:select (port-poll))
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (rnrs exceptions)
|
||||
#:use-module (lzlib)
|
||||
#:use-module (json)
|
||||
#:use-module (squee)
|
||||
#:use-module (gcrypt hash)
|
||||
#:use-module (fibers)
|
||||
#:use-module (fibers channels)
|
||||
#:use-module (guix monads)
|
||||
#:use-module (guix base32)
|
||||
#:use-module (guix store)
|
||||
#:use-module (guix channels)
|
||||
#:use-module (guix inferior)
|
||||
|
|
@ -41,6 +46,7 @@
|
|||
#:use-module (guix progress)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix serialization)
|
||||
#:use-module (guix build utils)
|
||||
#:use-module ((guix build syscalls)
|
||||
#:select (set-thread-name))
|
||||
|
|
@ -49,6 +55,7 @@
|
|||
#:use-module (guix-data-service utils)
|
||||
#:use-module (guix-data-service model utils)
|
||||
#:use-module (guix-data-service model build)
|
||||
#:use-module (guix-data-service model system)
|
||||
#:use-module (guix-data-service model channel-instance)
|
||||
#:use-module (guix-data-service model channel-news)
|
||||
#:use-module (guix-data-service model package)
|
||||
|
|
@ -477,10 +484,7 @@
|
|||
(package-derivation store package system))))
|
||||
;; You don't always get what you ask for, so check
|
||||
(if (string=? system (derivation-system derivation))
|
||||
(let ((file-name
|
||||
(derivation-file-name derivation)))
|
||||
(add-temp-root store file-name)
|
||||
file-name)
|
||||
(derivation-file-name derivation)
|
||||
(begin
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
|
|
@ -907,6 +911,294 @@
|
|||
lint-checker-ids
|
||||
lint-warnings-data)))
|
||||
|
||||
(define (update-derivation-ids-hash-table! conn
|
||||
derivation-ids-hash-table
|
||||
file-names)
|
||||
(define file-names-count (vector-length file-names))
|
||||
|
||||
(simple-format #t "debug: update-derivation-ids-hash-table!: ~A file-names\n"
|
||||
file-names-count)
|
||||
(let ((missing-file-names
|
||||
(vector-fold
|
||||
(lambda (_ result file-name)
|
||||
(if (and file-name
|
||||
(hash-ref derivation-ids-hash-table
|
||||
file-name))
|
||||
result
|
||||
(cons file-name result)))
|
||||
'()
|
||||
file-names)))
|
||||
|
||||
(simple-format
|
||||
#t "debug: update-derivation-ids-hash-table!: lookup ~A file-names, ~A not cached\n"
|
||||
file-names-count (length missing-file-names))
|
||||
|
||||
(unless (null? missing-file-names)
|
||||
(for-each
|
||||
(lambda (chunk)
|
||||
(for-each
|
||||
(match-lambda
|
||||
((id file-name)
|
||||
(hash-set! derivation-ids-hash-table
|
||||
file-name
|
||||
(string->number id))))
|
||||
(exec-query conn (select-existing-derivations chunk))))
|
||||
(chunk! missing-file-names 1000)))))
|
||||
|
||||
(define (insert-missing-derivations postgresql-connection-pool
|
||||
utility-thread-channel
|
||||
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))
|
||||
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(update-derivation-ids-hash-table! conn
|
||||
derivation-ids-hash-table
|
||||
(list->vector
|
||||
input-derivation-file-names)))
|
||||
(simple-format
|
||||
#t
|
||||
"debug: ensure-input-derivations-exist: checking for missing input derivations\n")
|
||||
(let ((missing-derivations-filenames
|
||||
(remove (lambda (derivation-file-name)
|
||||
(hash-ref derivation-ids-hash-table
|
||||
derivation-file-name))
|
||||
input-derivation-file-names)))
|
||||
|
||||
(unless (null? missing-derivations-filenames)
|
||||
(simple-format
|
||||
#f
|
||||
"debug: ensure-input-derivations-exist: inserting missing input derivations\n")
|
||||
;; Ensure all the input derivations exist
|
||||
(insert-missing-derivations
|
||||
postgresql-connection-pool
|
||||
utility-thread-channel
|
||||
derivation-ids-hash-table
|
||||
(call-with-worker-thread
|
||||
utility-thread-channel
|
||||
(lambda ()
|
||||
(map read-derivation-from-file
|
||||
missing-derivations-filenames))))))))
|
||||
|
||||
(define (insert-into-derivations conn drvs)
|
||||
(string-append
|
||||
"INSERT INTO derivations "
|
||||
"(file_name, builder, args, env_vars, system_id) VALUES "
|
||||
(string-join
|
||||
(map (match-lambda
|
||||
(($ <derivation> outputs inputs sources
|
||||
system builder args env-vars file-name)
|
||||
(simple-format
|
||||
#f "('~A', '~A', ARRAY[~A]::varchar[], ARRAY[~A], '~A')"
|
||||
file-name
|
||||
builder
|
||||
(string-join (map quote-string args) ",")
|
||||
(string-join (map (match-lambda
|
||||
((key . value)
|
||||
(string-append
|
||||
"['" key '"', $$"
|
||||
value "$$ ]")))
|
||||
env-vars)
|
||||
",")
|
||||
(system->system-id conn system))))
|
||||
drvs)
|
||||
",")
|
||||
" RETURNING id"
|
||||
";"))
|
||||
|
||||
(with-time-logging
|
||||
(simple-format
|
||||
#f "insert-missing-derivations: inserting ~A derivations"
|
||||
(length derivations))
|
||||
(let* ((chunks (chunk derivations 500))
|
||||
(derivation-ids
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(append-map!
|
||||
(lambda (chunk)
|
||||
(map (lambda (result)
|
||||
(string->number (car result)))
|
||||
(exec-query conn (insert-into-derivations conn chunk))))
|
||||
chunks))))
|
||||
|
||||
(with-time-logging
|
||||
"insert-missing-derivations: updating hash table"
|
||||
(for-each (lambda (derivation derivation-id)
|
||||
(hash-set! derivation-ids-hash-table
|
||||
(derivation-file-name derivation)
|
||||
derivation-id))
|
||||
derivations
|
||||
derivation-ids))
|
||||
|
||||
(with-time-logging
|
||||
"insert-missing-derivations: inserting sources"
|
||||
(for-each
|
||||
(lambda (derivation-id derivation)
|
||||
(let ((sources (derivation-sources derivation)))
|
||||
(unless (null? sources)
|
||||
(let ((sources-ids
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(insert-derivation-sources conn
|
||||
derivation-id
|
||||
sources))))
|
||||
(par-map&
|
||||
(lambda (id source-file)
|
||||
(match
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(exec-query
|
||||
conn
|
||||
"
|
||||
SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
|
||||
(list (number->string id))))
|
||||
(()
|
||||
(let ((nar-bytevector
|
||||
(call-with-worker-thread
|
||||
utility-thread-channel
|
||||
(lambda ()
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(open-bytevector-output-port))
|
||||
(lambda (port get-bytevector)
|
||||
(write-file source-file port)
|
||||
(get-bytevector)))))))
|
||||
(letpar&
|
||||
((compressed-nar-bytevector
|
||||
(call-with-worker-thread
|
||||
utility-thread-channel
|
||||
(lambda ()
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(open-bytevector-output-port))
|
||||
(lambda (port get-bytevector)
|
||||
(call-with-lzip-output-port port
|
||||
(lambda (port)
|
||||
(put-bytevector port nar-bytevector))
|
||||
#:level 9)
|
||||
(get-bytevector))))))
|
||||
(hash
|
||||
(call-with-worker-thread
|
||||
utility-thread-channel
|
||||
(lambda ()
|
||||
(bytevector->nix-base32-string
|
||||
(sha256 nar-bytevector)))))
|
||||
(uncompressed-size (bytevector-length nar-bytevector)))
|
||||
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(insert-derivation-source-file-nar
|
||||
conn
|
||||
id
|
||||
hash
|
||||
compressed-nar-bytevector
|
||||
uncompressed-size)))))
|
||||
(_ #f)))
|
||||
sources-ids
|
||||
sources)))))
|
||||
derivation-ids
|
||||
derivations))
|
||||
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(with-time-logging
|
||||
"insert-missing-derivations: inserting outputs"
|
||||
(for-each (lambda (derivation-id derivation)
|
||||
(insert-derivation-outputs conn
|
||||
derivation-id
|
||||
(derivation-outputs derivation)))
|
||||
derivation-ids
|
||||
derivations)))
|
||||
|
||||
(with-time-logging
|
||||
"insert-missing-derivations: ensure-input-derivations-exist"
|
||||
(ensure-input-derivations-exist (deduplicate-strings
|
||||
(map derivation-input-path
|
||||
(append-map derivation-inputs
|
||||
derivations)))))
|
||||
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(with-time-logging
|
||||
(simple-format
|
||||
#f "insert-missing-derivations: inserting inputs for ~A derivations"
|
||||
(length derivations))
|
||||
(insert-derivation-inputs conn
|
||||
derivation-ids
|
||||
derivations))))))
|
||||
|
||||
(define (derivation-file-names->derivation-ids postgresql-connection-pool
|
||||
utility-thread-channel
|
||||
derivation-file-names)
|
||||
(define derivations-count
|
||||
(vector-length derivation-file-names))
|
||||
|
||||
(if (= 0 derivations-count)
|
||||
#()
|
||||
(let* ((derivation-ids-hash-table (make-hash-table
|
||||
;; Account for more derivations in
|
||||
;; the graph
|
||||
(* 2 derivations-count))))
|
||||
(simple-format
|
||||
#t "debug: derivation-file-names->derivation-ids: processing ~A derivations\n"
|
||||
derivations-count)
|
||||
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(update-derivation-ids-hash-table! conn
|
||||
derivation-ids-hash-table
|
||||
derivation-file-names))
|
||||
|
||||
(let* ((missing-derivation-filenames
|
||||
(deduplicate-strings
|
||||
(vector-fold
|
||||
(lambda (_ result derivation-file-name)
|
||||
(if (not derivation-file-name)
|
||||
result
|
||||
(if (hash-ref derivation-ids-hash-table
|
||||
derivation-file-name)
|
||||
result
|
||||
(cons derivation-file-name result))))
|
||||
'()
|
||||
derivation-file-names)))
|
||||
(missing-derivations-chunked-promises
|
||||
(map
|
||||
(lambda (chunk)
|
||||
(fibers-delay
|
||||
(lambda ()
|
||||
(map read-derivation-from-file chunk))))
|
||||
(chunk! missing-derivation-filenames 1000))))
|
||||
|
||||
(for-each
|
||||
(lambda (missing-derivation-filenames-chunk)
|
||||
(let ((missing-derivations-chunk
|
||||
;; Do the filter again, since processing the last chunk
|
||||
;; might have inserted some of the derivations in this
|
||||
;; chunk
|
||||
(remove! (lambda (derivation)
|
||||
(hash-ref derivation-ids-hash-table
|
||||
(derivation-file-name
|
||||
derivation)))
|
||||
(fibers-force
|
||||
missing-derivation-filenames-chunk))))
|
||||
|
||||
(unless (null? missing-derivations-chunk)
|
||||
(insert-missing-derivations postgresql-connection-pool
|
||||
utility-thread-channel
|
||||
derivation-ids-hash-table
|
||||
missing-derivations-chunk))))
|
||||
missing-derivations-chunked-promises))
|
||||
|
||||
(let ((all-ids
|
||||
(vector-map
|
||||
(lambda (_ derivation-file-name)
|
||||
(if derivation-file-name
|
||||
(or (hash-ref derivation-ids-hash-table
|
||||
derivation-file-name)
|
||||
(error "missing derivation id"))
|
||||
#f))
|
||||
derivation-file-names)))
|
||||
|
||||
all-ids))))
|
||||
|
||||
(define guix-store-path
|
||||
(let ((store-path #f))
|
||||
(lambda (store)
|
||||
|
|
@ -1162,7 +1454,7 @@
|
|||
(cons inferior inferior-store)))
|
||||
parallelism
|
||||
#:min-size 0
|
||||
#:idle-seconds 10
|
||||
#:idle-seconds 30
|
||||
#:destructor (match-lambda
|
||||
((inferior . store)
|
||||
(close-inferior inferior)
|
||||
|
|
@ -1399,6 +1691,7 @@
|
|||
|
||||
(define* (extract-information-from db-conn guix-revision-id commit
|
||||
guix-source store-item
|
||||
utility-thread-channel
|
||||
#:key skip-system-tests?
|
||||
extra-inferior-environment-variables
|
||||
parallelism)
|
||||
|
|
@ -1454,25 +1747,29 @@
|
|||
1
|
||||
#:min-size 0))
|
||||
|
||||
(define packages-data-promise
|
||||
(fibers-delay
|
||||
(lambda ()
|
||||
(with-resource-from-pool inf-and-store-pool res
|
||||
(match res
|
||||
((inferior . inferior-store)
|
||||
(with-time-logging "getting all inferior package data"
|
||||
(let ((packages
|
||||
pkg-to-replacement-hash-table
|
||||
(inferior-packages-plus-replacements inferior)))
|
||||
(all-inferior-packages-data
|
||||
inferior
|
||||
packages
|
||||
pkg-to-replacement-hash-table)))))))))
|
||||
(define derivation-file-names->derivation-ids/fiberized
|
||||
(fiberize
|
||||
(lambda (derivation-file-names)
|
||||
(derivation-file-names->derivation-ids
|
||||
postgresql-connection-pool
|
||||
utility-thread-channel
|
||||
derivation-file-names))))
|
||||
|
||||
(define package-ids-promise
|
||||
(fibers-delay
|
||||
(lambda ()
|
||||
(let ((packages-data (fibers-force packages-data-promise)))
|
||||
(let ((packages-data
|
||||
(with-resource-from-pool inf-and-store-pool res
|
||||
(match res
|
||||
((inferior . inferior-store)
|
||||
(with-time-logging "getting all inferior package data"
|
||||
(let ((packages
|
||||
pkg-to-replacement-hash-table
|
||||
(inferior-packages-plus-replacements inferior)))
|
||||
(all-inferior-packages-data
|
||||
inferior
|
||||
packages
|
||||
pkg-to-replacement-hash-table))))))))
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(insert-packages conn packages-data))))))
|
||||
|
||||
|
|
@ -1534,94 +1831,99 @@
|
|||
|
||||
(define (extract-and-store-package-derivations)
|
||||
(define packages-count
|
||||
(vector-length
|
||||
(assq-ref (fibers-force packages-data-promise)
|
||||
'names)))
|
||||
(with-resource-from-pool inf-and-store-pool res
|
||||
(match res
|
||||
((inferior . inferior-store)
|
||||
(ensure-gds-inferior-packages-defined! inferior)
|
||||
|
||||
(define chunk-size 3000)
|
||||
(inferior-eval '(vector-length gds-inferior-packages) inferior)))))
|
||||
|
||||
(fibers-for-each
|
||||
(match-lambda
|
||||
((system . target)
|
||||
(let loop ((wal-bytes (stat:size (stat "/var/guix/db/db.sqlite-wal"))))
|
||||
(when (> wal-bytes (* 512 (expt 2 20)))
|
||||
(simple-format #t "debug: guix-daemon WAL is large (~A), waiting\n"
|
||||
wal-bytes)
|
||||
(define chunk-size 5000)
|
||||
|
||||
(sleep 30)
|
||||
(loop (stat:size (stat "/var/guix/db/db.sqlite-wal")))))
|
||||
(define (process-system-and-target system target)
|
||||
(let loop ((wal-bytes
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(stat:size (stat "/var/guix/db/db.sqlite-wal")))
|
||||
(lambda _ 0))))
|
||||
(when (> wal-bytes (* 512 (expt 2 20)))
|
||||
(simple-format #t "debug: guix-daemon WAL is large (~A), waiting\n"
|
||||
wal-bytes)
|
||||
|
||||
(sleep 30)
|
||||
(loop (catch #t
|
||||
(lambda ()
|
||||
(stat:size (stat "/var/guix/db/db.sqlite-wal")))
|
||||
(lambda _ 0)))))
|
||||
|
||||
(with-time-logging
|
||||
(simple-format #f "processing derivations for ~A" (cons system target))
|
||||
(let ((derivations-vector (make-vector packages-count)))
|
||||
(with-time-logging
|
||||
(simple-format #f "getting derivations for ~A" (cons system target))
|
||||
(let loop ((start-index 0))
|
||||
(if (>= (+ start-index chunk-size) packages-count)
|
||||
(let* ((remaining-count
|
||||
(- packages-count start-index))
|
||||
(chunk
|
||||
(with-resource-from-pool inf-and-store-pool res
|
||||
(match res
|
||||
((inferior . inferior-store)
|
||||
(ensure-gds-inferior-packages-defined! inferior)
|
||||
(let* ((count
|
||||
(if (>= (+ start-index chunk-size) packages-count)
|
||||
(- packages-count start-index)
|
||||
chunk-size))
|
||||
(chunk
|
||||
(with-resource-from-pool inf-and-store-pool res
|
||||
(match res
|
||||
((inferior . inferior-store)
|
||||
(ensure-gds-inferior-packages-defined! inferior)
|
||||
|
||||
(inferior-package-derivations
|
||||
inferior-store
|
||||
inferior
|
||||
system
|
||||
target
|
||||
start-index
|
||||
remaining-count))))))
|
||||
(vector-copy! derivations-vector
|
||||
start-index
|
||||
chunk))
|
||||
(let ((chunk
|
||||
(with-resource-from-pool inf-and-store-pool res
|
||||
(match res
|
||||
((inferior . inferior-store)
|
||||
(ensure-gds-inferior-packages-defined! inferior)
|
||||
(inferior-package-derivations
|
||||
inferior-store
|
||||
inferior
|
||||
system
|
||||
target
|
||||
start-index
|
||||
count))))))
|
||||
(vector-copy! derivations-vector
|
||||
start-index
|
||||
chunk)
|
||||
(unless (>= (+ start-index chunk-size) packages-count)
|
||||
(loop (+ start-index chunk-size))))))
|
||||
|
||||
(inferior-package-derivations
|
||||
inferior-store
|
||||
inferior
|
||||
system
|
||||
target
|
||||
start-index
|
||||
chunk-size))))))
|
||||
(vector-copy! derivations-vector
|
||||
start-index
|
||||
chunk)
|
||||
(loop (+ start-index chunk-size))))))
|
||||
(let* ((derivation-ids
|
||||
(with-time-logging
|
||||
(simple-format #f "derivation-file-names->derivation-ids (~A ~A)"
|
||||
system target)
|
||||
(derivation-file-names->derivation-ids/fiberized
|
||||
derivations-vector))))
|
||||
|
||||
(let ((package-ids (fibers-force package-ids-promise)))
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(let* ((derivation-ids
|
||||
(let* ((package-ids (fibers-force package-ids-promise))
|
||||
(package-derivation-ids
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(with-time-logging
|
||||
(simple-format #f "derivation-file-names->derivation-ids (~A ~A)"
|
||||
(simple-format #f "insert-package-derivations (~A ~A)"
|
||||
system target)
|
||||
(derivation-file-names->derivation-ids
|
||||
conn
|
||||
derivations-vector))))
|
||||
(insert-package-derivations conn
|
||||
system
|
||||
(or target "")
|
||||
package-ids
|
||||
derivation-ids)))))
|
||||
(chunk-for-each!
|
||||
(lambda (package-derivation-ids-chunk)
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(insert-guix-revision-package-derivations
|
||||
conn
|
||||
guix-revision-id
|
||||
package-derivation-ids-chunk)))
|
||||
2000
|
||||
package-derivation-ids))))))
|
||||
|
||||
(let ((package-derivation-ids
|
||||
(with-time-logging
|
||||
(simple-format #f "insert-package-derivations (~A ~A)"
|
||||
system target)
|
||||
(insert-package-derivations conn
|
||||
system
|
||||
(or target "")
|
||||
package-ids
|
||||
derivation-ids))))
|
||||
(chunk-for-each! (lambda (package-derivation-ids-chunk)
|
||||
(insert-guix-revision-package-derivations
|
||||
conn
|
||||
guix-revision-id
|
||||
package-derivation-ids-chunk))
|
||||
2000
|
||||
package-derivation-ids))))))))
|
||||
(with-resource-from-pool inf-and-store-pool res
|
||||
(match res
|
||||
((inferior . inferior-store)
|
||||
(inferior-fetch-system-target-pairs inferior)))))
|
||||
(let ((process-system-and-target/fiberized
|
||||
(fiberize process-system-and-target
|
||||
#:parallelism parallelism)))
|
||||
(par-map&
|
||||
(match-lambda
|
||||
((system . target)
|
||||
(process-system-and-target/fiberized system target)))
|
||||
(with-resource-from-pool inf-and-store-pool res
|
||||
(match res
|
||||
((inferior . inferior-store)
|
||||
(inferior-fetch-system-target-pairs inferior))))))
|
||||
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(with-time-logging
|
||||
|
|
@ -1635,7 +1937,7 @@
|
|||
(begin
|
||||
(simple-format #t "debug: skipping system tests\n")
|
||||
'())
|
||||
(let ((data
|
||||
(let ((data-with-derivation-file-names
|
||||
(with-resource-from-pool inf-and-store-pool res
|
||||
(match res
|
||||
((inferior . inferior-store)
|
||||
|
|
@ -1645,22 +1947,41 @@
|
|||
inferior-store
|
||||
guix-source
|
||||
commit)))))))
|
||||
(when data
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(insert-system-tests-for-guix-revision conn
|
||||
guix-revision-id
|
||||
data))))))
|
||||
(when data-with-derivation-file-names
|
||||
(let ((data-with-derivation-ids
|
||||
(map (match-lambda
|
||||
((name description derivation-file-names-by-system location-data)
|
||||
(list name
|
||||
description
|
||||
(let ((systems
|
||||
(map car derivation-file-names-by-system))
|
||||
(derivation-ids
|
||||
(derivation-file-names->derivation-ids/fiberized
|
||||
(list->vector
|
||||
(map cdr derivation-file-names-by-system)))))
|
||||
(map cons systems derivation-ids))
|
||||
location-data)))
|
||||
data-with-derivation-file-names)))
|
||||
(with-resource-from-pool postgresql-connection-pool conn
|
||||
(insert-system-tests-for-guix-revision
|
||||
conn
|
||||
guix-revision-id
|
||||
data-with-derivation-ids)))))))
|
||||
|
||||
(simple-format #t "debug: extract-information-from: ~A\n" store-path)
|
||||
(parallel-via-fibers
|
||||
(fibers-force package-ids-promise)
|
||||
(extract-and-store-lint-checkers-and-warnings)
|
||||
(extract-and-store-package-derivations)
|
||||
(extract-and-store-system-tests)))
|
||||
(with-time-logging
|
||||
(simple-format #f "extract-information-from: ~A\n" store-path)
|
||||
(parallel-via-fibers
|
||||
(fibers-force package-ids-promise)
|
||||
(extract-and-store-package-derivations)
|
||||
(extract-and-store-system-tests)
|
||||
(extract-and-store-lint-checkers-and-warnings)))
|
||||
|
||||
#t)
|
||||
|
||||
(prevent-inlining-for-tests extract-information-from)
|
||||
|
||||
(define (load-channel-instances git-repository-id commit
|
||||
(define (load-channel-instances utility-thread-channel
|
||||
git-repository-id commit
|
||||
channel-derivations-by-system)
|
||||
;; Load the channel instances in a different transaction, so that this can
|
||||
;; commit prior to the outer transaction
|
||||
|
|
@ -1685,19 +2006,35 @@
|
|||
(guix-revision-id
|
||||
(or existing-guix-revision-id
|
||||
(insert-guix-revision channel-instances-conn
|
||||
git-repository-id commit))))
|
||||
git-repository-id commit)))
|
||||
(postgresql-connection-pool
|
||||
(make-resource-pool
|
||||
(const channel-instances-conn)
|
||||
1
|
||||
#:min-size 0)))
|
||||
|
||||
(unless existing-guix-revision-id
|
||||
(insert-channel-instances channel-instances-conn
|
||||
guix-revision-id
|
||||
(filter-map
|
||||
(match-lambda
|
||||
((system . derivations)
|
||||
(and=>
|
||||
(assoc-ref derivations
|
||||
'manifest-entry-item)
|
||||
(lambda (drv)
|
||||
(cons system drv)))))
|
||||
channel-derivations-by-system))
|
||||
(let* ((derivations-by-system
|
||||
(filter-map
|
||||
(match-lambda
|
||||
((system . derivations)
|
||||
(and=>
|
||||
(assoc-ref derivations
|
||||
'manifest-entry-item)
|
||||
(lambda (drv)
|
||||
(cons system drv)))))
|
||||
channel-derivations-by-system))
|
||||
(derivation-ids
|
||||
(derivation-file-names->derivation-ids
|
||||
postgresql-connection-pool
|
||||
utility-thread-channel
|
||||
(list->vector (map cdr derivations-by-system)))))
|
||||
|
||||
(insert-channel-instances channel-instances-conn
|
||||
guix-revision-id
|
||||
(map cons
|
||||
(map car derivations-by-system)
|
||||
(vector->list derivation-ids))))
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"guix-data-service: saved the channel instance derivations to the database\n"))
|
||||
|
|
@ -1709,6 +2046,13 @@
|
|||
(define* (load-new-guix-revision conn git-repository-id commit
|
||||
#:key skip-system-tests? parallelism
|
||||
extra-inferior-environment-variables)
|
||||
(define utility-thread-channel
|
||||
(make-worker-thread-channel
|
||||
(const '())
|
||||
#:parallelism parallelism))
|
||||
|
||||
(%worker-thread-default-timeout #f)
|
||||
|
||||
(let* ((git-repository-fields
|
||||
(select-git-repository conn git-repository-id))
|
||||
(git-repository-url
|
||||
|
|
@ -1727,7 +2071,8 @@
|
|||
fetch-with-authentication?
|
||||
#:parallelism parallelism))
|
||||
(guix-revision-id
|
||||
(load-channel-instances git-repository-id commit
|
||||
(load-channel-instances utility-thread-channel
|
||||
git-repository-id commit
|
||||
channel-derivations-by-system)))
|
||||
(let ((store-item
|
||||
(channel-derivations-by-system->guix-store-item
|
||||
|
|
@ -1737,6 +2082,7 @@
|
|||
(extract-information-from conn
|
||||
guix-revision-id
|
||||
commit guix-source store-item
|
||||
utility-thread-channel
|
||||
#:skip-system-tests?
|
||||
skip-system-tests?
|
||||
#:extra-inferior-environment-variables
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue