;;; 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>
+;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of GNU Guix.
;;;
#: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)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
- #:export (hydra-jobs))
+ #:export (channel-instance->package
+ hydra-jobs))
;;; Commentary:
;;;
#: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)
"aarch64-linux-gnu"
"powerpc-linux-gnu"
"i586-pc-gnu" ;aka. GNU/Hurd
- "i686-w64-mingw32"))
+ "i686-w64-mingw32"
+ "x86_64-w64-mingw32"))
(define %guixsd-supported-systems
'("x86_64-linux" "i686-linux" "armhf-linux"))
(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"))))
"Return the list of packages to build."
(define (adjust package result)
(cond ((package-replacement package)
- (cons* package ;build both
- (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
load-manifest)
manifests))))
+(define (find-current-checkout arguments)
+ "Find the first checkout of ARGUMENTS that provided the current file.
+Return #f if no such checkout is found."
+ (let ((current-root
+ (canonicalize-path
+ (string-append (dirname (current-filename)) "/.."))))
+ (find (lambda (argument)
+ (and=> (assq-ref argument 'file-name)
+ (lambda (name)
+ (string=? name current-root)))) arguments)))
+
\f
;;;
;;; Hydra entry point.
((lst ...) lst)
((? string? str) (call-with-input-string str read))))
+ (define checkout
+ (or (find-current-checkout arguments)
+ (assq-ref arguments 'superior-guix-checkout)))
+
+ (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)
HCoop / jackhill / guix / guix.git / blobdiff