projects/guix·blob python-team · refs

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