X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/59fb5c1cdb6fa5d6d1dbeca58e33f4a01a7d98f8..85a4531f646e9f352f86870eb6c4fe7173e5bffc:/gnu/ci.scm diff --git a/gnu/ci.scm b/gnu/ci.scm index 7db7e6062f..4885870e16 100644 --- a/gnu/ci.scm +++ b/gnu/ci.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2017 Jan Nieuwenhuizen ;;; Copyright © 2018 Clément Lassieur ;;; @@ -24,10 +24,13 @@ #:use-module (guix grafts) #:use-module (guix profiles) #:use-module (guix packages) + #:use-module (guix channels) #:use-module (guix derivations) + #:use-module (guix build-system) #:use-module (guix monads) #:use-module (guix ui) - #:use-module ((guix licenses) #:select (gpl3+)) + #: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) @@ -69,7 +72,16 @@ #:graft? #f))) (description . ,(package-synopsis package)) (long-description . ,(package-description package)) - (license . ,(package-license package)) + + ;; XXX: Hydra ignores licenses that are not a structure or a + ;; list thereof. + (license . ,(let loop ((license (package-license package))) + (match license + ((? license?) + (license-name license)) + ((lst ...) + (map loop license))))) + (home-page . ,(package-home-page package)) (maintainers . ("bug-guix@gnu.org")) (max-silent-time . ,(or (assoc-ref (package-properties package) @@ -133,7 +145,7 @@ SYSTEM." (description . "Stand-alone QEMU image of the GNU system") (long-description . "This is a demo stand-alone QEMU image of the GNU system.") - (license . ,gpl3+) + (license . ,(license-name gpl3+)) (max-silent-time . 600) (timeout . 3600) (home-page . ,%guix-home-page-url) @@ -178,8 +190,42 @@ system.") "iso9660")))))) '())) -(define (system-test-jobs store system) +(define channel-build-system + ;; Build system used to "convert" a channel instance to a package. + (let* ((build (lambda* (store name inputs + #:key instance system + #:allow-other-keys) + (run-with-store store + (channel-instances->derivation (list instance)) + #:system system))) + (lower (lambda* (name #:key system instance #:allow-other-keys) + (bag + (name name) + (system system) + (build build) + (arguments `(#:instance ,instance)))))) + (build-system (name 'channel) + (description "Turn a channel instance into a package.") + (lower lower)))) + +(define (channel-instance->package instance) + "Return a package for the given channel INSTANCE." + (package + (inherit guix) + (version (or (string-take (channel-instance-commit instance) 7) + (string-append (package-version guix) "+"))) + (build-system channel-build-system) + (arguments `(#:instance ,instance)) + (inputs '()) + (native-inputs '()) + (propagated-inputs '()))) + +(define* (system-test-jobs store system + #:key source commit) "Return a list of jobs for the system tests." + (define instance + (checkout->channel-instance source #:commit commit)) + (define (test->thunk test) (lambda () (define drv @@ -191,10 +237,10 @@ system.") (system-test-value test)))) `((derivation . ,(derivation-file-name drv)) - (description . ,(format #f "GuixSD '~a' system test" + (description . ,(format #f "Guix '~a' system test" (system-test-name test))) (long-description . ,(system-test-description test)) - (license . ,gpl3+) + (license . ,(license-name gpl3+)) (max-silent-time . 600) (timeout . 3600) (home-page . ,%guix-home-page-url) @@ -206,8 +252,18 @@ system.") "." system)))) (cons name (test->thunk test)))) - (if (member system %guixsd-supported-systems) - (map ->job (all-system-tests)) + (if (and (member system %guixsd-supported-systems) + + ;; XXX: Our build farm has too few ARMv7 machines and they are very + ;; slow, so skip system tests there. + (not (string=? system "armhf-linux"))) + ;; 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-instance->package instance))) + (map ->job (all-system-tests))) '())) (define (tarball-jobs store system) @@ -216,8 +272,8 @@ system.") `((derivation . ,(derivation-file-name drv)) (description . "Stand-alone binary Guix tarball") (long-description . "This is a tarball containing binaries of Guix and -all its dependencies, and ready to be installed on non-GuixSD distributions.") - (license . ,gpl3+) +all its dependencies, and ready to be installed on \"foreign\" distributions.") + (license . ,(license-name gpl3+)) (home-page . ,%guix-home-page-url) (maintainers . ("bug-guix@gnu.org")))) @@ -333,6 +389,21 @@ valid." ((lst ...) lst) ((? string? str) (call-with-input-string str read)))) + (define checkout + ;; Extract metadata about the 'guix' checkout. Its key in ARGUMENTS may + ;; vary, so pick up the first one that's neither 'subset' nor 'systems'. + (any (match-lambda + ((key . value) + (and (not (memq key '(systems subset))) + value))) + arguments)) + + (define commit + (assq-ref checkout 'revision)) + + (define source + (assq-ref checkout 'file-name)) + (define (cross-jobs system) (define (from-32-to-64? target) ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack @@ -395,7 +466,9 @@ valid." system)))) (append (filter-map job all) (qemu-jobs store system) - (system-test-jobs store system) + (system-test-jobs store system + #:source source + #:commit commit) (tarball-jobs store system) (cross-jobs system)))) ((core)