me
/
guix
Archived
1
0
Fork 0
Code

ci: Make sure the Guix checkout is the one providing Cuirass proc. 

Fixes <https://bugs.gnu.org/36378>.
Reported by Reza Alizadeh Majd <r.majd@pantherx.org>.

* build-aux/hydra/gnu-system.scm (find-current-checkout): New procedure.
(hydra-jobs): Use FIND-CURRENT-CHECKOUT to define CHECKOUT.  Pass it to the
inferior Guix as an extra argument whose key is 'superior-guix-checkout'.
* gnu/ci.scm (find-current-checkout): New procedure.
(hydra-jobs): Use FIND-CURRENT-CHECKOUT to define CHECKOUT.  This will return
'#f' if the current Guix is an inferior.  In that case, use the
'superior-guix-checkout' argument provided by the superior Guix.
master
Clément Lassieur 2019-11-17 13:29:19 +01:00
parent db1106e2b5
commit f71b0a0012
No known key found for this signature in database
GPG Key ID: 89F96D4808F359C7
2 changed files with 36 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
build-aux/hydra/gnu-system.scm
View File

@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 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.
;;;
@ -34,16 +34,22 @@
(setvbuf (current-error-port) _IOLBF)
(set-current-output-port (current-error-port))
(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)))
(define (hydra-jobs store arguments)
"Return a list of jobs where each job is a NAME/THUNK pair."
(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))
(find-current-checkout arguments))
(define commit
(assq-ref checkout 'revision))
@ -70,9 +76,11 @@
((name . fields)
;; Hydra expects a thunk, so here it is.
(cons name (lambda () fields))))
(inferior-eval-with-store inferior store
(inferior-eval-with-store
inferior store
`(lambda (store)
(map (match-lambda
((name . thunk)
(cons name (thunk))))
(hydra-jobs store ',arguments)))))))
(hydra-jobs store '((superior-guix-checkout . ,checkout)
,@arguments))))))))

22
gnu/ci.scm
View File

@ -1,7 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; 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.
;;;
@ -374,6 +374,17 @@ valid."
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)))
;;;
;;; Hydra entry point.
@ -396,13 +407,8 @@ valid."
((? 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))
(or (find-current-checkout arguments)
(assq-ref arguments 'superior-guix-checkout)))
(define commit
(assq-ref checkout 'revision))