TakeV/guix
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

ci: Use a valid 'current-guix'.

Browse source 
This fixes a regression introduced in
b5f8c2c885 whereby 'current-guix' (needed
by some of the system tests) would fail to build.
Reported by Ricardo Wurmus <rekado@elephly.net>.

It also speeds up compilation of 'current-guix' since the channel
instance is already compiled or can be built quickly compared to the
default 'current-guix'.

* gnu/packages/package-management.scm (current-guix-package): New
variable.
(current-guix): Honor it.
* gnu/ci.scm (channel-build-system): New variable.
(channel-instances->derivation): New procedure.
(system-test-jobs): Add #:source and #:commit parameters.
Define 'instance' and parameterize CURRENT-GUIX-PACKAGE.
(hydra-jobs)[checkout, commit, source]: New variables.
Pass #:source and #:commit to 'system-test-jobs'.
This commit is contained in:
Ludovic Courtès 2019-01-20 00:20:34 +01:00
parent 38b77f3464
commit 7e6d8d366a
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 74 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

65
gnu/ci.scm
View file

@ -1,5 +1,5 @@
;;; 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>
;;;
@ -24,7 +24,9 @@ (define-module (gnu ci)
#: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)
@ -188,8 +190,40 @@ (define MiB
"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 #:allow-other-keys)
(run-with-store store
(channel-instances->derivation (list instance)))))
(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
@ -217,7 +251,13 @@ (define (->job test)
(cons name (test->thunk test))))
(if (member system %guixsd-supported-systems)
(map ->job (all-system-tests))
;; 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)
@ -343,6 +383,21 @@ (define systems
((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
@ -405,7 +460,9 @@ (define (either proc1 proc2 proc3)
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)

19
gnu/packages/package-management.scm
View file

@ -399,6 +399,12 @@ (define (wrong-extension? file)
(_
#t)))
(define-public current-guix-package
;; This parameter allows callers to override the package that 'current-guix'
;; returns. This is useful when 'current-guix' cannot compute it by itself,
;; for instance because it's not running from a source code checkout.
(make-parameter #f))
(define-public current-guix
(let* ((repository-root (canonicalize-path
(string-append (current-source-directory)
@ -409,12 +415,13 @@ (define-public current-guix
"Return a package representing Guix built from the current source tree.
This works by adding the current source tree to the store (after filtering it
out) and returning a package that uses that as its 'source'."
(package
(inherit guix)
(version (string-append (package-version guix) "+"))
(source (local-file repository-root "guix-current"
#:recursive? #t
#:select? (force select?)))))))
(or (current-guix-package)
(package
(inherit guix)
(version (string-append (package-version guix) "+"))
(source (local-file repository-root "guix-current"
#:recursive? #t
#:select? (force select?))))))))
;;;