services: pcscd-shepherd-service: Fix PID file location.
[jackhill/guix/guix.git] / gnu / ci.scm
CommitLineData
59fb5c1c 1;;; GNU Guix --- Functional package management for GNU
2032d847 2;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
db2785cd 3;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
f71b0a00 4;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
f43ec1c5 5;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
fc2fa7ad 6;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
59fb5c1c
LC
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 config)
25 #:use-module (guix store)
26 #:use-module (guix grafts)
27 #:use-module (guix profiles)
28 #:use-module (guix packages)
7e6d8d36 29 #:use-module (guix channels)
f43ec1c5 30 #:use-module (guix config)
59fb5c1c 31 #:use-module (guix derivations)
7e6d8d36 32 #:use-module (guix build-system)
59fb5c1c 33 #:use-module (guix monads)
dd1ee160 34 #:use-module (guix gexp)
59fb5c1c 35 #:use-module (guix ui)
b5f8c2c8
LC
36 #:use-module ((guix licenses)
37 #:select (gpl3+ license? license-name))
59fb5c1c
LC
38 #:use-module ((guix utils) #:select (%current-system))
39 #:use-module ((guix scripts system) #:select (read-operating-system))
40 #:use-module ((guix scripts pack)
41 #:select (lookup-compressor self-contained-tarball))
42 #:use-module (gnu bootloader)
43 #:use-module (gnu bootloader u-boot)
f19cf27c 44 #:use-module (gnu image)
59fb5c1c
LC
45 #:use-module (gnu packages)
46 #:use-module (gnu packages gcc)
47 #:use-module (gnu packages base)
48 #:use-module (gnu packages gawk)
49 #:use-module (gnu packages guile)
50 #:use-module (gnu packages gettext)
51 #:use-module (gnu packages compression)
52 #:use-module (gnu packages multiprecision)
53 #:use-module (gnu packages make-bootstrap)
54 #:use-module (gnu packages package-management)
55 #:use-module (gnu system)
f19cf27c 56 #:use-module (gnu system image)
59fb5c1c
LC
57 #:use-module (gnu system vm)
58 #:use-module (gnu system install)
b06ba9e0 59 #:use-module (gnu system images hurd)
846e5240 60 #:use-module (gnu system images novena)
8a4f1eef 61 #:use-module (gnu system images pine64)
17d9a91e 62 #:use-module (gnu system images pinebook-pro)
59fb5c1c
LC
63 #:use-module (gnu tests)
64 #:use-module (srfi srfi-1)
65 #:use-module (srfi srfi-26)
66 #:use-module (ice-9 match)
f292c501
LC
67 #:export (%cross-targets
68 channel-source->package
887fd835 69 hydra-jobs))
59fb5c1c
LC
70
71;;; Commentary:
72;;;
73;;; This file defines build jobs for the Hydra and Cuirass continuation
74;;; integration tools.
75;;;
76;;; Code:
77
78(define* (package->alist store package system
79 #:optional (package-derivation package-derivation))
80 "Convert PACKAGE to an alist suitable for Hydra."
81 (parameterize ((%graft? #f))
3ca014d1
MO
82 (let ((drv (package-derivation store package system
83 #:graft? #f)))
84 `((derivation . ,(derivation-file-name drv))
c5cf45e9
MO
85 (log . ,(log-file store (derivation-file-name drv)))
86 (outputs . ,(filter-map (lambda (res)
87 (match res
88 ((name . path)
89 `(,name . ,path))))
90 (derivation->output-paths drv)))
3ca014d1
MO
91 (nix-name . ,(derivation-name drv))
92 (system . ,(derivation-system drv))
93 (description . ,(package-synopsis package))
94 (long-description . ,(package-description package))
b5f2a035
MO
95
96 ;; XXX: Hydra ignores licenses that are not a <license> structure or a
97 ;; list thereof.
98 (license . ,(let loop ((license (package-license package)))
99 (match license
100 ((? license?)
101 (license-name license))
102 ((lst ...)
103 (map loop license)))))
104
3ca014d1
MO
105 (home-page . ,(package-home-page package))
106 (maintainers . ("bug-guix@gnu.org"))
107 (max-silent-time . ,(or (assoc-ref (package-properties package)
108 'max-silent-time)
109 3600)) ;1 hour by default
110 (timeout . ,(or (assoc-ref (package-properties package) 'timeout)
111 72000)))))) ;20 hours by default
59fb5c1c
LC
112
113(define (package-job store job-name package system)
114 "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
115 (let ((job-name (symbol-append job-name (string->symbol ".")
116 (string->symbol system))))
117 `(,job-name . ,(cut package->alist store package system))))
118
119(define (package-cross-job store job-name package target system)
120 "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
121SYSTEM."
122 `(,(symbol-append (string->symbol target) (string->symbol ".") job-name
123 (string->symbol ".") (string->symbol system)) .
124 ,(cute package->alist store package system
125 (lambda* (store package system #:key graft?)
126 (package-cross-derivation store package target system
127 #:graft? graft?)))))
128
129(define %core-packages
130 ;; Note: Don't put the '-final' package variants because (1) that's
131 ;; implicit, and (2) they cannot be cross-built (due to the explicit input
132 ;; chain.)
84f38f03 133 (list gcc-7 gcc-8 gcc-9 gcc-10 glibc binutils
59fb5c1c
LC
134 gmp mpfr mpc coreutils findutils diffutils patch sed grep
135 gawk gnu-gettext hello guile-2.0 guile-2.2 zlib gzip xz
136 %bootstrap-binaries-tarball
137 %binutils-bootstrap-tarball
138 (%glibc-bootstrap-tarball)
139 %gcc-bootstrap-tarball
140 %guile-bootstrap-tarball
141 %bootstrap-tarballs))
142
668a5198
LC
143(define (packages-to-cross-build target)
144 "Return the list of packages to cross-build for TARGET."
145 ;; Don't cross-build the bootstrap tarballs for MinGW.
146 (if (string-contains target "mingw")
147 (drop-right %core-packages 6)
148 %core-packages))
59fb5c1c
LC
149
150(define %cross-targets
151 '("mips64el-linux-gnu"
59fb5c1c
LC
152 "arm-linux-gnueabihf"
153 "aarch64-linux-gnu"
154 "powerpc-linux-gnu"
2032d847 155 "riscv64-linux-gnu"
59fb5c1c 156 "i586-pc-gnu" ;aka. GNU/Hurd
67dac6b8
CD
157 "i686-w64-mingw32"
158 "x86_64-w64-mingw32"))
59fb5c1c 159
3046e73b
LC
160(define (cross-jobs store system)
161 "Return a list of cross-compilation jobs for SYSTEM."
162 (define (from-32-to-64? target)
163 ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack
164 ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
165 ;; mips64el-linux-gnuabi64.
166 (and (or (string-prefix? "i686-" system)
167 (string-prefix? "i586-" system)
168 (string-prefix? "armhf-" system))
169 (string-contains target "64"))) ;x86_64, mips64el, aarch64, etc.
170
171 (define (same? target)
172 ;; Return true if SYSTEM and TARGET are the same thing. This is so we
173 ;; don't try to cross-compile to 'mips64el-linux-gnu' from
174 ;; 'mips64el-linux'.
175 (or (string-contains target system)
176 (and (string-prefix? "armhf" system) ;armhf-linux
177 (string-prefix? "arm" target)))) ;arm-linux-gnueabihf
178
179 (define (pointless? target)
180 ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
181 (match system
182 ((or "x86_64-linux" "i686-linux")
183 (if (string-contains target "mingw")
184 (not (string=? "x86_64-linux" system))
185 #f))
186 (_
187 ;; Don't try to cross-compile from non-Intel platforms: this isn't
188 ;; very useful and these are often brittle configurations.
189 #t)))
190
191 (define (either proc1 proc2 proc3)
192 (lambda (x)
193 (or (proc1 x) (proc2 x) (proc3 x))))
194
195 (append-map (lambda (target)
196 (map (lambda (package)
197 (package-cross-job store (job-name package)
198 package target system))
50b99c90 199 (packages-to-cross-build target)))
3046e73b
LC
200 (remove (either from-32-to-64? same? pointless?)
201 %cross-targets)))
202
b06ba9e0
MO
203;; Architectures that are able to build or cross-build Guix System images.
204;; This does not mean that other architectures are not supported, only that
205;; they are often not fast enough to support Guix System images building.
206(define %guix-system-supported-systems
207 '("x86_64-linux" "i686-linux"))
59fb5c1c 208
b06ba9e0 209(define %guix-system-images
8a4f1eef 210 (list hurd-barebones-qcow2-image
17d9a91e 211 pine64-barebones-raw-image
846e5240
DM
212 pinebook-pro-barebones-raw-image
213 novena-barebones-raw-image))
59fb5c1c 214
fc2fa7ad
MO
215(define (hours hours)
216 (* 3600 hours))
217
b06ba9e0 218(define (image-jobs store system)
fc2fa7ad
MO
219 "Return a list of jobs that build images for SYSTEM. Those jobs are
220expensive in storage and I/O operations, hence their periodicity is limited by
221passing the PERIOD argument."
59fb5c1c
LC
222 (define (->alist drv)
223 `((derivation . ,(derivation-file-name drv))
c5cf45e9
MO
224 (log . ,(log-file store (derivation-file-name drv)))
225 (outputs . ,(filter-map (lambda (res)
226 (match res
227 ((name . path)
228 `(,name . ,path))))
229 (derivation->output-paths drv)))
3ca014d1
MO
230 (nix-name . ,(derivation-name drv))
231 (system . ,(derivation-system drv))
b06ba9e0
MO
232 (description . "Stand-alone image of the GNU system")
233 (long-description . "This is a demo stand-alone image of the GNU
59fb5c1c 234system.")
b5f8c2c8 235 (license . ,(license-name gpl3+))
fc2fa7ad 236 (period . ,(hours 48))
59fb5c1c
LC
237 (max-silent-time . 600)
238 (timeout . 3600)
239 (home-page . ,%guix-home-page-url)
240 (maintainers . ("bug-guix@gnu.org"))))
241
242 (define (->job name drv)
243 (let ((name (symbol-append name (string->symbol ".")
244 (string->symbol system))))
245 `(,name . ,(lambda ()
246 (parameterize ((%graft? #f))
247 (->alist drv))))))
248
b06ba9e0
MO
249 (define (build-image image)
250 (run-with-store store
251 (mbegin %store-monad
252 (set-guile-for-build (default-guile))
253 (lower-object (system-image image)))))
254
59fb5c1c
LC
255 (define MiB
256 (expt 2 20))
257
b06ba9e0
MO
258 (if (member system %guix-system-supported-systems)
259 `(,(->job 'usb-image
260 (build-image
261 (image
262 (inherit efi-disk-image)
b06ba9e0
MO
263 (operating-system installation-os))))
264 ,(->job 'iso9660-image
265 (build-image
266 (image
f43ec1c5
JL
267 (inherit (image-with-label
268 iso9660-image
7596ae10
JL
269 (string-append "GUIX_" system "_"
270 (if (> (string-length %guix-version) 7)
271 (substring %guix-version 0 7)
272 %guix-version))))
b06ba9e0
MO
273 (operating-system installation-os))))
274 ;; Only cross-compile Guix System images from x86_64-linux for now.
275 ,@(if (string=? system "x86_64-linux")
276 (map (lambda (image)
277 (->job (image-name image) (build-image image)))
278 %guix-system-images)
279 '()))
1189f405 280 '()))
59fb5c1c 281
7e6d8d36
LC
282(define channel-build-system
283 ;; Build system used to "convert" a channel instance to a package.
284 (let* ((build (lambda* (store name inputs
dd1ee160 285 #:key source commit system
c3ab921e 286 #:allow-other-keys)
7e6d8d36 287 (run-with-store store
bc8b2ffd
LC
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)
291 (return source)
292 (lower-object source)))
dd1ee160
LC
293 (instance
294 -> (checkout->channel-instance
295 source #:commit commit)))
296 (channel-instances->derivation (list instance)))
c3ab921e 297 #:system system)))
dd1ee160
LC
298 (lower (lambda* (name #:key system source commit
299 #:allow-other-keys)
7e6d8d36
LC
300 (bag
301 (name name)
302 (system system)
303 (build build)
dd1ee160
LC
304 (arguments `(#:source ,source
305 #:commit ,commit))))))
7e6d8d36
LC
306 (build-system (name 'channel)
307 (description "Turn a channel instance into a package.")
308 (lower lower))))
309
dd1ee160
LC
310(define* (channel-source->package source #:key commit)
311 "Return a package for the given channel SOURCE, a lowerable object."
7e6d8d36
LC
312 (package
313 (inherit guix)
dd1ee160 314 (version (string-append (package-version guix) "+"))
7e6d8d36 315 (build-system channel-build-system)
dd1ee160
LC
316 (arguments `(#:source ,source
317 #:commit ,commit))
7e6d8d36
LC
318 (inputs '())
319 (native-inputs '())
320 (propagated-inputs '())))
321
322(define* (system-test-jobs store system
323 #:key source commit)
59fb5c1c
LC
324 "Return a list of jobs for the system tests."
325 (define (test->thunk test)
326 (lambda ()
327 (define drv
328 (run-with-store store
329 (mbegin %store-monad
330 (set-current-system system)
331 (set-grafting #f)
332 (set-guile-for-build (default-guile))
333 (system-test-value test))))
334
fc2fa7ad
MO
335 ;; Those tests are extremely expensive in I/O operations and storage
336 ;; size, use the "period" attribute to run them with a period of at
337 ;; least 48 hours.
59fb5c1c 338 `((derivation . ,(derivation-file-name drv))
c5cf45e9
MO
339 (log . ,(log-file store (derivation-file-name drv)))
340 (outputs . ,(filter-map (lambda (res)
341 (match res
342 ((name . path)
343 `(,name . ,path))))
344 (derivation->output-paths drv)))
3ca014d1
MO
345 (nix-name . ,(derivation-name drv))
346 (system . ,(derivation-system drv))
59e80445 347 (description . ,(format #f "Guix '~a' system test"
59fb5c1c
LC
348 (system-test-name test)))
349 (long-description . ,(system-test-description test))
b5f8c2c8 350 (license . ,(license-name gpl3+))
fc2fa7ad 351 (period . ,(hours 48))
59fb5c1c
LC
352 (max-silent-time . 600)
353 (timeout . 3600)
354 (home-page . ,%guix-home-page-url)
355 (maintainers . ("bug-guix@gnu.org")))))
356
357 (define (->job test)
358 (let ((name (string->symbol
359 (string-append "test." (system-test-name test)
360 "." system))))
361 (cons name (test->thunk test))))
362
b06ba9e0 363 (if (member system %guix-system-supported-systems)
7e6d8d36
LC
364 ;; Override the value of 'current-guix' used by system tests. Using a
365 ;; channel instance makes tests that rely on 'current-guix' less
366 ;; expensive. It also makes sure we get a valid Guix package when this
367 ;; code is not running from a checkout.
368 (parameterize ((current-guix-package
dd1ee160 369 (channel-source->package source #:commit commit)))
7e6d8d36 370 (map ->job (all-system-tests)))
59fb5c1c
LC
371 '()))
372
373(define (tarball-jobs store system)
374 "Return Hydra jobs to build the self-contained Guix binary tarball."
375 (define (->alist drv)
376 `((derivation . ,(derivation-file-name drv))
c5cf45e9
MO
377 (log . ,(log-file store (derivation-file-name drv)))
378 (outputs . ,(filter-map (lambda (res)
379 (match res
380 ((name . path)
381 `(,name . ,path))))
382 (derivation->output-paths drv)))
3ca014d1
MO
383 (nix-name . ,(derivation-name drv))
384 (system . ,(derivation-system drv))
59fb5c1c
LC
385 (description . "Stand-alone binary Guix tarball")
386 (long-description . "This is a tarball containing binaries of Guix and
59e80445 387all its dependencies, and ready to be installed on \"foreign\" distributions.")
b5f8c2c8 388 (license . ,(license-name gpl3+))
59fb5c1c 389 (home-page . ,%guix-home-page-url)
fc2fa7ad
MO
390 (maintainers . ("bug-guix@gnu.org"))
391 (period . ,(hours 24))))
59fb5c1c
LC
392
393 (define (->job name drv)
394 (let ((name (symbol-append name (string->symbol ".")
395 (string->symbol system))))
396 `(,name . ,(lambda ()
397 (parameterize ((%graft? #f))
398 (->alist drv))))))
399
400 ;; XXX: Add a job for the stable Guix?
401 (list (->job 'binary-tarball
402 (run-with-store store
403 (mbegin %store-monad
404 (set-guile-for-build (default-guile))
405 (>>= (profile-derivation (packages->manifest (list guix)))
406 (lambda (profile)
407 (self-contained-tarball "guix-binary" profile
408 #:localstatedir? #t
409 #:compressor
410 (lookup-compressor "xz")))))
411 #:system system))))
412
413(define job-name
414 ;; Return the name of a package's job.
415 (compose string->symbol
416 (cut package-full-name <> "-")))
417
418(define package->job
419 (let ((base-packages
420 (delete-duplicates
421 (append-map (match-lambda
422 ((_ package _ ...)
423 (match (package-transitive-inputs package)
424 (((_ inputs _ ...) ...)
425 inputs))))
426 (%final-inputs)))))
427 (lambda (store package system)
428 "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
429valid."
430 (cond ((member package base-packages)
431 (package-job store (symbol-append 'base. (job-name package))
432 package system))
433 ((supported-package? package system)
434 (let ((drv (package-derivation store package system
435 #:graft? #f)))
436 (and (substitutable-derivation? drv)
437 (package-job store (job-name package)
438 package system))))
439 (else
440 #f)))))
441
442(define (all-packages)
443 "Return the list of packages to build."
444 (define (adjust package result)
445 (cond ((package-replacement package)
f00ff8db
LC
446 ;; XXX: If PACKAGE and its replacement have the same name/version,
447 ;; then both Cuirass jobs will have the same name, which
448 ;; effectively means that the second one will be ignored. Thus,
449 ;; return the replacement first.
450 (cons* (package-replacement package) ;build both
451 package
59fb5c1c
LC
452 result))
453 ((package-superseded package)
454 result) ;don't build it
455 (else
456 (cons package result))))
457
458 (fold-packages adjust
459 (fold adjust '() ;include base packages
460 (match (%final-inputs)
461 (((labels packages _ ...) ...)
462 packages)))
463 #:select? (const #t))) ;include hidden packages
464
465(define (arguments->manifests arguments)
466 "Return the list of manifests extracted from ARGUMENTS."
467 (map (match-lambda
468 ((input-name . relative-path)
469 (let* ((checkout (assq-ref arguments (string->symbol input-name)))
470 (base (assq-ref checkout 'file-name)))
471 (in-vicinity base relative-path))))
472 (assq-ref arguments 'manifests)))
473
474(define (manifests->packages store manifests)
475 "Return the list of packages found in MANIFESTS."
476 (define (load-manifest manifest)
477 (save-module-excursion
478 (lambda ()
479 (set-current-module (make-user-module '((guix profiles) (gnu))))
480 (primitive-load manifest))))
481
482 (delete-duplicates!
483 (map manifest-entry-item
484 (append-map (compose manifest-entries
485 load-manifest)
486 manifests))))
487
f71b0a00
CL
488(define (find-current-checkout arguments)
489 "Find the first checkout of ARGUMENTS that provided the current file.
490Return #f if no such checkout is found."
491 (let ((current-root
492 (canonicalize-path
493 (string-append (dirname (current-filename)) "/.."))))
494 (find (lambda (argument)
495 (and=> (assq-ref argument 'file-name)
496 (lambda (name)
497 (string=? name current-root)))) arguments)))
498
59fb5c1c
LC
499\f
500;;;
501;;; Hydra entry point.
502;;;
503
504(define (hydra-jobs store arguments)
505 "Return Hydra jobs."
506 (define subset
507 (match (assoc-ref arguments 'subset)
508 ("core" 'core) ; only build core packages
509 ("hello" 'hello) ; only build hello
510 (((? string?) (? string?) ...) 'list) ; only build selected list of packages
511 ("manifests" 'manifests) ; only build packages in the list of manifests
512 (_ 'all))) ; build everything
513
514 (define systems
515 (match (assoc-ref arguments 'systems)
516 (#f %hydra-supported-systems)
517 ((lst ...) lst)
518 ((? string? str) (call-with-input-string str read))))
519
7e6d8d36 520 (define checkout
f71b0a00
CL
521 (or (find-current-checkout arguments)
522 (assq-ref arguments 'superior-guix-checkout)))
7e6d8d36
LC
523
524 (define commit
525 (assq-ref checkout 'revision))
526
527 (define source
528 (assq-ref checkout 'file-name))
529
59fb5c1c
LC
530 ;; Turn off grafts. Grafting is meant to happen on the user's machines.
531 (parameterize ((%graft? #f))
532 ;; Return one job for each package, except bootstrap packages.
533 (append-map (lambda (system)
534 (format (current-error-port)
535 "evaluating for '~a' (heap size: ~a MiB)...~%"
536 system
537 (round
538 (/ (assoc-ref (gc-stats) 'heap-size)
539 (expt 2. 20))))
540 (invalidate-derivation-caches!)
541 (case subset
542 ((all)
543 ;; Build everything, including replacements.
544 (let ((all (all-packages))
545 (job (lambda (package)
546 (package->job store package
547 system))))
548 (append (filter-map job all)
98bf5ffe 549 (image-jobs store system)
7e6d8d36
LC
550 (system-test-jobs store system
551 #:source source
552 #:commit commit)
59fb5c1c 553 (tarball-jobs store system)
3046e73b 554 (cross-jobs store system))))
59fb5c1c
LC
555 ((core)
556 ;; Build core packages only.
557 (append (map (lambda (package)
558 (package-job store (job-name package)
559 package system))
560 %core-packages)
3046e73b 561 (cross-jobs store system)))
59fb5c1c
LC
562 ((hello)
563 ;; Build hello package only.
db2785cd
JN
564 (let ((hello (specification->package "hello")))
565 (list (package-job store (job-name hello) hello system))))
59fb5c1c
LC
566 ((list)
567 ;; Build selected list of packages only.
db2785cd
JN
568 (let* ((names (assoc-ref arguments 'subset))
569 (packages (map specification->package names)))
570 (map (lambda (package)
571 (package-job store (job-name package)
572 package system))
573 packages)))
59fb5c1c
LC
574 ((manifests)
575 ;; Build packages in the list of manifests.
576 (let* ((manifests (arguments->manifests arguments))
577 (packages (manifests->packages store manifests)))
578 (map (lambda (package)
579 (package-job store (job-name package)
580 package system))
581 packages)))
582 (else
583 (error "unknown subset" subset))))
584 systems)))