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 (%core-packages
71 channel-source->package
76 ;;; This file defines build jobs for Cuirass.
80 (define* (derivation->job name drv
83 (max-silent-time 3600)
85 "Return a Cuirass job called NAME and describing DRV. PERIOD is the minimal
86 duration that must separate two evaluations of the same job. If PERIOD is
87 false, then the job will be evaluated as soon as possible.
89 MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
90 building the derivation."
91 `((#:job-name . ,name)
92 (#:derivation . ,(derivation-file-name drv))
93 (#:outputs . ,(filter-map
98 (derivation->output-paths drv)))
99 (#:nix-name . ,(derivation-name drv))
100 (#:system . ,(derivation-system drv))
102 (#:max-silent-time . ,max-silent-time)
103 (#:timeout . ,timeout)))
105 (define* (package-job store job-name package system
107 "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
108 (let ((job-name (string-append job-name "." system)))
109 (parameterize ((%graft? #f))
110 (let* ((drv (if cross?
111 (package-cross-derivation store package target system
113 (package-derivation store package system
115 (max-silent-time (or (assoc-ref (package-properties package)
118 (timeout (or (assoc-ref (package-properties package)
121 (derivation->job job-name drv
122 #:max-silent-time max-silent-time
123 #:timeout timeout)))))
125 (define (package-cross-job store job-name package target system)
126 "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
128 (let ((name (string-append target "." job-name "." system)))
129 (package-job store name package system
133 (define %core-packages
134 ;; Note: Don't put the '-final' package variants because (1) that's
135 ;; implicit, and (2) they cannot be cross-built (due to the explicit input
137 (list gcc-7 gcc-8 gcc-9 gcc-10 glibc binutils
138 gmp mpfr mpc coreutils findutils diffutils patch sed grep
139 gawk gnu-gettext hello guile-2.0 guile-2.2 zlib gzip xz
140 %bootstrap-binaries-tarball
141 %binutils-bootstrap-tarball
142 (%glibc-bootstrap-tarball)
143 %gcc-bootstrap-tarball
144 %guile-bootstrap-tarball
145 %bootstrap-tarballs))
147 (define (packages-to-cross-build target)
148 "Return the list of packages to cross-build for TARGET."
149 ;; Don't cross-build the bootstrap tarballs for MinGW.
150 (if (string-contains target "mingw")
151 (drop-right %core-packages 6)
154 (define %cross-targets
155 '("mips64el-linux-gnu"
156 "arm-linux-gnueabihf"
160 "i586-pc-gnu" ;aka. GNU/Hurd
162 "x86_64-w64-mingw32"))
164 (define (cross-jobs store system)
165 "Return a list of cross-compilation jobs for SYSTEM."
166 (define (from-32-to-64? target)
167 ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack
168 ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
169 ;; mips64el-linux-gnuabi64.
170 (and (or (string-prefix? "i686-" system)
171 (string-prefix? "i586-" system)
172 (string-prefix? "armhf-" system))
173 (string-contains target "64"))) ;x86_64, mips64el, aarch64, etc.
175 (define (same? target)
176 ;; Return true if SYSTEM and TARGET are the same thing. This is so we
177 ;; don't try to cross-compile to 'mips64el-linux-gnu' from
179 (or (string-contains target system)
180 (and (string-prefix? "armhf" system) ;armhf-linux
181 (string-prefix? "arm" target)))) ;arm-linux-gnueabihf
183 (define (pointless? target)
184 ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
186 ((or "x86_64-linux" "i686-linux")
187 (if (string-contains target "mingw")
188 (not (string=? "x86_64-linux" system))
191 ;; Don't try to cross-compile from non-Intel platforms: this isn't
192 ;; very useful and these are often brittle configurations.
195 (define (either proc1 proc2 proc3)
197 (or (proc1 x) (proc2 x) (proc3 x))))
199 (append-map (lambda (target)
200 (map (lambda (package)
201 (package-cross-job store (job-name package)
202 package target system))
203 (packages-to-cross-build target)))
204 (remove (either from-32-to-64? same? pointless?)
207 (define* (guix-jobs store systems #:key source commit)
208 "Return a list of jobs for Guix itself."
210 (primitive-load (string-append source "/build-aux/build-self.scm")))
214 (let ((name (string->symbol
215 (string-append "guix." system)))
216 (drv (run-with-store store
217 (build source #:version commit #:system system
219 #:guile-version "2.2"))))
220 (derivation->job name drv)))
223 ;; Architectures that are able to build or cross-build Guix System images.
224 ;; This does not mean that other architectures are not supported, only that
225 ;; they are often not fast enough to support Guix System images building.
226 (define %guix-system-supported-systems
227 '("x86_64-linux" "i686-linux"))
229 (define %guix-system-images
230 (list hurd-barebones-qcow2-image
231 pine64-barebones-raw-image
232 pinebook-pro-barebones-raw-image
233 novena-barebones-raw-image))
235 (define (hours hours)
238 (define (image-jobs store system)
239 "Return a list of jobs that build images for SYSTEM. Those jobs are
240 expensive in storage and I/O operations, hence their periodicity is limited by
241 passing the PERIOD argument."
242 (define (->job name drv)
243 (let ((name (string-append name "." system)))
244 (parameterize ((%graft? #f))
245 (derivation->job name drv
246 #:period (hours 48)))))
248 (define (build-image image)
249 (run-with-store store
251 (set-guile-for-build (default-guile))
252 (lower-object (system-image image)))))
257 (if (member system %guix-system-supported-systems)
258 `(,(->job "usb-image"
261 (inherit efi-disk-image)
262 (operating-system installation-os))))
263 ,(->job "iso9660-image"
266 (inherit (image-with-label
268 (string-append "GUIX_" system "_"
269 (if (> (string-length %guix-version) 7)
270 (substring %guix-version 0 7)
272 (operating-system installation-os))))
273 ;; Only cross-compile Guix System images from x86_64-linux for now.
274 ,@(if (string=? system "x86_64-linux")
276 (->job (symbol->string (image-name image))
277 (build-image image)))
282 (define channel-build-system
283 ;; Build system used to "convert" a channel instance to a package.
284 (let* ((build (lambda* (store name inputs
285 #:key source commit system
287 (run-with-store store
288 ;; SOURCE can be a lowerable object such as <local-file>
289 ;; or a file name. Adjust accordingly.
290 (mlet* %store-monad ((source (if (string? source)
292 (lower-object source)))
294 -> (checkout->channel-instance
295 source #:commit commit)))
296 (channel-instances->derivation (list instance)))
298 (lower (lambda* (name #:key system source commit
304 (arguments `(#:source ,source
305 #:commit ,commit))))))
306 (build-system (name 'channel)
307 (description "Turn a channel instance into a package.")
310 (define* (channel-source->package source #:key commit)
311 "Return a package for the given channel SOURCE, a lowerable object."
314 (version (string-append (package-version guix) "+"))
315 (build-system channel-build-system)
316 (arguments `(#:source ,source
320 (propagated-inputs '())))
322 (define* (system-test-jobs store system
324 "Return a list of jobs for the system tests."
326 (parameterize ((current-guix-package
327 (channel-source->package source #:commit commit)))
328 (let ((name (string-append "test." (system-test-name test)
330 (drv (run-with-store store
332 (set-current-system system)
334 (set-guile-for-build (default-guile))
335 (system-test-value test)))))
337 ;; Those tests are extremely expensive in I/O operations and storage
338 ;; size, use the "period" attribute to run them with a period of at
340 (derivation->job name drv
341 #:period (hours 24)))))
343 (if (member system %guix-system-supported-systems)
344 ;; Override the value of 'current-guix' used by system tests. Using a
345 ;; channel instance makes tests that rely on 'current-guix' less
346 ;; expensive. It also makes sure we get a valid Guix package when this
347 ;; code is not running from a checkout.
348 (map ->job (all-system-tests))
351 (define (tarball-jobs store system)
352 "Return jobs to build the self-contained Guix binary tarball."
353 (define (->job name drv)
354 (let ((name (string-append name "." system)))
355 (parameterize ((%graft? #f))
356 (derivation->job name drv
357 #:period (hours 24)))))
359 ;; XXX: Add a job for the stable Guix?
361 (->job "binary-tarball"
362 (run-with-store store
364 (set-guile-for-build (default-guile))
365 (>>= (profile-derivation (packages->manifest (list guix)))
367 (self-contained-tarball "guix-binary" profile
370 (lookup-compressor "xz")))))
374 ;; Return the name of a package's job.
380 (append-map (match-lambda
382 (match (package-transitive-inputs package)
383 (((_ inputs _ ...) ...)
386 (lambda (store package system)
387 "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
389 (cond ((member package base-packages)
390 (package-job store (string-append "base." (job-name package))
392 ((supported-package? package system)
393 (let ((drv (package-derivation store package system
395 (and (substitutable-derivation? drv)
396 (package-job store (job-name package)
401 (define (all-packages)
402 "Return the list of packages to build."
403 (define (adjust package result)
404 (cond ((package-replacement package)
405 ;; XXX: If PACKAGE and its replacement have the same name/version,
406 ;; then both Cuirass jobs will have the same name, which
407 ;; effectively means that the second one will be ignored. Thus,
408 ;; return the replacement first.
409 (cons* (package-replacement package) ;build both
412 ((package-superseded package)
413 result) ;don't build it
415 (cons package result))))
417 (fold-packages adjust
418 (fold adjust '() ;include base packages
419 (match (%final-inputs)
420 (((labels packages _ ...) ...)
422 #:select? (const #t))) ;include hidden packages
424 (define (arguments->manifests arguments channels)
425 "Return the list of manifests extracted from ARGUMENTS."
426 (define (channel-name->checkout name)
427 (let ((channel (find (lambda (channel)
428 (eq? (channel-name channel) name))
430 (channel-url channel)))
434 (let ((checkout (channel-name->checkout name)))
435 (in-vicinity checkout path))))
438 (define (manifests->packages store manifests)
439 "Return the list of packages found in MANIFESTS."
440 (define (load-manifest manifest)
441 (save-module-excursion
443 (set-current-module (make-user-module '((guix profiles) (gnu))))
444 (primitive-load manifest))))
447 (map manifest-entry-item
448 (append-map (compose manifest-entries
454 ;;; Cuirass entry point.
457 (define (cuirass-jobs store arguments)
458 "Register Cuirass jobs."
460 (assoc-ref arguments 'subset))
463 (match (assoc-ref arguments 'systems)
464 (#f %cuirass-supported-systems)
466 ((? string? str) (call-with-input-string str read))))
469 (let ((channels (assq-ref arguments 'channels)))
470 (map sexp->channel channels)))
473 (find guix-channel? channels))
476 (channel-commit guix))
481 ;; Turn off grafts. Grafting is meant to happen on the user's machines.
482 (parameterize ((%graft? #f))
483 ;; Return one job for each package, except bootstrap packages.
486 (format (current-error-port)
487 "evaluating for '~a' (heap size: ~a MiB)...~%"
490 (/ (assoc-ref (gc-stats) 'heap-size)
492 (invalidate-derivation-caches!)
495 ;; Build everything, including replacements.
496 (let ((all (all-packages))
497 (job (lambda (package)
498 (package->job store package system))))
501 (image-jobs store system)
502 (system-test-jobs store system
505 (tarball-jobs store system)
506 (cross-jobs store system))))
508 ;; Build core packages only.
510 (map (lambda (package)
511 (package-job store (job-name package)
514 (cross-jobs store system)))
516 ;; Build Guix modules only.
517 (guix-jobs store systems
521 ;; Build hello package only.
522 (let ((hello (specification->package "hello")))
523 (list (package-job store (job-name hello)
525 (('channels . channels)
526 ;; Build only the packages from CHANNELS.
527 (let ((all (all-packages)))
530 (match (package-channels package)
532 (and (member (channel-name channel) channels)
533 (package->job store package system)))
537 ;; Build selected list of packages only.
538 (let ((packages (map specification->package rest)))
539 (map (lambda (package)
540 (package-job store (job-name package)
544 ;; Build packages in the list of manifests.
545 (let* ((manifests (arguments->manifests rest channels))
546 (packages (manifests->packages store manifests)))
547 (map (lambda (package)
548 (package-job store (job-name package)
552 (error "unknown subset" subset))))