From 7b2f9e0de1ad2d320973b7aea132a8afcad8bece Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Cl=C3=A9ment=20Lassieur?= Date: Tue, 26 Jun 2018 11:18:23 +0200 Subject: Add support for multiple inputs. * Makefile.am (dist_sql_DATA): Add src/sql/upgrade-1.sql. * bin/cuirass.in (show-help, %options, main): Remove the LOAD-PATH option that was used afterwards as %GUIX-PACKAGE-PATH. * bin/evaluate.in (absolutize, input-checkout, spec-source, spec-load-path, spec-package-path, format-checkouts): New procedures. (%not-colon): Remove variable. (main): Take the load path, package path and PROC from the checkouts that result from the inputs. Format the checkouts before sending them to the procedure. Remove the LOAD-PATH argument. * doc/cuirass.texi (Overview, Database schema): Document the changes. * examples/{guix-jobs.scm, hello-git.scm, hello-singleton.scm, hello-subset.scm, random.scm}: Adapt to the new specification format. * examples/guix-track-git.scm (package->spec): Rename to PACKAGE->INPUT. (package->git-tracked): Replace FETCH-REPOSITORY with FETCH-INPUT and handle the new format of its return value. * examples/random-jobs.scm (make-random-jobs): Rename RANDOM to CHECKOUT. Rename the checkout from 'random (which is a specification) to 'cuirass (which is a checkout resulting from an input). * src/cuirass/base.scm (fetch-repository): Rename to fetch-input. Rename SPEC to INPUT. Return a checkout object instead of returning two values. (evaluate): Take a list of CHECKOUTS and COMMITS as arguments, instead of SOURCE. Remove TOKENIZE and LOAD-PATH. Pass the CHECKOUTS instead of the SOURCE to "evaluate". Remove %GUIX-PACKAGE-PATH. Build the EVAL object instead of getting it from "evaluate". (compile?, fetch-inputs, compile-checkouts): New procedures. (process-specs): Fetch all inputs instead of only fetching one repository. The result of that fetching operation is a list of CHECKOUTS whose COMMITS are used as a STAMP. (%guix-package-path, set-guix-package-path): Remove them. * src/cuirass/database.scm (db-add-input, db-get-inputs): New procedures. (db-add-specification, db-get-specifications): Adapt to the new specification format. Add/get all inputs as well. (db-add-evaluation): Rename REVISION to COMMITS. Store COMMITS as space separated commit hashes. (db-get-builds): Rename REPO_NAME to NAME. (db-get-stamp): Rename COMMIT to STAMP. Return #f when there is no STAMP. (db-add-stamp): Rename COMMIT to STAMP. Deal with DB-GET-STAMP's new return value. (db-get-evaluations): Rename REVISION to COMMITS. Tokenize COMMITS. * src/cuirass/utils.scm (%non-blocking): Export it. * src/schema.sql (Inputs): New table that refers to the Specifications table. (Specifications): Move input related fields to the Inputs table. Rename REPO_NAME to NAME. Rename ARGUMENTS to PROC_ARGS. Rename FILE to PROC_FILE. Add LOAD_PATH_INPUTS, PACKAGE_PATH_INPUTS and PROC_INPUT fields that refer to the Inputs table. (Stamps): Rename REPO_NAME to NAME. (Evaluations): Rename REPO_NAME to NAME. Rename REVISION to COMMITS. (Specifications_index): Replace with Inputs_index. * src/sql/upgrade-1.sql: New file. * tests/database.scm (example-spec, make-dummy-eval, sqlite-exec): Adapt to the new specifications format. Rename REVISION to COMMITS. * tests/http.scm (evaluations-query-result, fill-db): Idem. --- bin/cuirass.in | 5 +-- bin/evaluate.in | 120 ++++++++++++++++++++++++++++++++++++++++---------------- 2 files changed, 88 insertions(+), 37 deletions(-) (limited to 'bin') diff --git a/bin/cuirass.in b/bin/cuirass.in index b7c9144..11eb975 100644 --- a/bin/cuirass.in +++ b/bin/cuirass.in @@ -9,6 +9,7 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" ;;; Copyright © 2016 Mathieu Lirzin ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018 Clément Lassieur ;;; ;;; This file is part of Cuirass. ;;; @@ -42,7 +43,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" --one-shot Evaluate and build jobs only once --cache-directory=DIR Use DIR for storing repository data --fallback Fall back to building when the substituter fails. - -L --load-path=DIR Prepend DIR to Guix package module search path. -S --specifications=SPECFILE Add specifications from SPECFILE to database. -D --database=DB Use DB to store build results. @@ -59,7 +59,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" (define %options '((one-shot (value #f)) (cache-directory (value #t)) - (load-path (single-char #\L) (value #t)) (specifications (single-char #\S) (value #t)) (database (single-char #\D) (value #t)) (port (single-char #\p) (value #t)) @@ -88,8 +87,6 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" (%package-database (option-ref opts 'database (%package-database))) (%package-cachedir (option-ref opts 'cache-directory (%package-cachedir))) - (%guix-package-path - (option-ref opts 'load-path (%guix-package-path))) (%use-substitutes? (option-ref opts 'use-substitutes #f)) (%fallback? (option-ref opts 'fallback #f))) (cond diff --git a/bin/evaluate.in b/bin/evaluate.in index 86d0e83..3f08b92 100644 --- a/bin/evaluate.in +++ b/bin/evaluate.in @@ -27,32 +27,96 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" ;; Note: Do not use any Guix modules (see below). (use-modules (ice-9 match) - (ice-9 pretty-print)) + (ice-9 pretty-print) + (srfi srfi-1) + (srfi srfi-26)) (define (ref module name) "Dynamically link variable NAME under MODULE and return it." (let ((m (resolve-interface module))) (module-ref m name))) -(define %not-colon - (char-set-complement (char-set #\:))) +(define (absolutize directory load-path) + (if (string-prefix? "/" load-path) + load-path + (string-append directory "/" load-path))) + +(define (input-checkout checkouts input-name) + "Find in CHECKOUTS the CHECKOUT corresponding to INPUT-NAME, and return it." + (find (lambda (checkout) + (string=? (assq-ref checkout #:name) + input-name)) + checkouts)) + +(define (spec-source spec checkouts) + "Find in CHECKOUTS the directory where the #:PROC-INPUT repository of SPEC +has been checked out, and return it." + (let* ((input-name (assq-ref spec #:proc-input)) + (checkout (input-checkout checkouts input-name))) + (assq-ref checkout #:directory))) + +(define (spec-load-path spec checkouts) + "Find in CHECKOUTS the load paths of each SPEC's #:LOAD-PATH-INPUTS and +return them as a list." + (map (lambda (input-name) + (let* ((checkout (input-checkout checkouts input-name)) + (directory (assq-ref checkout #:directory)) + (load-path (assq-ref checkout #:load-path))) + (absolutize directory load-path))) + (assq-ref spec #:load-path-inputs))) + +(define (spec-package-path spec checkouts) + "Find in CHECKOUTS the package paths of each SPEC's #:PACKAGE-PATH-INPUTS +and return them as a colon separated string." + (let* ((input-names (assq-ref spec #:package-path-inputs)) + (checkouts (map (cut input-checkout checkouts <>) input-names))) + (string-join + (map + (lambda (checkout) + (let ((directory (assq-ref checkout #:directory)) + (load-path (assq-ref checkout #:load-path))) + (absolutize directory load-path))) + checkouts) + ":"))) + +(define (format-checkouts checkouts) + "Format checkouts the way Hydra does: #:NAME becomes the key as a symbol, +#:DIRECTORY becomes FILE-NAME and #:COMMIT becomes REVISION. The other +entries are added because they could be useful during the evaluation." + (map + (lambda (checkout) + (let loop ((in checkout) + (out '()) + (name #f)) + (match in + (() + (cons name out)) + (((#:name . val) . rest) + (loop rest out (string->symbol val))) + (((#:directory . val) . rest) + (loop rest (cons `(file-name . ,val) out) name)) + (((#:commit . val) . rest) + (loop rest (cons `(revision . ,val) out) name)) + (((keyword . val) . rest) + (loop rest (cons `(,(keyword->symbol keyword) . ,val) out) name))))) + checkouts)) (define* (main #:optional (args (command-line))) (match args - ((command load-path guix-package-path source specstr) + ((command spec-str checkouts-str) ;; Load FILE, a Scheme file that defines Hydra jobs. ;; - ;; Until FILE is loaded, we must *not* load any Guix module because - ;; SOURCE may be providing its own, which could differ from ours--this is - ;; the case when SOURCE is a Guix checkout. The 'ref' procedure helps us - ;; achieve this. - (let ((%user-module (make-fresh-user-module)) - (spec (with-input-from-string specstr read)) - (stdout (current-output-port)) - (stderr (current-error-port)) - (load-path (string-tokenize load-path %not-colon))) - (unless (string-null? guix-package-path) - (setenv "GUIX_PACKAGE_PATH" guix-package-path)) + ;; Until FILE is loaded, we must *not* load any Guix module because the + ;; user may be providing its own with #:LOAD-PATH-INPUTS, which could + ;; differ from ours. The 'ref' procedure helps us achieve this. + (let* ((%user-module (make-fresh-user-module)) + (spec (with-input-from-string spec-str read)) + (checkouts (with-input-from-string checkouts-str read)) + (source (spec-source spec checkouts)) + (file (assq-ref spec #:proc-file)) + (stdout (current-output-port)) + (stderr (current-error-port))) + (setenv "GUIX_PACKAGE_PATH" (spec-package-path spec checkouts)) ;; Since we have relative file name canonicalization by default, better ;; change to SOURCE to make sure things like 'include' with relative @@ -60,13 +124,13 @@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" (chdir source) ;; Change '%load-path' once and for all. We need it to be effective - ;; both when we load SPEC's #:file and when we later call the thunks. - (set! %load-path (append load-path %load-path)) + ;; both when we load FILE and when we later call the thunks. + (set! %load-path (append (spec-load-path spec checkouts) %load-path)) (save-module-excursion (lambda () (set-current-module %user-module) - (primitive-load (assq-ref spec #:file)))) + (primitive-load file))) ;; From there on we can access Guix modules. @@ -93,22 +157,12 @@ building things during evaluation~%") (apply real-build-things store args)))) ;; Call the entry point of FILE and print the resulting job sexp. - ;; Among the arguments, always pass 'file-name' and 'revision' like - ;; Hydra does. - (let* ((proc-name (assq-ref spec #:proc)) - (proc (module-ref %user-module proc-name)) - (commit (assq-ref spec #:current-commit)) - (name (assq-ref spec #:name)) - (args `((guix - (revision . ,commit) - (file-name . ,source)) - ,@(or (assq-ref spec #:arguments) '()))) - (thunks (proc store args)) - (eval `((#:specification . ,name) - (#:revision . ,commit)))) + (let* ((proc (module-ref %user-module (assq-ref spec #:proc))) + (args `(,@(format-checkouts checkouts) + ,@(or (assq-ref spec #:proc-args) '()))) + (thunks (proc store args))) (pretty-print - `(evaluation ,eval - ,(map (lambda (thunk) (thunk)) + `(evaluation ,(map (lambda (thunk) (thunk)) thunks)) stdout))))) ((command _ ...) -- cgit v1.2.3