projects/guix·blob librewolf-updates · refs

606 lines · 23.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012-2024, 2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2017, 2020, 2026 Jan (janneke) Nieuwenhuizen <[email protected]>
4;;; Copyright © 2018, 2019 Clément Lassieur <[email protected]>
5;;; Copyright © 2020 Julien Lepiller <[email protected]>
6;;; Copyright © 2020, 2021 Mathieu Othacehe <[email protected]>
7;;;
8;;; This file is part of GNU Guix.
9;;;
10;;; GNU Guix is free software; you can redistribute it and/or modify it
11;;; under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 3 of the License, or (at
13;;; your option) any later version.
14;;;
15;;; GNU Guix is distributed in the hope that it will be useful, but
16;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22
23(define-module (gnu ci)
24 #:use-module (guix build-system channel)
25 #:use-module (guix config)
26 #:autoload (guix describe) (package-channels)
27 #:use-module (guix memoization)
28 #:use-module (guix store)
29 #:use-module (guix profiles)
30 #:use-module (guix packages)
31 #:autoload (guix transformations) (tunable-package? tuned-package)
32 #:use-module (guix channels)
33 #:use-module (guix config)
34 #:use-module (guix derivations)
35 #:use-module (guix monads)
36 #:use-module (guix gexp)
37 #:use-module (guix ui)
38 #:use-module ((guix licenses)
39 #:select (gpl3+ license? license-name))
40 #:use-module ((guix utils) #:select (%current-system))
41 #:use-module ((guix scripts system) #:select (read-operating-system))
42 #:use-module ((guix scripts pack)
43 #:select (self-contained-tarball))
44 #:use-module (gnu bootloader)
45 #:use-module (gnu bootloader u-boot)
46 #:use-module (gnu compression)
47 #:use-module (gnu image)
48 #:use-module (gnu packages)
49 #:use-module (gnu packages gcc)
50 #:use-module (gnu packages gdb)
51 #:use-module (gnu packages base)
52 #:use-module (gnu packages gawk)
53 #:use-module (gnu packages guile)
54 #:use-module (gnu packages gettext)
55 #:use-module (gnu packages compression)
56 #:use-module (gnu packages multiprecision)
57 #:use-module (gnu packages make-bootstrap)
58 #:use-module (gnu packages package-management)
59 #:use-module (guix platform)
60 #:use-module (gnu system)
61 #:use-module (gnu system image)
62 #:use-module (gnu system vm)
63 #:use-module (gnu system install)
64 #:use-module (gnu system images hurd)
65 #:use-module (gnu system images novena)
66 #:use-module (gnu system images pine64)
67 #:use-module (gnu system images pinebook-pro)
68 #:use-module (gnu system images visionfive2)
69 #:use-module (gnu tests)
70 #:use-module (srfi srfi-1)
71 #:use-module (srfi srfi-26)
72 #:use-module (ice-9 match)
73 #:export (derivation->job
74 image->job
75
76 %core-packages
77
78 arguments->systems
79 cuirass-jobs))
80
81;;; Commentary:
82;;;
83;;; This file defines build jobs for Cuirass.
84;;;
85;;; Code:
86
87(define* (derivation->job name drv
88 #:key
89 (max-silent-time 3600)
90 (timeout (* 5 3600)))
91 "Return a Cuirass job called NAME and describing DRV.
92
93MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
94building the derivation."
95 `((#:job-name . ,name)
96 (#:derivation . ,(derivation-file-name drv))
97 (#:inputs . ,(map (compose derivation-file-name
98 derivation-input-derivation)
99 (derivation-inputs drv)))
100 (#:outputs . ,(filter-map
101 (lambda (res)
102 (match res
103 ((name . path)
104 `(,name . ,path))))
105 (derivation->output-paths drv)))
106 (#:nix-name . ,(derivation-name drv))
107 (#:system . ,(derivation-system drv))
108 (#:max-silent-time . ,max-silent-time)
109 (#:timeout . ,timeout)))
110
111(define* (package-job store job-name package system
112 #:key cross? target (suffix ""))
113 "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
114 (let ((job-name (string-append job-name "." system suffix)))
115 (parameterize ((%graft? #f))
116 (let* ((drv (if cross?
117 (package-cross-derivation store package target system
118 #:graft? #f)
119 (package-derivation store package system
120 #:graft? #f)))
121 (max-silent-time (or (assoc-ref (package-properties package)
122 'max-silent-time)
123 3600))
124 (timeout (or (assoc-ref (package-properties package)
125 'timeout)
126 72000)))
127 (derivation->job job-name drv
128 #:max-silent-time max-silent-time
129 #:timeout timeout)))))
130
131(define (package-cross-job store job-name package target system)
132 "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
133SYSTEM."
134 (let ((name (string-append target "." job-name)))
135 (package-job store name package system
136 #:cross? #t
137 #:target target)))
138
139(define %core-packages
140 ;; Note: Don't put the '-final' package variants because (1) that's
141 ;; implicit, and (2) they cannot be cross-built (due to the explicit input
142 ;; chain.)
143 (list gcc-10 gcc-11 gcc-12 glibc binutils gdb-minimal
144 gmp mpfr mpc coreutils findutils diffutils patch sed grep
145 gawk gnu-gettext hello guile-2.2 guile-3.0 zlib gzip xz guix
146 %bootstrap-binaries-tarball
147 %binutils-bootstrap-tarball
148 (%glibc-bootstrap-tarball)
149 %gcc-bootstrap-tarball
150 %guile-bootstrap-tarball
151 %bootstrap-tarballs))
152
153(define (commencement-packages system)
154 "Return the list of bootstrap packages from the commencement module for
155SYSTEM."
156 ;; Only include packages supported on SYSTEM. For example, the Mes
157 ;; bootstrap graph is currently not supported on ARM so it should be
158 ;; excluded.
159 (filter (lambda (obj)
160 (and (package? obj)
161 (supported-package? obj system)))
162 (module-map (lambda (sym var)
163 (variable-ref var))
164 (resolve-module '(gnu packages commencement)))))
165
166(define (packages-to-cross-build target)
167 "Return the list of packages to cross-build for TARGET."
168 ;; Don't cross-build the bootstrap tarballs for MinGW.
169 (if (string-contains target "mingw")
170 (drop-right %core-packages 6)
171 %core-packages))
172
173(define %bare-platform-triplets
174 ;; Cross-compilation triplets of platforms that lack a proper user-space and
175 ;; for which there's no point in trying to build regular packages.
176 '("avr"
177 "or1k-elf"
178 "xtensa-ath9k-elf"))
179
180(define %unsupported-platform-triplets
181 ;; These systems are kept around for nostalgia or for tinkering, but regular
182 ;; CI is disabled for them to reduce the load on CI infrastructure.
183 '("mips64el-linux-gnu"
184 "powerpc-linux-gnu"
185 "powerpc64-linux-gnu"))
186
187(define (cross-jobs store system)
188 "Return a list of cross-compilation jobs for SYSTEM."
189 (define (from-32-to-64? target)
190 ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack
191 ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
192 ;; mips64el-linux-gnuabi64.
193 (and (or (string-prefix? "i686-" system)
194 (string-prefix? "i586-" system)
195 (string-prefix? "armhf-" system))
196 (string-contains target "64"))) ;x86_64, mips64el, aarch64, etc.
197
198 (define (same? target)
199 ;; Return true if SYSTEM and TARGET are the same thing. This is so we
200 ;; don't try to cross-compile to 'mips64el-linux-gnu' from
201 ;; 'mips64el-linux'.
202 (or (and (string-contains target system)
203 (not (string=? "x86_64-linux-gnux32" target)))
204 (and (string-prefix? "armhf" system) ;armhf-linux
205 (string-prefix? "arm" target)))) ;arm-linux-gnueabihf
206
207 (define (pointless? target)
208 ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
209 (or (member target %bare-platform-triplets)
210 (member target %unsupported-platform-triplets)
211 (match system
212 ((or "x86_64-linux" "i686-linux")
213 (if (string-contains target "mingw")
214 (not (string=? "x86_64-linux" system))
215 #f))
216 (_
217 ;; Don't try to cross-compile from non-Intel platforms: this isn't
218 ;; very useful and these are often brittle configurations.
219 #t))))
220
221 (define (either proc1 proc2 proc3)
222 (lambda (x)
223 (or (proc1 x) (proc2 x) (proc3 x))))
224
225 (append-map (lambda (target)
226 (map (lambda (package)
227 (package-cross-job store (job-name package)
228 package target system))
229 (packages-to-cross-build target)))
230 (remove (either from-32-to-64? same? pointless?)
231 (targets))))
232
233(define* (guix-jobs store systems #:key source commit)
234 "Return a list of jobs for Guix itself."
235 (define instance
236 (checkout->channel-instance source
237 #:url (channel-url %default-guix-channel)
238 #:commit commit))
239
240 (map
241 (lambda (system)
242 (let ((name (string->symbol
243 (string-append "guix." system)))
244 (drv (run-with-store store
245 (channel-instances->derivation (list instance)
246 #:system system))))
247 (derivation->job name drv)))
248 systems))
249
250;; Architectures that are able to build or cross-build Guix System images.
251;; This does not mean that other architectures are not supported, only that
252;; they are often not fast enough to support Guix System images building.
253(define %guix-system-supported-systems
254 '("x86_64-linux" "i686-linux"))
255
256(define %guix-system-images
257 (list hurd-barebones-qcow2-image
258 hurd64-barebones-qcow2-image
259 pine64-barebones-raw-image
260 pinebook-pro-barebones-raw-image
261 novena-barebones-raw-image
262 visionfive2-barebones-raw-image))
263
264(define (hours hours)
265 (* 3600 hours))
266
267(define* (image->job store image
268 #:key name system)
269 "Return the job for IMAGE on SYSTEM. If NAME is passed, use it as job name,
270otherwise use the IMAGE name."
271 (let* ((image-name (or name
272 (symbol->string (image-name image))))
273 (name (string-append image-name "." system))
274 (drv (run-with-store store
275 (mbegin %store-monad
276 (set-guile-for-build (default-guile))
277 (lower-object (system-image image) system)))))
278 (parameterize ((%graft? #f))
279 (derivation->job name drv))))
280
281(define* (image-jobs store system
282 #:key source commit)
283 "Return a list of jobs that build images for SYSTEM."
284 (define MiB
285 (expt 2 20))
286
287 (parameterize ((current-guix-package
288 (channel-source->package source #:commit commit)))
289 (if (member system %guix-system-supported-systems)
290 `(,(image->job store
291 (image
292 (inherit mbr-hybrid-disk-image)
293 (operating-system installation-os))
294 #:name "usb-image"
295 #:system system)
296 ,(image->job
297 store
298 (image
299 (inherit (image-with-label
300 iso9660-image
301 (string-append "GUIX_" system "_"
302 (if (> (string-length %guix-version) 7)
303 (substring %guix-version 0 7)
304 %guix-version))))
305 (operating-system installation-os))
306 #:name "iso9660-image"
307 #:system system)
308 ;; Only cross-compile Guix System images from x86_64-linux for now.
309 ,@(if (string=? system "x86_64-linux")
310 (map (cut image->job store <>
311 #:system system)
312 %guix-system-images)
313 '()))
314 '())))
315
316(define* (system-test-jobs store system
317 #:key source commit)
318 "Return a list of jobs for the system tests."
319 (define (->job test)
320 (let ((name (string-append "test." (system-test-name test)
321 "." system))
322 (drv (run-with-store store
323 (mbegin %store-monad
324 (set-current-system system)
325 (set-grafting #f)
326 (set-guile-for-build (default-guile))
327 (system-test-value test)))))
328
329 (derivation->job name drv)))
330
331 (if (member system %guix-system-supported-systems)
332 ;; Override the value of 'current-guix' used by system tests. Using a
333 ;; channel instance makes tests that rely on 'current-guix' less
334 ;; expensive. It also makes sure we get a valid Guix package when this
335 ;; code is not running from a checkout.
336 (parameterize ((current-guix-package
337 (channel-source->package source #:commit commit)))
338 (map ->job (all-system-tests)))
339 '()))
340
341(define (tarball-jobs store system)
342 "Return jobs to build the self-contained Guix binary tarball."
343 (define (->job name drv)
344 (let ((name (string-append name "." system)))
345 (parameterize ((%graft? #f))
346 (derivation->job name drv))))
347
348 ;; XXX: Add a job for the stable Guix?
349 (list
350 (->job "binary-tarball"
351 (run-with-store store
352 (mbegin %store-monad
353 (set-guile-for-build (default-guile))
354 (>>= (profile-derivation (packages->manifest (list guix)))
355 (lambda (profile)
356 (self-contained-tarball "guix-binary" profile
357 #:profile-name "current-guix"
358 #:localstatedir? #t
359 #:compressor
360 (lookup-compressor "xz")))))
361 #:system system))))
362
363(define job-name
364 ;; Return the name of a package's job.
365 package-name)
366
367(define base-packages
368 (mlambda (system)
369 "Return the set of packages considered to be part of the base for SYSTEM."
370 (delete-duplicates
371 (append-map (match-lambda
372 ((_ package _ ...)
373 (match (package-transitive-inputs package)
374 (((_ inputs _ ...) ...)
375 inputs))))
376 (%final-inputs system)))))
377
378(define package->job
379 (lambda* (store package system #:key (suffix ""))
380 "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
381valid. Append SUFFIX to the job name."
382 (cond ((member package (base-packages system))
383 (package-job store (string-append "base." (job-name package))
384 package system #:suffix suffix))
385 ((supported-package? package system)
386 (let ((drv (package-derivation store package system
387 #:graft? #f)))
388 (and (substitutable-derivation? drv)
389 (package-job store (job-name package)
390 package system #:suffix suffix))))
391 (else
392 #f))))
393
394(define %x86-64-micro-architectures
395 ;; Micro-architectures for which we build tuned variants.
396 '("haswell" "skylake" "x86-64-v2" "x86-64-v3" "x86-64-v4"))
397
398(define (tuned-package-jobs store package system)
399 "Return a list of jobs for PACKAGE tuned for SYSTEM's micro-architectures."
400 (filter-map (lambda (micro-architecture)
401 (define suffix
402 (string-append "." micro-architecture))
403
404 (package->job store
405 (tuned-package package micro-architecture)
406 system
407 #:suffix suffix))
408 (match system
409 ("x86_64-linux" %x86-64-micro-architectures)
410 (_ '()))))
411
412(define (all-packages)
413 "Return the list of packages to build."
414 (define (adjust package result)
415 (cond ((package-replacement package)
416 ;; XXX: If PACKAGE and its replacement have the same name/version,
417 ;; then both Cuirass jobs will have the same name, which
418 ;; effectively means that the second one will be ignored. Thus,
419 ;; return the replacement first.
420 (cons* (package-replacement package) ;build both
421 package
422 result))
423 ((package-superseded package)
424 result) ;don't build it
425 (else
426 (cons package result))))
427
428 (fold-packages adjust
429 (fold adjust '() ;include base packages
430 (match (%final-inputs)
431 (((labels packages _ ...) ...)
432 packages)))
433 #:select? (const #t))) ;include hidden packages
434
435(define (arguments->manifests arguments channels)
436 "Return the list of manifests extracted from ARGUMENTS."
437 (map (lambda (manifest)
438 (any (lambda (checkout)
439 (let ((path (in-vicinity checkout manifest)))
440 (and (file-exists? path)
441 path)))
442 (map channel-url channels)))
443 arguments))
444
445(define (manifests->jobs store manifests systems)
446 "Return the list of jobs for the entries in MANIFESTS, a list of file
447names, for each one of SYSTEMS."
448 (define (load-manifest manifest)
449 (save-module-excursion
450 (lambda ()
451 (set-current-module (make-user-module '((guix profiles) (gnu))))
452 (primitive-load manifest))))
453
454 (define (manifest-entry-job-name entry)
455 (string-append (manifest-entry-name entry) "-"
456 (manifest-entry-version entry)))
457
458 (define (manifest-entry->job entry system)
459 (let* ((obj (manifest-entry-item entry))
460 (drv (parameterize ((%graft? #f))
461 (run-with-store store
462 (lower-object obj system)
463 #:system system)))
464 (max-silent-time (or (and (package? obj)
465 (assoc-ref (package-properties obj)
466 'max-silent-time))
467 3600))
468 (timeout (or (and (package? obj)
469 (assoc-ref (package-properties obj) 'timeout))
470 (* 5 3600))))
471 (derivation->job (manifest-entry-job-name entry) drv
472 #:max-silent-time max-silent-time
473 #:timeout timeout)))
474
475 (let ((entries (delete-duplicates
476 (append-map (compose manifest-entries load-manifest)
477 manifests)
478 manifest-entry=?)))
479 (append-map (lambda (system)
480 (map (cut manifest-entry->job <> system) entries))
481 systems)))
482
483(define (arguments->systems arguments)
484 "Return the systems list from ARGUMENTS."
485 (match (assoc-ref arguments 'systems)
486 (#f %cuirass-supported-systems)
487 ((lst ...) lst)
488 ((? string? str) (call-with-input-string str read))))
489
490
491;;;
492;;; Cuirass entry point.
493;;;
494
495(define (cuirass-jobs store arguments)
496 "Register Cuirass jobs."
497 (define subset
498 (assoc-ref arguments 'subset))
499
500 (define systems
501 (arguments->systems arguments))
502
503 (define channels
504 (let ((channels (assq-ref arguments 'channels)))
505 (map sexp->channel channels)))
506
507 (define guix
508 (find guix-channel? channels))
509
510 (define commit
511 (channel-commit guix))
512
513 (define source
514 (channel-url guix))
515
516 ;; Turn off grafts. Grafting is meant to happen on the user's machines.
517 (parameterize ((%graft? #f))
518 ;; Return one job for each package, except bootstrap packages.
519 (append-map
520 (lambda (system)
521 (format (current-error-port)
522 "evaluating for '~a' (heap size: ~a MiB)...~%"
523 system
524 (round
525 (/ (assoc-ref (gc-stats) 'heap-size)
526 (expt 2. 20))))
527 (invalidate-derivation-caches!)
528 (match subset
529 ('all
530 ;; Build everything, including replacements.
531 (let ((all (all-packages))
532 (jobs (lambda (package)
533 (match (package->job store package system)
534 (#f '())
535 (main-job
536 (cons main-job
537 (if (tunable-package? package)
538 (tuned-package-jobs store package system)
539 '())))))))
540 (append
541 (append-map jobs all)
542 (cross-jobs store system))))
543 ('core
544 ;; Build core packages only.
545 (append
546 (map (lambda (package)
547 (package-job store (job-name package)
548 package system))
549 (append (commencement-packages system) %core-packages))
550 (cross-jobs store system)))
551 ('guix
552 ;; Build Guix modules only.
553 (guix-jobs store systems
554 #:source source
555 #:commit commit))
556 ('hello
557 ;; Build hello package only.
558 (let ((hello (specification->package "hello")))
559 (list (package-job store (job-name hello)
560 hello system))))
561 ('images
562 ;; Build Guix System images only.
563 (image-jobs store system
564 #:source source
565 #:commit commit))
566 ('system-tests
567 ;; Build Guix System tests only.
568 (system-test-jobs store system
569 #:source source
570 #:commit commit))
571 ('tarball
572 ;; Build Guix tarball only.
573 (tarball-jobs store system))
574 (('custom . modules)
575 ;; Build custom modules jobs only.
576 (append-map
577 (lambda (module)
578 (let ((proc (module-ref
579 (resolve-interface module)
580 'cuirass-jobs)))
581 (proc store arguments)))
582 modules))
583 (('channels . channels)
584 ;; Build only the packages from CHANNELS.
585 (let ((all (all-packages)))
586 (filter-map
587 (lambda (package)
588 (any (lambda (channel)
589 (and (member (channel-name channel) channels)
590 (package->job store package system)))
591 (package-channels package)))
592 all)))
593 (('packages . rest)
594 ;; Build selected list of packages only.
595 (let ((packages (map specification->package rest)))
596 (map (lambda (package)
597 (package-job store (job-name package)
598 package system))
599 packages)))
600 (('manifests . rest)
601 ;; Build packages in the list of manifests.
602 (let ((manifests (arguments->manifests rest channels)))
603 (manifests->jobs store manifests systems)))
604 (else
605 (error "unknown subset" subset))))
606 systems)))