aboutsummaryrefslogtreecommitdiff
path: root/gnu/local.mk
AgeCommit message (Expand)Author
2017-03-16gnu: qemu: Fix CVE-2017-{2620,2630}....Leo Famulari
2017-03-16gnu: virglrenderer: Fix CVE-2017-6386....Leo Famulari
2017-03-16gnu: password-store: Fix compatibility with GnuPG 2.1.19....Clément Lassieur
2017-03-10gnu: wget: Fix CVE-2017-6508....Leo Famulari
2017-03-09gnu: python-fake-factory: Add back missing patch file....Mark H Weaver
2017-03-08gnu: python-pandas: Fix build on 32-bit....Marius Bakke
2017-03-08gnu: Add python-faker....Marius Bakke
2017-03-07gnu: pcre2: Update to 10.23....Marius Bakke
2017-03-07gnu: gnupg: Update to 2.1.19....Leo Famulari
2017-03-06gnu: python-matplotlib: Update to 2.0.0....Thomas Danckaert
2017-03-06gnu: Add python2-subprocess32....Marius Bakke
2017-03-06gnu: texlive: Fix CVE-2016-10243....Leo Famulari
2017-03-04gnu: wxwidgets: Fix for Filezilla client....rennes
2017-03-04gnu: kio: Fix CVE-2017-6410....Leo Famulari
2017-03-03gnu: arb: Update to 2.10.0....Andreas Enge
2017-03-03Merge branch 'python-tests'Marius Bakke
2017-03-03gnu: mupdf: Fix CVE-2017-{5896,5991}....Alex Vong
2017-03-01gnu: vdirsyncer: Update to 0.15.0....Leo Famulari
2017-02-28gnu: screen: Update to 4.5.1....Efraim Flashner
2017-02-27Merge branch 'master' into python-testsMarius Bakke
2017-02-27gnu: gst-plugins-base: Update to 1.10.4....Leo Famulari
2017-02-26gnu: Remove unused patch....Marius Bakke
2017-02-24gnu: python-dendropy: Fix failing tests....Ricardo Wurmus
2017-02-24gnu: python-fake-factory: Fix build on 32bit....Marius Bakke
2017-02-23gnu: util-linux: Fix CVE-2017-2616....Leo Famulari
2017-02-23gnu: shadow: Fix CVE-2017-2616....Leo Famulari
2017-02-18gnu: vdirsyncer: Don't fail the test suite when the build machine is slow....Leo Famulari
2017-02-14gnu: vim: Fix CVE-2017-5953....Leo Famulari
2017-02-13gnu: netsurf: Enable tests....Eric Bavier
2017-02-13gnu: netsurf: Use unbundled source....Eric Bavier
2017-02-13gnu: Add hubbub....Eric Bavier
2017-02-13gnu: netsurf: Upgrade to 3.6....Eric Bavier
2017-02-14gnu: python-pygit2: Skip tests requiring network access....Marius Bakke
2017-02-13Merge branch 'master' into python-testsMarius Bakke
2017-02-13gnu: Add simh....José Miguel Sánchez García
2017-02-12gnu: screen: Fix CVE-2017-5618....Leo Famulari
2017-02-12gnu: qemu: Fix CVE-2017-{5667,5898,5931}....Leo Famulari
2017-02-11gnu: spice: Fix CVE-2016-9577 and CVE-2016-9578....Marius Bakke
2017-02-11gnu: shadow: Update to 4.4....ng0
2017-02-10tests: Add 'prosody-service-type' test....Clément Lassieur
2017-02-10gnu: Move (gnu packages grub) and (gnu packages u-boot) ......David Craven
2017-02-09gnu: ntfs-3g: Fix CVE-2017-0358....Kei Kebreau
2017-02-07Add (gnu build shepherd)....Ludovic Courtès
2017-02-06gnu: Add re2c....Sergei Trofimovich
2017-02-03gnu: p7zip: Fix CVE-2016-9256....Efraim Flashner
2017-02-03gnu: qemu: Patch CVE-2017-{2615, 5578, 5579, 5856}....Efraim Flashner
2017-02-02gnu: gst-plugins-base: Fix build on 32bit....Marius Bakke
2017-02-01gnu: httpd: Update to 2.4.25 [fixes CVE-2016-{0736,2161,5387,8743}]....Leo Famulari
2017-02-01gnu: libevent: Skip tests that fail on 32bit....Marius Bakke
2017-02-01gnu: libevent: Update to 2.1.8 [security fixes]....Marius Bakke
generated by cgit
'>403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
;;; Copyright © 2020, 2021 Mathieu Othacehe <othacehe@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu ci)
  #:use-module (guix build-system channel)
  #:use-module (guix config)
  #:autoload   (guix describe) (package-channels)
  #:use-module (guix store)
  #:use-module (guix profiles)
  #:use-module (guix packages)
  #:autoload   (guix transformations) (tunable-package? tuned-package)
  #:use-module (guix channels)
  #:use-module (guix config)
  #:use-module (guix derivations)
  #:use-module (guix monads)
  #:use-module (guix gexp)
  #:use-module (guix ui)
  #:use-module ((guix licenses)
                #:select (gpl3+ license? license-name))
  #:use-module ((guix utils) #:select (%current-system))
  #:use-module ((guix scripts system) #:select (read-operating-system))
  #:use-module ((guix scripts pack)
                #:select (self-contained-tarball))
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader u-boot)
  #:use-module (gnu compression)
  #:use-module (gnu image)
  #:use-module (gnu packages)
  #:use-module (gnu packages gcc)
  #:use-module (gnu packages gdb)
  #:use-module (gnu packages base)
  #:use-module (gnu packages gawk)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages gettext)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages multiprecision)
  #:use-module (gnu packages make-bootstrap)
  #:use-module (gnu packages package-management)
  #:use-module (guix platform)
  #:use-module (gnu system)
  #:use-module (gnu system image)
  #:use-module (gnu system vm)
  #:use-module (gnu system install)
  #:use-module (gnu system images hurd)
  #:use-module (gnu system images novena)
  #:use-module (gnu system images pine64)
  #:use-module (gnu system images pinebook-pro)
  #:use-module (gnu tests)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (derivation->job
            image->job

            %core-packages

            arguments->systems
            cuirass-jobs))

;;; Commentary:
;;;
;;; This file defines build jobs for Cuirass.
;;;
;;; Code:

(define* (derivation->job name drv
                          #:key
                          (max-silent-time 3600)
                          (timeout (* 5 3600)))
  "Return a Cuirass job called NAME and describing DRV.

MAX-SILENT-TIME and TIMEOUT are build options passed to the daemon when
building the derivation."
  `((#:job-name . ,name)
    (#:derivation . ,(derivation-file-name drv))
    (#:inputs . ,(map (compose derivation-file-name
                               derivation-input-derivation)
                      (derivation-inputs drv)))
    (#:outputs . ,(filter-map
                   (lambda (res)
                     (match res
                       ((name . path)
                        `(,name . ,path))))
                   (derivation->output-paths drv)))
    (#:nix-name . ,(derivation-name drv))
    (#:system . ,(derivation-system drv))
    (#:max-silent-time . ,max-silent-time)
    (#:timeout . ,timeout)))

(define* (package-job store job-name package system
                      #:key cross? target (suffix ""))
  "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
  (let ((job-name (string-append job-name "." system suffix)))
    (parameterize ((%graft? #f))
      (let* ((drv (if cross?
                      (package-cross-derivation store package target system
                                                #:graft? #f)
                      (package-derivation store package system
                                          #:graft? #f)))
             (max-silent-time (or (assoc-ref (package-properties package)
                                             'max-silent-time)
                                  3600))
             (timeout (or (assoc-ref (package-properties package)
                                     'timeout)
                          72000)))
        (derivation->job job-name drv
                         #:max-silent-time max-silent-time
                         #:timeout timeout)))))

(define (package-cross-job store job-name package target system)
  "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
SYSTEM."
  (let ((name (string-append target "." job-name)))
    (package-job store name package system
                 #:cross? #t
                 #:target target)))

(define %core-packages
  ;; Note: Don't put the '-final' package variants because (1) that's
  ;; implicit, and (2) they cannot be cross-built (due to the explicit input
  ;; chain.)
  (list gcc-10 gcc-11 gcc-12 glibc binutils gdb-minimal
        gmp mpfr mpc coreutils findutils diffutils patch sed grep
        gawk gnu-gettext hello guile-2.2 guile-3.0 zlib gzip xz guix
        %bootstrap-binaries-tarball
        %binutils-bootstrap-tarball
        (%glibc-bootstrap-tarball)
        %gcc-bootstrap-tarball
        %guile-bootstrap-tarball
        %bootstrap-tarballs))

(define (commencement-packages system)
  "Return the list of bootstrap packages from the commencement module for
SYSTEM."
  ;; Only include packages supported on SYSTEM.  For example, the Mes
  ;; bootstrap graph is currently not supported on ARM so it should be
  ;; excluded.
  (filter (lambda (obj)
            (and (package? obj)
                 (supported-package? obj system)))
          (module-map (lambda (sym var)
                        (variable-ref var))
                      (resolve-module '(gnu packages commencement)))))

(define (packages-to-cross-build target)
  "Return the list of packages to cross-build for TARGET."
  ;; Don't cross-build the bootstrap tarballs for MinGW.
  (if (string-contains target "mingw")
      (drop-right %core-packages 6)
      %core-packages))

(define (cross-jobs store system)
  "Return a list of cross-compilation jobs for SYSTEM."
  (define (from-32-to-64? target)
    ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit.  This hack
    ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
    ;; mips64el-linux-gnuabi64.
    (and (or (string-prefix? "i686-" system)
             (string-prefix? "i586-" system)
             (string-prefix? "armhf-" system))
         (string-contains target "64")))    ;x86_64, mips64el, aarch64, etc.

  (define (same? target)
    ;; Return true if SYSTEM and TARGET are the same thing.  This is so we
    ;; don't try to cross-compile to 'mips64el-linux-gnu' from
    ;; 'mips64el-linux'.
    (or (string-contains target system)
        (and (string-prefix? "armhf" system)    ;armhf-linux
             (string-prefix? "arm" target))))   ;arm-linux-gnueabihf

  (define (pointless? target)
    ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
    (match system
      ((or "x86_64-linux" "i686-linux")
       (if (string-contains target "mingw")
           (not (string=? "x86_64-linux" system))
           #f))
      (_
       ;; Don't try to cross-compile from non-Intel platforms: this isn't
       ;; very useful and these are often brittle configurations.
       #t)))

  (define (either proc1 proc2 proc3)
    (lambda (x)
      (or (proc1 x) (proc2 x) (proc3 x))))

  (append-map (lambda (target)
                (map (lambda (package)
                       (package-cross-job store (job-name package)
                                          package target system))
                     (packages-to-cross-build target)))
              (remove (either from-32-to-64? same? pointless?)
                      (targets))))

(define* (guix-jobs store systems #:key source commit)
  "Return a list of jobs for Guix itself."
  (define build
    (primitive-load (string-append source "/build-aux/build-self.scm")))

  (map
   (lambda (system)
     (let ((name (string->symbol
                  (string-append "guix." system)))
           (drv (run-with-store store
                  (build source #:version commit #:system system
                         #:pull-version 1
                         #:guile-version "2.2"))))
       (derivation->job name drv)))
   systems))

;; Architectures that are able to build or cross-build Guix System images.
;; This does not mean that other architectures are not supported, only that
;; they are often not fast enough to support Guix System images building.
(define %guix-system-supported-systems
  '("x86_64-linux" "i686-linux"))

(define %guix-system-images
  (list hurd-barebones-qcow2-image
        pine64-barebones-raw-image
        pinebook-pro-barebones-raw-image
        novena-barebones-raw-image))

(define (hours hours)
  (* 3600 hours))

(define* (image->job store image
                     #:key name system)
  "Return the job for IMAGE on SYSTEM.  If NAME is passed, use it as job name,
otherwise use the IMAGE name."
  (let* ((image-name (or name
                         (symbol->string (image-name image))))
         (name (string-append image-name "." system))
         (drv (run-with-store store
                (mbegin %store-monad
                  (set-guile-for-build (default-guile))
                  (lower-object (system-image image) system)))))
    (parameterize ((%graft? #f))
      (derivation->job name drv))))

(define* (image-jobs store system
                     #:key source commit)
  "Return a list of jobs that build images for SYSTEM."
  (define MiB
    (expt 2 20))

  (parameterize ((current-guix-package
                  (channel-source->package source #:commit commit)))
    (if (member system %guix-system-supported-systems)
        `(,(image->job store
                       (image
                        (inherit efi-disk-image)
                        (operating-system installation-os))
                       #:name "usb-image"
                       #:system system)
          ,(image->job
            store
            (image
             (inherit (image-with-label
                       iso9660-image
                       (string-append "GUIX_" system "_"
                                      (if (> (string-length %guix-version) 7)
                                          (substring %guix-version 0 7)
                                          %guix-version))))
             (operating-system installation-os))
            #:name "iso9660-image"
            #:system system)
          ;; Only cross-compile Guix System images from x86_64-linux for now.
          ,@(if (string=? system "x86_64-linux")
                (map (cut image->job store <>
                          #:system system)
                     %guix-system-images)
                '()))
        '())))

(define* (system-test-jobs store system
                           #:key source commit)
  "Return a list of jobs for the system tests."
  (define (->job test)
    (let ((name (string-append "test." (system-test-name test)
                               "." system))
          (drv (run-with-store store
                 (mbegin %store-monad
                   (set-current-system system)
                   (set-grafting #f)
                   (set-guile-for-build (default-guile))
                   (system-test-value test)))))

      (derivation->job name drv)))

  (if (member system %guix-system-supported-systems)
      ;; Override the value of 'current-guix' used by system tests.  Using a
      ;; channel instance makes tests that rely on 'current-guix' less
      ;; expensive.  It also makes sure we get a valid Guix package when this
      ;; code is not running from a checkout.
      (parameterize ((current-guix-package
                      (channel-source->package source #:commit commit)))
        (map ->job (all-system-tests)))
      '()))

(define (tarball-jobs store system)
  "Return jobs to build the self-contained Guix binary tarball."
  (define (->job name drv)
    (let ((name (string-append name "." system)))
      (parameterize ((%graft? #f))
        (derivation->job name drv))))

  ;; XXX: Add a job for the stable Guix?
  (list
   (->job "binary-tarball"
          (run-with-store store
            (mbegin %store-monad
              (set-guile-for-build (default-guile))
              (>>= (profile-derivation (packages->manifest (list guix)))
                   (lambda (profile)
                     (self-contained-tarball "guix-binary" profile
                                             #:profile-name "current-guix"
                                             #:localstatedir? #t
                                             #:compressor
                                             (lookup-compressor "xz")))))
            #:system system))))

(define job-name
  ;; Return the name of a package's job.
  package-name)

(define package->job
  (let ((base-packages
         (delete-duplicates
          (append-map (match-lambda
                        ((_ package _ ...)
                         (match (package-transitive-inputs package)
                           (((_ inputs _ ...) ...)
                            inputs))))
                      (%final-inputs)))))
    (lambda* (store package system #:key (suffix ""))
      "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
valid.  Append SUFFIX to the job name."
      (cond ((member package base-packages)
             (package-job store (string-append "base." (job-name package))
                          package system #:suffix suffix))
            ((supported-package? package system)
             (let ((drv (package-derivation store package system
                                            #:graft? #f)))
               (and (substitutable-derivation? drv)
                    (package-job store (job-name package)
                                 package system #:suffix suffix))))
            (else
             #f)))))

(define %x86-64-micro-architectures
  ;; Micro-architectures for which we build tuned variants.
  '("westmere" "ivybridge" "haswell" "skylake" "skylake-avx512"))

(define (tuned-package-jobs store package system)
  "Return a list of jobs for PACKAGE tuned for SYSTEM's micro-architectures."
  (filter-map (lambda (micro-architecture)
                (define suffix
                  (string-append "." micro-architecture))

                (package->job store
                              (tuned-package package micro-architecture)
                              system
                              #:suffix suffix))
              (match system
                ("x86_64-linux" %x86-64-micro-architectures)
                (_ '()))))

(define (all-packages)
  "Return the list of packages to build."
  (define (adjust package result)
    (cond ((package-replacement package)
           ;; XXX: If PACKAGE and its replacement have the same name/version,
           ;; then both Cuirass jobs will have the same name, which
           ;; effectively means that the second one will be ignored.  Thus,
           ;; return the replacement first.
           (cons* (package-replacement package)   ;build both
                  package
                  result))
          ((package-superseded package)
           result)                                ;don't build it
          (else
           (cons package result))))

  (fold-packages adjust
                 (fold adjust '()                 ;include base packages
                       (match (%final-inputs)
                         (((labels packages _ ...) ...)
                          packages)))
                 #:select? (const #t)))           ;include hidden packages

(define (arguments->manifests arguments channels)
  "Return the list of manifests extracted from ARGUMENTS."
  (map (lambda (manifest)
         (any (lambda (checkout)
                (let ((path (in-vicinity checkout manifest)))
                  (and (file-exists? path)
                       path)))
              (map channel-url channels)))
       arguments))

(define (manifests->jobs store manifests)
  "Return the list of jobs for the entries in MANIFESTS, a list of file
names."
  (define (load-manifest manifest)
    (save-module-excursion
     (lambda ()
       (set-current-module (make-user-module '((guix profiles) (gnu))))
       (primitive-load manifest))))

  (define (manifest-entry-job-name entry)
    (string-append (manifest-entry-name entry) "-"
                   (manifest-entry-version entry)))

  (define (manifest-entry->job entry)
    (let* ((obj (manifest-entry-item entry))
           (drv (parameterize ((%graft? #f))
                  (run-with-store store
                    (lower-object obj))))
           (max-silent-time (or (and (package? obj)
                                     (assoc-ref (package-properties obj)
                                                'max-silent-time))
                                3600))
           (timeout (or (and (package? obj)
                             (assoc-ref (package-properties obj) 'timeout))
                        (* 5 3600))))
      (derivation->job (manifest-entry-job-name entry) drv
                       #:max-silent-time max-silent-time
                       #:timeout timeout)))

  (map manifest-entry->job
       (delete-duplicates
        (append-map (compose manifest-entries load-manifest)
                    manifests)
        manifest-entry=?)))

(define (arguments->systems arguments)
  "Return the systems list from ARGUMENTS."
  (match (assoc-ref arguments 'systems)
    (#f              %cuirass-supported-systems)
    ((lst ...)       lst)
    ((? string? str) (call-with-input-string str read))))


;;;
;;; Cuirass entry point.
;;;

(define (cuirass-jobs store arguments)
  "Register Cuirass jobs."
  (define subset
    (assoc-ref arguments 'subset))

  (define systems
    (arguments->systems arguments))

  (define channels
    (let ((channels (assq-ref arguments 'channels)))
      (map sexp->channel channels)))

  (define guix
    (find guix-channel? channels))

  (define commit
    (channel-commit guix))

  (define source
    (channel-url guix))

  ;; Turn off grafts.  Grafting is meant to happen on the user's machines.
  (parameterize ((%graft? #f))
    ;; Return one job for each package, except bootstrap packages.
    (append-map
     (lambda (system)
       (format (current-error-port)
               "evaluating for '~a' (heap size: ~a MiB)...~%"
               system
               (round
                (/ (assoc-ref (gc-stats) 'heap-size)
                   (expt 2. 20))))
       (invalidate-derivation-caches!)
       (match subset
         ('all
          ;; Build everything, including replacements.
          (let ((all (all-packages))
                (jobs (lambda (package)
                        (match (package->job store package system)
                          (#f '())
                          (main-job
                           (cons main-job
                                 (if (tunable-package? package)
                                     (tuned-package-jobs store package system)
                                     '())))))))
            (append
             (append-map jobs all)
             (cross-jobs store system))))
         ('core
          ;; Build core packages only.
          (append
           (map (lambda (package)
                  (package-job store (job-name package)
                               package system))
                (append (commencement-packages system) %core-packages))
           (cross-jobs store system)))
         ('guix
          ;; Build Guix modules only.
          (guix-jobs store systems
                     #:source source
                     #:commit commit))
         ('hello
          ;; Build hello package only.
          (let ((hello (specification->package "hello")))
            (list (package-job store (job-name hello)
                               hello system))))
         ('images
          ;; Build Guix System images only.
          (image-jobs store system
                      #:source source
                      #:commit commit))
         ('system-tests
          ;; Build Guix System tests only.
          (system-test-jobs store system
                            #:source source
                            #:commit commit))
         ('tarball
          ;; Build Guix tarball only.
          (tarball-jobs store system))
         (('custom . modules)
          ;; Build custom modules jobs only.
          (append-map
           (lambda (module)
             (let ((proc (module-ref
                          (resolve-interface module)
                          'cuirass-jobs)))
               (proc store arguments)))
           modules))
         (('channels . channels)
          ;; Build only the packages from CHANNELS.
          (let ((all (all-packages)))
            (filter-map
             (lambda (package)
               (any (lambda (channel)
                      (and (member (channel-name channel) channels)
                           (package->job store package system)))
                    (package-channels package)))
             all)))
         (('packages . rest)
          ;; Build selected list of packages only.
          (let ((packages (map specification->package rest)))
            (map (lambda (package)
                   (package-job store (job-name package)
                                package system))
                 packages)))
         (('manifests . rest)
          ;; Build packages in the list of manifests.
          (let ((manifests (arguments->manifests rest channels)))
            (manifests->jobs store manifests)))
         (else
          (error "unknown subset" subset))))
     systems)))
generated by cgit