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

Add a slightly crude method to ignore systems and targets

Browse source 
While processing a revision. It would be good to also record what systems and
targets are in the platforms so it's clear what data is missing, but that can
be added later.
This commit is contained in:
Christopher Baines 2025-02-03 21:47:53 +00:00
parent acdedb075d
commit 931b7bc593
5 changed files with 92 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

12
guix-data-service/jobs.scm
View file

@ -144,6 +144,8 @@ WHERE load_new_guix_revision_jobs.id = $1"
skip-system-tests?
extra-inferior-environment-variables
per-job-parallelism
ignore-systems
ignore-targets
(free-space-requirement
(* 2 (expt 2 30)))) ; 2G
(define (fetch-new-jobs)
@ -173,7 +175,15 @@ WHERE load_new_guix_revision_jobs.id = $1"
extra-inferior-environment-variables)
,@(if per-job-parallelism
(list (simple-format #f "--parallelism=~A" per-job-parallelism))
'()))
'())
,@(if (null? ignore-systems)
'()
(list (simple-format #f "--ignore-systems=~A"
(string-join ignore-systems ","))))
,@(if (null? ignore-targets)
'()
(list (simple-format #f "--ignore-targets=~A"
(string-join ignore-targets ",")))))
#:output log-port
#:error log-port)))

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

@ -1355,7 +1355,7 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(define* (channel->source-and-derivation-file-names-by-system
conn channel
fetch-with-authentication?
#:key parallelism)
#:key parallelism ignore-systems)
(define use-container? (defined?
'open-inferior/container
@ -1496,8 +1496,21 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(with-resource-from-pool inferior-and-store-pool res
(match res
((inferior . inferior-store)
(let* ((systems
(inferior-eval '(@ (guix packages) %supported-systems)
inferior)))))
inferior))
(ignored-systems
(lset-intersection string=?
systems
ignore-systems)))
(unless (null? ignored-systems)
(simple-format
(current-error-port)
"ignoring systems: ~A\n"
ignored-systems))
(lset-difference string=?
systems
ignored-systems))))))
(result
(fibers-map
(lambda (system)
@ -1536,13 +1549,15 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(define* (channel->source-and-derivations-by-system conn channel
fetch-with-authentication?
#:key parallelism)
#:key parallelism
ignore-systems)
(match (with-time-logging "computing the channel derivation"
(channel->source-and-derivation-file-names-by-system
conn
channel
fetch-with-authentication?
#:parallelism parallelism))
#:parallelism parallelism
#:ignore-systems ignore-systems))
((source . derivation-file-names-by-system)
(for-each
(match-lambda
@ -1752,7 +1767,8 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
derivation-ids-hash-table
#:key skip-system-tests?
extra-inferior-environment-variables
parallelism)
parallelism
ignore-systems ignore-targets)
(define guix-locpath
;; Augment the GUIX_LOCPATH to include glibc-locales from
@ -2130,9 +2146,24 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(process-system-and-target system target
get-derivations/fiberized)))))
(list
(let ((all-system-target-pairs
(call-with-inferior
(lambda (inferior inferior-store)
(inferior-fetch-system-target-pairs inferior))))
(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
@ -2270,7 +2301,8 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
(define* (load-new-guix-revision conn git-repository-id commit
#:key skip-system-tests? parallelism
extra-inferior-environment-variables)
extra-inferior-environment-variables
ignore-systems ignore-targets)
(define call-with-utility-thread
(let* ((thread-pool
(call-with-default-io-waiters
@ -2326,7 +2358,8 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
channel-conn
channel-for-commit
fetch-with-authentication?
#:parallelism parallelism))))))
#:parallelism parallelism
#:ignore-systems ignore-systems))))))
(define guix-revision-id-promise
(fibers-delay
@ -2370,6 +2403,8 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
skip-system-tests?
#:extra-inferior-environment-variables
extra-inferior-environment-variables
#:ignore-systems ignore-systems
#:ignore-targets ignore-targets
#:parallelism parallelism)
(if (defined? 'channel-news-for-commit
@ -2790,6 +2825,8 @@ SKIP LOCKED")
(define* (process-load-new-guix-revision-job id #:key skip-system-tests?
extra-inferior-environment-variables
ignore-systems
ignore-targets
parallelism)
(define finished-channel
(make-channel))
@ -2868,6 +2905,8 @@ SKIP LOCKED")
#:skip-system-tests? #t
#:extra-inferior-environment-variables
extra-inferior-environment-variables
#:ignore-systems ignore-systems
#:ignore-targets ignore-targets
#:parallelism parallelism))
(lambda (key . args)
(simple-format (current-error-port)

16
scripts/guix-data-service-process-job.in
View file

@ -56,10 +56,22 @@
(lambda (opt name arg result)
(alist-cons 'inferior-environment-variable
(string-split arg #\=)
result)))
(option '("ignore-systems") #t #f
(lambda (opt name arg result)
(alist-cons 'ignore-systems
(string-split arg #\,)
result)))
(option '("ignore-targets") #t #f
(lambda (opt name arg result)
(alist-cons 'ignore-targets
(string-split arg #\,)
result)))))
(define %default-options
'((parallelism . 1)))
'((parallelism . 1)
(ignore-systems . ())
(ignore-targets . ())))
(define (parse-options args)
(args-fold
@ -91,6 +103,8 @@
(cons key val))
(_ #f))
opts)
#:ignore-systems (assq-ref opts 'ignore-systems)
#:ignore-targets (assq-ref opts 'ignore-targets)
#:parallelism (assq-ref opts 'parallelism)))
#:hz 0
#:parallelism 1)))))

16
scripts/guix-data-service-process-jobs.in
View file

@ -60,12 +60,24 @@
(lambda (opt name arg result)
(alist-cons 'free-space-requirement
(string->number arg)
result)))
(option '("ignore-systems") #t #f
(lambda (opt name arg result)
(alist-cons 'ignore-systems
(string-split arg #\,)
result)))
(option '("ignore-targets") #t #f
(lambda (opt name arg result)
(alist-cons 'ignore-targets
(string-split arg #\,)
result)))))
(define %default-options
;; Alist of default option values
`((max-processes . ,default-max-processes)
(per-job-parallelism . 1)))
(per-job-parallelism . 1)
(ignore-systems . ())
(ignore-targets . ())))
(define (parse-options args)
(args-fold
@ -115,6 +127,8 @@
opts)
#:per-job-parallelism
(assq-ref opts 'per-job-parallelism)
#:ignore-systems (assq-ref opts 'ignore-systems)
#:ignore-targets (assq-ref opts 'ignore-targets)
#:free-space-requirement
(assq-ref opts 'free-space-requirement)))
(lambda _

2
tests/jobs-load-new-guix-revision.scm
View file

@ -46,7 +46,7 @@
((guix-data-service jobs load-new-guix-revision)
channel->source-and-derivations-by-system
(lambda* (conn channel fetch-with-authentication?
#:key parallelism)
#:key parallelism ignore-systems)
(values
"/gnu/store/guix"
'(("x86_64-linux"