hydra: Compute jobs in an inferior.
Previously we would rely on auto-compilation of all the Guix modules. The complete evaluation would take ~15mn on berlin.guixsd.org and require lots of RAM. This approach should be faster since potentially only part of the modules are rebuilt. Furthermore, as a side-effect, it builds the derivations that 'guix pull' uses. * build-aux/hydra/gnu-system.scm: Remove 'eval-when' form. (hydra-jobs): New procedure. * gnu/ci.scm (package->alist, qemu-jobs, system-test-jobs) (tarball-jobs): Return strings for the 'license' field. * guix/self.scm (compiled-guix)[*cli-modules*]: Add (gnu ci).master
Ludovic Courtès
parent
65ff85dcee
commit
b5f8c2c885
|
|
@ -23,39 +23,56 @@
|
|||
;;; tool.
|
||||
;;;
|
||||
|
||||
(use-modules (system base compile))
|
||||
|
||||
(eval-when (expand load eval)
|
||||
|
||||
;; Pre-load the compiler so we don't end up auto-compiling it.
|
||||
(compile #t)
|
||||
|
||||
;; Use our very own Guix modules.
|
||||
(set! %fresh-auto-compile #t)
|
||||
|
||||
;; Ignore .go files except for Guile's. This is because our checkout in the
|
||||
;; store has mtime set to the epoch, and thus .go files look newer, even
|
||||
;; though they may not correspond. Use 'reverse' so that /gnu/store/…-guile
|
||||
;; comes before /run/current-system/profile.
|
||||
(set! %load-compiled-path
|
||||
(list
|
||||
(dirname (dirname (search-path (reverse %load-compiled-path)
|
||||
"ice-9/boot-9.go")))))
|
||||
|
||||
(and=> (assoc-ref (current-source-location) 'filename)
|
||||
(lambda (file)
|
||||
(let ((dir (canonicalize-path
|
||||
(string-append (dirname file) "/../.."))))
|
||||
(format (current-error-port) "prepending ~s to the load path~%"
|
||||
dir)
|
||||
(set! %load-path (cons dir %load-path))))))
|
||||
|
||||
(use-modules (gnu ci))
|
||||
(use-modules (guix inferior) (guix channels)
|
||||
(guix)
|
||||
(guix ui)
|
||||
(srfi srfi-1)
|
||||
(ice-9 match))
|
||||
|
||||
;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output
|
||||
;; port to the bit bucket, let us write to the error port instead.
|
||||
(setvbuf (current-error-port) _IOLBF)
|
||||
(set-current-output-port (current-error-port))
|
||||
|
||||
;; Return the procedure from (gnu ci).
|
||||
hydra-jobs
|
||||
(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))
|
||||
|
||||
(define commit
|
||||
(assq-ref checkout 'revision))
|
||||
|
||||
(define source
|
||||
(assq-ref checkout 'file-name))
|
||||
|
||||
(define instance
|
||||
(checkout->channel-instance source #:commit commit))
|
||||
|
||||
(define derivation
|
||||
;; Compute the derivation of Guix for COMMIT.
|
||||
(run-with-store store
|
||||
(channel-instances->derivation (list instance))))
|
||||
|
||||
(show-what-to-build store (list derivation))
|
||||
(build-derivations store (list derivation))
|
||||
|
||||
;; Open an inferior for the just-built Guix.
|
||||
(let ((inferior (open-inferior (derivation->output-path derivation))))
|
||||
(inferior-eval '(use-modules (gnu ci) (ice-9 match)) inferior)
|
||||
|
||||
(map (match-lambda
|
||||
((name . fields)
|
||||
;; Hydra expects a thunk, so here it is.
|
||||
(cons name (lambda () fields))))
|
||||
(inferior-eval-with-store inferior store
|
||||
`(lambda (store)
|
||||
(map (match-lambda
|
||||
((name . thunk)
|
||||
(cons name (thunk))))
|
||||
(hydra-jobs store ',arguments)))))))
|
||||
|
|
|
|||
20
gnu/ci.scm
20
gnu/ci.scm
|
|
@ -27,7 +27,8 @@
|
|||
#:use-module (guix derivations)
|
||||
#: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 +70,16 @@
|
|||
#: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)
|
||||
|
|
@ -133,7 +143,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)
|
||||
|
|
@ -194,7 +204,7 @@ system.")
|
|||
(description . ,(format #f "GuixSD '~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)
|
||||
|
|
@ -217,7 +227,7 @@ system.")
|
|||
(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+)
|
||||
(license . ,(license-name gpl3+))
|
||||
(home-page . ,%guix-home-page-url)
|
||||
(maintainers . ("bug-guix@gnu.org"))))
|
||||
|
||||
|
|
|
|||
|
|
@ -624,7 +624,8 @@ assumed to be part of MODULES."
|
|||
|
||||
(define *cli-modules*
|
||||
(scheme-node "guix-cli"
|
||||
(scheme-modules* source "/guix/scripts")
|
||||
(append (scheme-modules* source "/guix/scripts")
|
||||
`((gnu ci)))
|
||||
(list *core-modules* *extra-modules*
|
||||
*core-package-modules* *package-modules*
|
||||
*system-modules*)
|
||||
|
|
|
|||
Loading…
Reference in New Issue