1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
4 ;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
5 ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
6 ;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
8 ;;; This file is part of GNU Guix.
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.
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.
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/>.
23 (define-module (gnu ci)
24 #:use-module (guix channels)
25 #:use-module (guix config)
26 #:use-module (guix describe)
27 #:use-module (guix store)
28 #:use-module (guix grafts)
29 #:use-module (guix profiles)
30 #:use-module (guix packages)
31 #:use-module (guix channels)
32 #:use-module (guix config)
33 #:use-module (guix derivations)
34 #:use-module (guix build-system)
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 (lookup-compressor self-contained-tarball))
44 #:use-module (gnu bootloader)
45 #:use-module (gnu bootloader u-boot)
46 #:use-module (gnu image)
47 #:use-module (gnu packages)
48 #:use-module (gnu packages gcc)
49 #:use-module (gnu packages base)
50 #:use-module (gnu packages gawk)
51 #:use-module (gnu packages guile)
52 #:use-module (gnu packages gettext)
53 #:use-module (gnu packages compression)
54 #:use-module (gnu packages multiprecision)
55 #:use-module (gnu packages make-bootstrap)
56 #:use-module (gnu packages package-management)
57 #:use-module (gnu system)
58 #:use-module (gnu system image)
59 #:use-module (gnu system vm)
60 #:use-module (gnu system install)
61 #:use-module (gnu system images hurd)
62 #:use-module (gnu system images novena)
63 #:use-module (gnu system images pine64)
64 #:use-module (gnu system images pinebook-pro)
65 #:use-module (gnu tests)
66 #:use-module (srfi srfi-1)
67 #:use-module (srfi srfi-26)
68 #:use-module (ice-9 match)
69 #:export (derivation->job
74 channel-source->package
81 ;;; This file defines build jobs for Cuirass.
85 (define* (derivation->job name drv
87 (max-silent-time 3600)
89 "Return a Cuirass job called NAME and describing DRV.
91 MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
92 building the derivation."
93 `((#:job-name . ,name)
94 (#:derivation . ,(derivation-file-name drv))
95 (#:inputs . ,(map (compose derivation-file-name
96 derivation-input-derivation)
97 (derivation-inputs drv)))
98 (#:outputs . ,(filter-map
103 (derivation->output-paths drv)))
104 (#:nix-name . ,(derivation-name drv))
105 (#:system . ,(derivation-system drv))
106 (#:max-silent-time . ,max-silent-time)
107 (#:timeout . ,timeout)))
109 (define* (package-job store job-name package system
111 "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
112 (let ((job-name (string-append job-name "." system)))
113 (parameterize ((%graft? #f))
114 (let* ((drv (if cross?
115 (package-cross-derivation store package target system
117 (package-derivation store package system
119 (max-silent-time (or (assoc-ref (package-properties package)
122 (timeout (or (assoc-ref (package-properties package)
125 (derivation->job job-name drv
126 #:max-silent-time max-silent-time
127 #:timeout timeout)))))
129 (define (package-cross-job store job-name package target system)
130 "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
132 (let ((name (string-append target "." job-name "." system)))
133 (package-job store name package system
137 (define %core-packages
138 ;; Note: Don't put the '-final' package variants because (1) that's
139 ;; implicit, and (2) they cannot be cross-built (due to the explicit input
141 (list gcc-7 gcc-8 gcc-9 gcc-10 glibc binutils
142 gmp mpfr mpc coreutils findutils diffutils patch sed grep
143 gawk gnu-gettext hello guile-2.0 guile-2.2 zlib gzip xz
144 %bootstrap-binaries-tarball
145 %binutils-bootstrap-tarball
146 (%glibc-bootstrap-tarball)
147 %gcc-bootstrap-tarball
148 %guile-bootstrap-tarball
149 %bootstrap-tarballs))
151 (define (packages-to-cross-build target)
152 "Return the list of packages to cross-build for TARGET."
153 ;; Don't cross-build the bootstrap tarballs for MinGW.
154 (if (string-contains target "mingw")
155 (drop-right %core-packages 6)
158 (define %cross-targets
159 '("mips64el-linux-gnu"
160 "arm-linux-gnueabihf"
163 "powerpc64le-linux-gnu"
165 "i586-pc-gnu" ;aka. GNU/Hurd
167 "x86_64-w64-mingw32"))
169 (define (cross-jobs store system)
170 "Return a list of cross-compilation jobs for SYSTEM."
171 (define (from-32-to-64? target)
172 ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack
173 ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
174 ;; mips64el-linux-gnuabi64.
175 (and (or (string-prefix? "i686-" system)
176 (string-prefix? "i586-" system)
177 (string-prefix? "armhf-" system))
178 (string-contains target "64"))) ;x86_64, mips64el, aarch64, etc.
180 (define (same? target)
181 ;; Return true if SYSTEM and TARGET are the same thing. This is so we
182 ;; don't try to cross-compile to 'mips64el-linux-gnu' from
184 (or (string-contains target system)
185 (and (string-prefix? "armhf" system) ;armhf-linux
186 (string-prefix? "arm" target)))) ;arm-linux-gnueabihf
188 (define (pointless? target)
189 ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
191 ((or "x86_64-linux" "i686-linux")
192 (if (string-contains target "mingw")
193 (not (string=? "x86_64-linux" system))
196 ;; Don't try to cross-compile from non-Intel platforms: this isn't
197 ;; very useful and these are often brittle configurations.
200 (define (either proc1 proc2 proc3)
202 (or (proc1 x) (proc2 x) (proc3 x))))
204 (append-map (lambda (target)
205 (map (lambda (package)
206 (package-cross-job store (job-name package)
207 package target system))
208 (packages-to-cross-build target)))
209 (remove (either from-32-to-64? same? pointless?)
212 (define* (guix-jobs store systems #:key source commit)
213 "Return a list of jobs for Guix itself."
215 (primitive-load (string-append source "/build-aux/build-self.scm")))
219 (let ((name (string->symbol
220 (string-append "guix." system)))
221 (drv (run-with-store store
222 (build source #:version commit #:system system
224 #:guile-version "2.2"))))
225 (derivation->job name drv)))
228 ;; Architectures that are able to build or cross-build Guix System images.
229 ;; This does not mean that other architectures are not supported, only that
230 ;; they are often not fast enough to support Guix System images building.
231 (define %guix-system-supported-systems
232 '("x86_64-linux" "i686-linux"))
234 (define %guix-system-images
235 (list hurd-barebones-qcow2-image
236 pine64-barebones-raw-image
237 pinebook-pro-barebones-raw-image
238 novena-barebones-raw-image))
240 (define (hours hours)
243 (define* (image->job store image
245 "Return the job for IMAGE on SYSTEM. If NAME is passed, use it as job name,
246 otherwise use the IMAGE name."
247 (let* ((image-name (or name
248 (symbol->string (image-name image))))
249 (name (string-append image-name "." system))
250 (drv (run-with-store store
252 (set-guile-for-build (default-guile))
253 (lower-object (system-image image))))))
254 (parameterize ((%graft? #f))
255 (derivation->job name drv))))
257 (define (image-jobs store system)
258 "Return a list of jobs that build images for SYSTEM."
262 (if (member system %guix-system-supported-systems)
265 (inherit efi-disk-image)
266 (operating-system installation-os))
272 (inherit (image-with-label
274 (string-append "GUIX_" system "_"
275 (if (> (string-length %guix-version) 7)
276 (substring %guix-version 0 7)
278 (operating-system installation-os))
279 #:name "iso9660-image"
281 ;; Only cross-compile Guix System images from x86_64-linux for now.
282 ,@(if (string=? system "x86_64-linux")
283 (map (cut image->job store <>
289 (define channel-build-system
290 ;; Build system used to "convert" a channel instance to a package.
291 (let* ((build (lambda* (store name inputs
292 #:key source commit system
294 (run-with-store store
295 ;; SOURCE can be a lowerable object such as <local-file>
296 ;; or a file name. Adjust accordingly.
297 (mlet* %store-monad ((source (if (string? source)
299 (lower-object source)))
301 -> (checkout->channel-instance
302 source #:commit commit)))
303 (channel-instances->derivation (list instance)))
305 (lower (lambda* (name #:key system source commit
311 (arguments `(#:source ,source
312 #:commit ,commit))))))
313 (build-system (name 'channel)
314 (description "Turn a channel instance into a package.")
317 (define* (channel-source->package source #:key commit)
318 "Return a package for the given channel SOURCE, a lowerable object."
321 (version (string-append (package-version guix) "+"))
322 (build-system channel-build-system)
323 (arguments `(#:source ,source
327 (propagated-inputs '())))
329 (define* (system-test-jobs store system
331 "Return a list of jobs for the system tests."
333 (let ((name (string-append "test." (system-test-name test)
335 (drv (run-with-store store
337 (set-current-system system)
339 (set-guile-for-build (default-guile))
340 (system-test-value test)))))
342 (derivation->job name drv)))
344 (if (member system %guix-system-supported-systems)
345 ;; Override the value of 'current-guix' used by system tests. Using a
346 ;; channel instance makes tests that rely on 'current-guix' less
347 ;; expensive. It also makes sure we get a valid Guix package when this
348 ;; code is not running from a checkout.
349 (parameterize ((current-guix-package
350 (channel-source->package source #:commit commit)))
351 (map ->job (all-system-tests)))
354 (define (tarball-jobs store system)
355 "Return jobs to build the self-contained Guix binary tarball."
356 (define (->job name drv)
357 (let ((name (string-append name "." system)))
358 (parameterize ((%graft? #f))
359 (derivation->job name drv))))
361 ;; XXX: Add a job for the stable Guix?
363 (->job "binary-tarball"
364 (run-with-store store
366 (set-guile-for-build (default-guile))
367 (>>= (profile-derivation (packages->manifest (list guix)))
369 (self-contained-tarball "guix-binary" profile
370 #:profile-name "current-guix"
373 (lookup-compressor "xz")))))
377 ;; Return the name of a package's job.
383 (append-map (match-lambda
385 (match (package-transitive-inputs package)
386 (((_ inputs _ ...) ...)
389 (lambda (store package system)
390 "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
392 (cond ((member package base-packages)
393 (package-job store (string-append "base." (job-name package))
395 ((supported-package? package system)
396 (let ((drv (package-derivation store package system
398 (and (substitutable-derivation? drv)
399 (package-job store (job-name package)
404 (define (all-packages)
405 "Return the list of packages to build."
406 (define (adjust package result)
407 (cond ((package-replacement package)
408 ;; XXX: If PACKAGE and its replacement have the same name/version,
409 ;; then both Cuirass jobs will have the same name, which
410 ;; effectively means that the second one will be ignored. Thus,
411 ;; return the replacement first.
412 (cons* (package-replacement package) ;build both
415 ((package-superseded package)
416 result) ;don't build it
418 (cons package result))))
420 (fold-packages adjust
421 (fold adjust '() ;include base packages
422 (match (%final-inputs)
423 (((labels packages _ ...) ...)
425 #:select? (const #t))) ;include hidden packages
427 (define (arguments->manifests arguments channels)
428 "Return the list of manifests extracted from ARGUMENTS."
429 (map (lambda (manifest)
430 (any (lambda (checkout)
431 (let ((path (in-vicinity checkout manifest)))
432 (and (file-exists? path)
434 (map channel-url channels)))
437 (define (manifests->packages store manifests)
438 "Return the list of packages found in MANIFESTS."
439 (define (load-manifest manifest)
440 (save-module-excursion
442 (set-current-module (make-user-module '((guix profiles) (gnu))))
443 (primitive-load manifest))))
446 (map manifest-entry-item
447 (append-map (compose manifest-entries
451 (define (arguments->systems arguments)
452 "Return the systems list from ARGUMENTS."
453 (match (assoc-ref arguments 'systems)
454 (#f %cuirass-supported-systems)
456 ((? string? str) (call-with-input-string str read))))
460 ;;; Cuirass entry point.
463 (define (cuirass-jobs store arguments)
464 "Register Cuirass jobs."
466 (assoc-ref arguments 'subset))
469 (arguments->systems arguments))
472 (let ((channels (assq-ref arguments 'channels)))
473 (map sexp->channel channels)))
476 (find guix-channel? channels))
479 (channel-commit guix))
484 ;; Turn off grafts. Grafting is meant to happen on the user's machines.
485 (parameterize ((%graft? #f))
486 ;; Return one job for each package, except bootstrap packages.
489 (format (current-error-port)
490 "evaluating for '~a' (heap size: ~a MiB)...~%"
493 (/ (assoc-ref (gc-stats) 'heap-size)
495 (invalidate-derivation-caches!)
498 ;; Build everything, including replacements.
499 (let ((all (all-packages))
500 (job (lambda (package)
501 (package->job store package system))))
504 (cross-jobs store system))))
506 ;; Build core packages only.
508 (map (lambda (package)
509 (package-job store (job-name package)
512 (cross-jobs store system)))
514 ;; Build Guix modules only.
515 (guix-jobs store systems
519 ;; Build hello package only.
520 (let ((hello (specification->package "hello")))
521 (list (package-job store (job-name hello)
524 ;; Build Guix System images only.
525 (image-jobs store system))
527 ;; Build Guix System tests only.
528 (system-test-jobs store system
532 ;; Build Guix tarball only.
533 (tarball-jobs store system))
535 ;; Build custom modules jobs only.
538 (let ((proc (module-ref
539 (resolve-interface module)
541 (proc store arguments)))
543 (('channels . channels)
544 ;; Build only the packages from CHANNELS.
545 (let ((all (all-packages)))
548 (any (lambda (channel)
549 (and (member (channel-name channel) channels)
550 (package->job store package system)))
551 (package-channels package)))
554 ;; Build selected list of packages only.
555 (let ((packages (map specification->package rest)))
556 (map (lambda (package)
557 (package-job store (job-name package)
561 ;; Build packages in the list of manifests.
562 (let* ((manifests (arguments->manifests rest channels))
563 (packages (manifests->packages store manifests)))
564 (map (lambda (package)
565 (package-job store (job-name package)
569 (error "unknown subset" subset))))