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? skip-system-tests?
extra-inferior-environment-variables extra-inferior-environment-variables
per-job-parallelism per-job-parallelism
ignore-systems
ignore-targets
(free-space-requirement (free-space-requirement
(* 2 (expt 2 30)))) ; 2G (* 2 (expt 2 30)))) ; 2G
(define (fetch-new-jobs) (define (fetch-new-jobs)
@ -173,7 +175,15 @@ WHERE load_new_guix_revision_jobs.id = $1"
extra-inferior-environment-variables) extra-inferior-environment-variables)
,@(if per-job-parallelism ,@(if per-job-parallelism
(list (simple-format #f "--parallelism=~A" 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 #:output log-port
#:error 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 (define* (channel->source-and-derivation-file-names-by-system
conn channel conn channel
fetch-with-authentication? fetch-with-authentication?
#:key parallelism) #:key parallelism ignore-systems)
(define use-container? (defined? (define use-container? (defined?
'open-inferior/container '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 (with-resource-from-pool inferior-and-store-pool res
(match res (match res
((inferior . inferior-store) ((inferior . inferior-store)
(let* ((systems
(inferior-eval '(@ (guix packages) %supported-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 (result
(fibers-map (fibers-map
(lambda (system) (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 (define* (channel->source-and-derivations-by-system conn channel
fetch-with-authentication? fetch-with-authentication?
#:key parallelism) #:key parallelism
ignore-systems)
(match (with-time-logging "computing the channel derivation" (match (with-time-logging "computing the channel derivation"
(channel->source-and-derivation-file-names-by-system (channel->source-and-derivation-file-names-by-system
conn conn
channel channel
fetch-with-authentication? fetch-with-authentication?
#:parallelism parallelism)) #:parallelism parallelism
#:ignore-systems ignore-systems))
((source . derivation-file-names-by-system) ((source . derivation-file-names-by-system)
(for-each (for-each
(match-lambda (match-lambda
@ -1752,7 +1767,8 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
derivation-ids-hash-table derivation-ids-hash-table
#:key skip-system-tests? #:key skip-system-tests?
extra-inferior-environment-variables extra-inferior-environment-variables
parallelism) parallelism
ignore-systems ignore-targets)
(define guix-locpath (define guix-locpath
;; Augment the GUIX_LOCPATH to include glibc-locales from ;; 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 (process-system-and-target system target
get-derivations/fiberized))))) get-derivations/fiberized)))))
(list (list
(let ((all-system-target-pairs
(call-with-inferior (call-with-inferior
(lambda (inferior inferior-store) (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 #:report
(lambda (data) (lambda (data)
(for-each (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 (define* (load-new-guix-revision conn git-repository-id commit
#:key skip-system-tests? parallelism #:key skip-system-tests? parallelism
extra-inferior-environment-variables) extra-inferior-environment-variables
ignore-systems ignore-targets)
(define call-with-utility-thread (define call-with-utility-thread
(let* ((thread-pool (let* ((thread-pool
(call-with-default-io-waiters (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-conn
channel-for-commit channel-for-commit
fetch-with-authentication? fetch-with-authentication?
#:parallelism parallelism)))))) #:parallelism parallelism
#:ignore-systems ignore-systems))))))
(define guix-revision-id-promise (define guix-revision-id-promise
(fibers-delay (fibers-delay
@ -2370,6 +2403,8 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
skip-system-tests? skip-system-tests?
#:extra-inferior-environment-variables #:extra-inferior-environment-variables
extra-inferior-environment-variables extra-inferior-environment-variables
#:ignore-systems ignore-systems
#:ignore-targets ignore-targets
#:parallelism parallelism) #:parallelism parallelism)
(if (defined? 'channel-news-for-commit (if (defined? 'channel-news-for-commit
@ -2790,6 +2825,8 @@ SKIP LOCKED")
(define* (process-load-new-guix-revision-job id #:key skip-system-tests? (define* (process-load-new-guix-revision-job id #:key skip-system-tests?
extra-inferior-environment-variables extra-inferior-environment-variables
ignore-systems
ignore-targets
parallelism) parallelism)
(define finished-channel (define finished-channel
(make-channel)) (make-channel))
@ -2868,6 +2905,8 @@ SKIP LOCKED")
#:skip-system-tests? #t #:skip-system-tests? #t
#:extra-inferior-environment-variables #:extra-inferior-environment-variables
extra-inferior-environment-variables extra-inferior-environment-variables
#:ignore-systems ignore-systems
#:ignore-targets ignore-targets
#:parallelism parallelism)) #:parallelism parallelism))
(lambda (key . args) (lambda (key . args)
(simple-format (current-error-port) (simple-format (current-error-port)

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

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

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

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

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

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