Add compute-and-fix-broken-derivations-in-revision
It's an uphill struggle to generate these derivaitons to repair them in the database, so copy lots of the code to try and make this easier.
This commit is contained in:
parent
cdb3669a0a
commit
f9770b8d59
1 changed files with 343 additions and 98 deletions
|
|
@ -99,7 +99,8 @@
|
|||
|
||||
fix-derivation
|
||||
fix-derivation-source-file-nar
|
||||
find-broken-derivations-in-revision))
|
||||
find-broken-derivations-in-revision
|
||||
compute-and-fix-broken-derivations-in-revision))
|
||||
|
||||
(define inferior-package-id
|
||||
(@@ (guix inferior) inferior-package-id))
|
||||
|
|
@ -1386,6 +1387,11 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
|
||||
(define (find-broken-derivations-in-revision commit)
|
||||
(run-fibers
|
||||
(lambda ()
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(print-backtrace-and-exception/knots exn)
|
||||
(raise-exception exn))
|
||||
(lambda ()
|
||||
(concatenate!
|
||||
(fibers-batch-map
|
||||
|
|
@ -1394,7 +1400,7 @@ SELECT store_path FROM derivation_source_files WHERE id = $1"
|
|||
(with-postgresql-connection
|
||||
"fix"
|
||||
(lambda (conn)
|
||||
(peek system target)
|
||||
(simple-format #t "checking: ~A ~A\n" system target)
|
||||
(map
|
||||
car
|
||||
(exec-query
|
||||
|
|
@ -1424,11 +1430,250 @@ WHERE builder != 'builtin:download'
|
|||
(list-systems conn))
|
||||
(map (lambda (target)
|
||||
(list "x86_64-linux" target))
|
||||
(valid-targets conn))))))))
|
||||
(valid-targets conn))))))))))
|
||||
#:hz 0
|
||||
#:parallelism 1
|
||||
#:drain? #t))
|
||||
|
||||
(define* (compute-and-fix-broken-derivations-in-revision
|
||||
git-repository-id commit
|
||||
#:key
|
||||
(ignore-systems '())
|
||||
(ignore-targets '())
|
||||
(extra-inferior-environment-variables '())
|
||||
(parallelism 4))
|
||||
(let ((broken-derivations
|
||||
(find-broken-derivations-in-revision commit)))
|
||||
(run-fibers
|
||||
(lambda ()
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(print-backtrace-and-exception/knots exn)
|
||||
(raise-exception exn))
|
||||
(lambda ()
|
||||
(let* ((guix-source
|
||||
channel-derivations-by-system
|
||||
(with-postgresql-connection
|
||||
"channel->source-and-derivations-by-system"
|
||||
(lambda (conn)
|
||||
(let* ((git-repository-fields
|
||||
(select-git-repository conn git-repository-id))
|
||||
(git-repository-url
|
||||
(assq-ref git-repository-fields 'url))
|
||||
(fetch-with-authentication?
|
||||
(assq-ref git-repository-fields 'fetch-with-authentication?)))
|
||||
(channel->source-and-derivations-by-system
|
||||
conn
|
||||
(channel (name 'guix)
|
||||
(url git-repository-url)
|
||||
(commit commit))
|
||||
fetch-with-authentication?
|
||||
#:parallelism parallelism
|
||||
#:ignore-systems ignore-systems)))))
|
||||
(store-item
|
||||
guix-derivation
|
||||
(channel-derivations-by-system->guix-store-item
|
||||
channel-derivations-by-system))
|
||||
(guix-locpath
|
||||
;; Augment the GUIX_LOCPATH to include glibc-locales from
|
||||
;; the Guix at store-path, this should mean that the
|
||||
;; inferior Guix works, even if it's build using a different
|
||||
;; glibc version
|
||||
(string-append
|
||||
(with-store-connection
|
||||
(lambda (store)
|
||||
(glibc-locales-for-guix-store-path store store-item)))
|
||||
"/lib/locale"
|
||||
":" (getenv "GUIX_LOCPATH"))))
|
||||
|
||||
(define inf-and-store-pool
|
||||
(make-resource-pool
|
||||
(lambda ()
|
||||
(let* ((inferior-store (open-store-connection)))
|
||||
(unless (valid-path? inferior-store store-item)
|
||||
(simple-format #t "warning: store item missing (~A)\n"
|
||||
store-item)
|
||||
(simple-format #t "warning: building (~A)\n"
|
||||
guix-derivation)
|
||||
(build-derivations inferior-store
|
||||
(list (read-derivation-from-file
|
||||
guix-derivation))))
|
||||
;; Use this more to keep the store-path alive so long as there's a
|
||||
;; inferior operating
|
||||
(add-temp-root inferior-store store-item)
|
||||
|
||||
(let ((inferior (start-inferior-for-data-extration
|
||||
inferior-store
|
||||
store-item
|
||||
guix-locpath
|
||||
extra-inferior-environment-variables)))
|
||||
(ensure-non-blocking-store-connection inferior-store)
|
||||
(make-inferior-non-blocking! inferior)
|
||||
(simple-format #t "debug: started new inferior and store connection\n")
|
||||
|
||||
(cons inferior inferior-store))))
|
||||
parallelism
|
||||
#:min-size 0
|
||||
#:idle-seconds 20
|
||||
#:name "inferior"
|
||||
#:destructor
|
||||
(match-lambda
|
||||
((inferior . store)
|
||||
(simple-format
|
||||
#t "debug: closing inferior and associated store connection\n")
|
||||
|
||||
(close-connection store)
|
||||
(close-inferior inferior)))))
|
||||
|
||||
(define (call-with-inferior proc)
|
||||
(define (check-wal-size)
|
||||
(define (get-wal-bytes)
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(stat:size (stat "/var/guix/db/db.sqlite-wal")))
|
||||
(lambda _ 0)))
|
||||
|
||||
(define threshold
|
||||
(max
|
||||
(* 4096 (expt 2 20))
|
||||
(* 0.8
|
||||
(- (free-disk-space "/var/guix/db/db.sqlite")
|
||||
(get-wal-bytes)))))
|
||||
|
||||
(if (< (get-wal-bytes) threshold)
|
||||
#t
|
||||
(let loop ((wal-bytes (get-wal-bytes)))
|
||||
(if (> wal-bytes threshold)
|
||||
(let ((stats (resource-pool-stats inf-and-store-pool)))
|
||||
(simple-format
|
||||
#t "debug: guix-daemon WAL is large (~A), ~A inferiors, waiting\n"
|
||||
wal-bytes
|
||||
(assq-ref stats 'resources))
|
||||
|
||||
(sleep 30)
|
||||
(loop (get-wal-bytes)))
|
||||
(begin
|
||||
(simple-format
|
||||
#t "debug: guix-daemon WAL now ~A bytes, continuing\n"
|
||||
wal-bytes)
|
||||
#t)))))
|
||||
|
||||
(let loop ()
|
||||
(check-wal-size)
|
||||
(match
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(if (resource-pool-timeout-error? exn)
|
||||
'retry
|
||||
(raise-exception exn)))
|
||||
(lambda ()
|
||||
(call-with-resource-from-pool inf-and-store-pool
|
||||
(match-lambda
|
||||
((inferior . inferior-store)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(proc inferior inferior-store))
|
||||
(lambda vals
|
||||
(simple-format #t "debug: returning inferior to pool\n")
|
||||
(cons 'result vals)))))
|
||||
#:timeout 20))
|
||||
#:unwind? #t)
|
||||
('retry (loop))
|
||||
(('result . vals)
|
||||
(apply values vals)))))
|
||||
|
||||
(define packages-count
|
||||
(call-with-inferior
|
||||
(lambda (inferior inferior-store)
|
||||
(ensure-gds-inferior-packages-defined! inferior)
|
||||
|
||||
(inferior-eval '(vector-length gds-inferior-packages) inferior))))
|
||||
|
||||
(define chunk-size 1000)
|
||||
|
||||
(define compute-derivations/parallelism-limiter
|
||||
(make-parallelism-limiter parallelism))
|
||||
(define (compute-derivations system target)
|
||||
;; Limit concurrency here to keep focused on specific systems until
|
||||
;; they've been fully processed
|
||||
(with-parallelism-limiter
|
||||
compute-derivations/parallelism-limiter
|
||||
(with-time-logging
|
||||
(simple-format #f "getting derivations for ~A"
|
||||
(cons system target))
|
||||
(let loop ((start-index 0))
|
||||
(let* ((last-chunk?
|
||||
(>= (+ start-index chunk-size) packages-count))
|
||||
(count
|
||||
(if last-chunk?
|
||||
(- packages-count start-index)
|
||||
chunk-size))
|
||||
(chunk
|
||||
(call-with-inferior
|
||||
(lambda (inferior inferior-store)
|
||||
(ensure-gds-inferior-packages-defined! inferior)
|
||||
|
||||
(let ((result
|
||||
(inferior-package-derivations
|
||||
inferior-store
|
||||
inferior
|
||||
system
|
||||
target
|
||||
start-index
|
||||
count)))
|
||||
|
||||
(when last-chunk?
|
||||
(inferior-cleanup inferior))
|
||||
|
||||
result)))))
|
||||
(unless last-chunk?
|
||||
(loop (+ start-index chunk-size))))))))
|
||||
|
||||
(with-time-logging "compute package derivations"
|
||||
(fibers-map-with-progress
|
||||
(match-lambda
|
||||
((system . target)
|
||||
(compute-derivations system target)))
|
||||
(list
|
||||
(let ((all-system-target-pairs
|
||||
(call-with-inferior
|
||||
(lambda (inferior inferior-store)
|
||||
(inferior-fetch-system-target-pairs inferior)))))
|
||||
(filter
|
||||
(match-lambda
|
||||
((system . target)
|
||||
(if (or (member system ignore-systems)
|
||||
(member target ignore-targets))
|
||||
(begin
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"ignoring ~A ~A for package derivations\n"
|
||||
system
|
||||
target)
|
||||
#f)
|
||||
#t)))
|
||||
all-system-target-pairs)))
|
||||
#:report
|
||||
(lambda (data)
|
||||
(for-each
|
||||
(match-lambda
|
||||
((result (system . target))
|
||||
(simple-format #t "~A ~A: ~A\n"
|
||||
system target result)))
|
||||
data))))
|
||||
(destroy-parallelism-limiter
|
||||
compute-derivations/parallelism-limiter)))))
|
||||
|
||||
#:hz 0
|
||||
#:parallelism 1
|
||||
#:drain? #t)
|
||||
|
||||
(simple-format #t "fixing ~A derivations\n"
|
||||
(length broken-derivations))
|
||||
|
||||
(for-each fix-derivation
|
||||
broken-derivations)))
|
||||
|
||||
(define* (derivation-file-names->derivation-ids postgresql-connection-pool
|
||||
call-with-utility-thread
|
||||
read-derivations/serialised
|
||||
|
|
@ -2023,6 +2268,73 @@ WHERE builder != 'builtin:download'
|
|||
|
||||
inf))))
|
||||
|
||||
(define (inferior-cleanup inferior)
|
||||
(inferior-eval
|
||||
'(let ((stats (gc-stats)))
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"cleaning up inferior (heap: ~a MiB used (~a MiB heap))~%"
|
||||
(round
|
||||
(/ (- (assoc-ref stats 'heap-size)
|
||||
(assoc-ref stats 'heap-free-size))
|
||||
(expt 2. 20)))
|
||||
(round
|
||||
(/ (assoc-ref stats 'heap-size)
|
||||
(expt 2. 20)))))
|
||||
inferior)
|
||||
|
||||
(catch
|
||||
'match-error
|
||||
(lambda ()
|
||||
(inferior-eval '(invalidate-derivation-caches!)
|
||||
inferior))
|
||||
(lambda (key . args)
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n")))
|
||||
|
||||
;; Generating derivations populates the derivation cache
|
||||
(inferior-eval
|
||||
'(hash-clear! (@@ (guix derivations) %derivation-cache))
|
||||
inferior)
|
||||
|
||||
;; Clean the cached store connections, as there are
|
||||
;; caches associated with these that take up lots of
|
||||
;; memory
|
||||
(inferior-eval
|
||||
'(when (defined? '%store-table)
|
||||
(hash-clear! %store-table))
|
||||
inferior)
|
||||
|
||||
(inferior-eval
|
||||
'(hash-for-each
|
||||
(lambda (key _)
|
||||
((@ (guix memoization) invalidate-memoization!) key))
|
||||
(@@ (guix memoization) %memoization-tables))
|
||||
inferior)
|
||||
|
||||
(inferior-eval '(gc) inferior)
|
||||
|
||||
(inferior-eval
|
||||
'(let ((stats (gc-stats)))
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"finished cleaning up inferior (heap: ~a MiB used (~a MiB heap))~%"
|
||||
(round
|
||||
(/ (- (assoc-ref stats 'heap-size)
|
||||
(assoc-ref stats 'heap-free-size))
|
||||
(expt 2. 20)))
|
||||
(round
|
||||
(/ (assoc-ref stats 'heap-size)
|
||||
(expt 2. 20)))))
|
||||
inferior)
|
||||
|
||||
;; (inferior-eval
|
||||
;; '((@@ (guix memoization) show-memoization-tables))
|
||||
;; inferior)
|
||||
|
||||
*unspecified*)
|
||||
|
||||
(define* (extract-information-from db-conn guix-revision-id-promise
|
||||
commit
|
||||
guix-source store-item
|
||||
|
|
@ -2257,73 +2569,6 @@ WHERE builder != 'builtin:download'
|
|||
|
||||
(define chunk-size 1000)
|
||||
|
||||
(define (inferior-cleanup inferior)
|
||||
(inferior-eval
|
||||
'(let ((stats (gc-stats)))
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"cleaning up inferior (heap: ~a MiB used (~a MiB heap))~%"
|
||||
(round
|
||||
(/ (- (assoc-ref stats 'heap-size)
|
||||
(assoc-ref stats 'heap-free-size))
|
||||
(expt 2. 20)))
|
||||
(round
|
||||
(/ (assoc-ref stats 'heap-size)
|
||||
(expt 2. 20)))))
|
||||
inferior)
|
||||
|
||||
(catch
|
||||
'match-error
|
||||
(lambda ()
|
||||
(inferior-eval '(invalidate-derivation-caches!)
|
||||
inferior))
|
||||
(lambda (key . args)
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"warning: ignoring match-error from calling inferior invalidate-derivation-caches!\n")))
|
||||
|
||||
;; Generating derivations populates the derivation cache
|
||||
(inferior-eval
|
||||
'(hash-clear! (@@ (guix derivations) %derivation-cache))
|
||||
inferior)
|
||||
|
||||
;; Clean the cached store connections, as there are
|
||||
;; caches associated with these that take up lots of
|
||||
;; memory
|
||||
(inferior-eval
|
||||
'(when (defined? '%store-table)
|
||||
(hash-clear! %store-table))
|
||||
inferior)
|
||||
|
||||
(inferior-eval
|
||||
'(hash-for-each
|
||||
(lambda (key _)
|
||||
((@ (guix memoization) invalidate-memoization!) key))
|
||||
(@@ (guix memoization) %memoization-tables))
|
||||
inferior)
|
||||
|
||||
(inferior-eval '(gc) inferior)
|
||||
|
||||
(inferior-eval
|
||||
'(let ((stats (gc-stats)))
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
"finished cleaning up inferior (heap: ~a MiB used (~a MiB heap))~%"
|
||||
(round
|
||||
(/ (- (assoc-ref stats 'heap-size)
|
||||
(assoc-ref stats 'heap-free-size))
|
||||
(expt 2. 20)))
|
||||
(round
|
||||
(/ (assoc-ref stats 'heap-size)
|
||||
(expt 2. 20)))))
|
||||
inferior)
|
||||
|
||||
;; (inferior-eval
|
||||
;; '((@@ (guix memoization) show-memoization-tables))
|
||||
;; inferior)
|
||||
|
||||
*unspecified*)
|
||||
|
||||
(define get-derivations/parallelism-limiter
|
||||
(make-parallelism-limiter parallelism))
|
||||
(define (get-derivations system target)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue