diff options
Diffstat (limited to 'build-aux/cuirass/evaluate.scm')
| -rw-r--r-- | build-aux/cuirass/evaluate.scm | 105 |
1 files changed, 105 insertions, 0 deletions
diff --git a/build-aux/cuirass/evaluate.scm b/build-aux/cuirass/evaluate.scm new file mode 100644 index 0000000000..fc0744ad2a --- /dev/null +++ b/build-aux/cuirass/evaluate.scm @@ -0,0 +1,105 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +;;; This program replicates the behavior of Cuirass's 'evaluate' process. +;;; It displays the evaluated jobs on the standard output. + +(use-modules (guix channels) + (guix derivations) + (guix git-download) + (guix inferior) + (guix packages) + (guix store) + (guix ui) + ((guix ui) #:select (build-notifier)) + (ice-9 match) + (ice-9 threads)) + +(define %top-srcdir + (and=> (assq-ref (current-source-location) 'filename) + (lambda (file) + (canonicalize-path + (string-append (dirname file) "/../.."))))) + +(match (command-line) + ((command directory) + (let ((real-build-things build-things)) + (with-store store + ;; Make sure we don't resort to substitutes. + (set-build-options store + #:use-substitutes? #f + #:substitute-urls '()) + + ;; The evaluation of Guix itself requires building a "trampoline" + ;; program, and possibly everything it depends on. Thus, allow builds + ;; but print a notification. + (with-build-handler (build-notifier #:use-substitutes? #f) + + ;; Add %TOP-SRCDIR to the store with a proper Git predicate so we + ;; work from a clean checkout. + (let ((source (add-to-store store "guix-source" #t + "sha256" %top-srcdir + #:select? (git-predicate %top-srcdir)))) + (define instances + (list (checkout->channel-instance source))) + + (define channels + (map channel-instance-channel instances)) + + (define derivation + ;; Compute the derivation of Guix for COMMIT. + (run-with-store store + (channel-instances->derivation instances))) + + ;; TODO: Remove 'show-what-to-build' call when Cuirass' 'evaluate' + ;; scripts uses 'with-build-handler'. + (show-what-to-build store (list derivation)) + (build-derivations store (list derivation)) + + + ;; Evaluate jobs on a per-system basis for two reasons. It speeds + ;; up the evaluation speed as the evaluations can be performed + ;; concurrently. It also decreases the amount of memory needed per + ;; evaluation process. + (n-par-for-each + (/ (current-processor-count) 2) + (lambda (system) + (with-store store + (let ((inferior + (open-inferior (derivation->output-path derivation))) + (channels (map channel-instance->sexp instances))) + (inferior-eval '(use-modules (gnu ci)) inferior) + (let ((jobs + (inferior-eval-with-store + inferior store + `(lambda (store) + (cuirass-jobs store + '((subset . all) + (systems . ,(list system)) + (channels . ,channels)))))) + (file + (string-append directory "/jobs-" system ".scm"))) + (call-with-output-file file + (lambda (port) + (write jobs port))))))) + %cuirass-supported-systems)))))) + (x + (format (current-error-port) "Wrong command: ~a~%." x) + (exit 1))) |