Only compute derivations if there are any to fix
This commit is contained in:
parent
42e45c0917
commit
76cc8d82b9
1 changed files with 172 additions and 171 deletions
|
|
@ -1530,186 +1530,187 @@ WHERE builder != 'builtin:download'
|
|||
#:ignore-targets ignore-targets)))
|
||||
(simple-format #t "~A broken derivations\n"
|
||||
(length broken-derivations))
|
||||
(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"))))
|
||||
(unless (= 0 broken-derivations)
|
||||
(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)
|
||||
(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 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
|
||||
(let ((inferior (start-inferior-for-data-extration
|
||||
inferior-store
|
||||
inferior
|
||||
system
|
||||
target
|
||||
start-index
|
||||
count)))
|
||||
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")
|
||||
|
||||
(when last-chunk?
|
||||
(inferior-cleanup inferior))
|
||||
(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")
|
||||
|
||||
result))
|
||||
#:memory-limit inferior-memory-limit)))
|
||||
(unless last-chunk?
|
||||
(loop (+ start-index chunk-size))))))))
|
||||
(close-connection store)
|
||||
(close-inferior inferior)))))
|
||||
|
||||
(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))))
|
||||
(define packages-count
|
||||
(call-with-inferior
|
||||
inf-and-store-pool
|
||||
(lambda (inferior inferior-store)
|
||||
(ensure-gds-inferior-packages-defined! inferior)
|
||||
|
||||
(destroy-resource-pool
|
||||
inf-and-store-pool)
|
||||
(destroy-parallelism-limiter
|
||||
compute-derivations/parallelism-limiter)))))
|
||||
#:hz 0
|
||||
#:parallelism 1
|
||||
#:drain? #t)
|
||||
(inferior-eval '(vector-length gds-inferior-packages) inferior))
|
||||
#:memory-limit inferior-memory-limit))
|
||||
|
||||
(simple-format #t "fixing ~A derivations\n"
|
||||
(length broken-derivations))
|
||||
(define chunk-size 1000)
|
||||
|
||||
(for-each fix-derivation
|
||||
broken-derivations)))
|
||||
(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
|
||||
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
|
||||
call-with-utility-thread
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue