;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
#: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)
#:graft? #f)))
(description . ,(package-synopsis package))
(long-description . ,(package-description package))
- (license . ,(package-license package))
+
+ ;; XXX: Hydra ignores licenses that are not a <license> 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)
(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)
"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
(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)
"." 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)
`((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"))))
((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
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)