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

Only compute derivations if there are any to fix

Browse source
This commit is contained in:
Christopher Baines 2025-06-27 10:39:41 +02:00
parent 42e45c0917
commit 76cc8d82b9
1 changed files with 172 additions and 171 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1530,186 +1530,187 @@ WHERE builder != 'builtin:download'
#:ignore-targets ignore-targets))) #:ignore-targets ignore-targets)))
(simple-format #t "~A broken derivations\n" (simple-format #t "~A broken derivations\n"
(length broken-derivations)) (length broken-derivations))
(run-fibers (unless (= 0 broken-derivations)
(lambda () (run-fibers
(with-exception-handler (lambda ()
(lambda (exn) (with-exception-handler
(print-backtrace-and-exception/knots exn) (lambda (exn)
(raise-exception exn)) (print-backtrace-and-exception/knots exn)
(lambda () (raise-exception exn))
(let* ((guix-source (lambda ()
channel-derivations-by-system (let* ((guix-source
(with-postgresql-connection channel-derivations-by-system
"channel->source-and-derivations-by-system" (with-postgresql-connection
(lambda (conn) "channel->source-and-derivations-by-system"
(let* ((git-repository-fields (lambda (conn)
(select-git-repository conn git-repository-id)) (let* ((git-repository-fields
(git-repository-url (select-git-repository conn git-repository-id))
(assq-ref git-repository-fields 'url)) (git-repository-url
(fetch-with-authentication? (assq-ref git-repository-fields 'url))
(assq-ref git-repository-fields 'fetch-with-authentication?))) (fetch-with-authentication?
(channel->source-and-derivations-by-system (assq-ref git-repository-fields 'fetch-with-authentication?)))
conn (channel->source-and-derivations-by-system
(channel (name 'guix) conn
(url git-repository-url) (channel (name 'guix)
(commit commit)) (url git-repository-url)
fetch-with-authentication? (commit commit))
#:parallelism parallelism fetch-with-authentication?
#:ignore-systems ignore-systems))))) #:parallelism parallelism
(store-item #:ignore-systems ignore-systems)))))
guix-derivation (store-item
(channel-derivations-by-system->guix-store-item guix-derivation
channel-derivations-by-system)) (channel-derivations-by-system->guix-store-item
(guix-locpath channel-derivations-by-system))
;; Augment the GUIX_LOCPATH to include glibc-locales from (guix-locpath
;; the Guix at store-path, this should mean that the ;; Augment the GUIX_LOCPATH to include glibc-locales from
;; inferior Guix works, even if it's build using a different ;; the Guix at store-path, this should mean that the
;; glibc version ;; inferior Guix works, even if it's build using a different
(string-append ;; glibc version
(with-store-connection (string-append
(lambda (store) (with-store-connection
(glibc-locales-for-guix-store-path store store-item))) (lambda (store)
"/lib/locale" (glibc-locales-for-guix-store-path store store-item)))
":" (getenv "GUIX_LOCPATH")))) "/lib/locale"
":" (getenv "GUIX_LOCPATH"))))
(define inf-and-store-pool (define inf-and-store-pool
(make-resource-pool (make-resource-pool
(lambda () (lambda ()
(let* ((inferior-store (open-store-connection))) (let* ((inferior-store (open-store-connection)))
(unless (valid-path? inferior-store store-item) (unless (valid-path? inferior-store store-item)
(simple-format #t "warning: store item missing (~A)\n" (simple-format #t "warning: store item missing (~A)\n"
store-item) store-item)
(simple-format #t "warning: building (~A)\n" (simple-format #t "warning: building (~A)\n"
guix-derivation) guix-derivation)
(build-derivations inferior-store (build-derivations inferior-store
(list (read-derivation-from-file (list (read-derivation-from-file
guix-derivation)))) guix-derivation))))
;; Use this more to keep the store-path alive so long as there's a ;; Use this more to keep the store-path alive so long as there's a
;; inferior operating ;; inferior operating
(add-temp-root inferior-store store-item) (add-temp-root inferior-store store-item)
(let ((inferior (start-inferior-for-data-extration (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 packages-count
(call-with-inferior
inf-and-store-pool
(lambda (inferior inferior-store)
(ensure-gds-inferior-packages-defined! inferior)
(inferior-eval '(vector-length gds-inferior-packages) inferior))
#:memory-limit inferior-memory-limit))
(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
inf-and-store-pool
(lambda (inferior inferior-store)
(ensure-gds-inferior-packages-defined! inferior)
(let ((result
(inferior-package-derivations
inferior-store inferior-store
inferior store-item
system guix-locpath
target extra-inferior-environment-variables)))
start-index (ensure-non-blocking-store-connection inferior-store)
count))) (make-inferior-non-blocking! inferior)
(simple-format #t "debug: started new inferior and store connection\n")
(when last-chunk? (cons inferior inferior-store))))
(inferior-cleanup inferior)) 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")
result)) (close-connection store)
#:memory-limit inferior-memory-limit))) (close-inferior inferior)))))
(unless last-chunk?
(loop (+ start-index chunk-size))))))))
(with-time-logging "compute package derivations" (define packages-count
(fibers-map-with-progress (call-with-inferior
(match-lambda inf-and-store-pool
((system . target) (lambda (inferior inferior-store)
(compute-derivations system target))) (ensure-gds-inferior-packages-defined! inferior)
(list
(let ((all-system-target-pairs
(call-with-inferior
inf-and-store-pool
(lambda (inferior inferior-store)
(inferior-fetch-system-target-pairs inferior))
#:memory-limit inferior-memory-limit)))
(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-resource-pool (inferior-eval '(vector-length gds-inferior-packages) inferior))
inf-and-store-pool) #:memory-limit inferior-memory-limit))
(destroy-parallelism-limiter
compute-derivations/parallelism-limiter)))))
#:hz 0
#:parallelism 1
#:drain? #t)
(simple-format #t "fixing ~A derivations\n" (define chunk-size 1000)
(length broken-derivations))
(for-each fix-derivation (define compute-derivations/parallelism-limiter
broken-derivations))) (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
inf-and-store-pool
(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))
#:memory-limit inferior-memory-limit)))
(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
inf-and-store-pool
(lambda (inferior inferior-store)
(inferior-fetch-system-target-pairs inferior))
#:memory-limit inferior-memory-limit)))
(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-resource-pool
inf-and-store-pool)
(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 (define* (derivation-file-names->derivation-ids postgresql-connection-pool
call-with-utility-thread call-with-utility-thread