#!/bin/sh # -*- scheme -*- # @configure_input@ exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@" !# ;;;; evaluate -- convert a specification to a job list ;;; Copyright © 2016, 2018 Ludovic Courtès ;;; Copyright © 2016, 2017 Mathieu Lirzin ;;; Copyright © 2017, 2018 Mathieu Othacehe ;;; Copyright © 2018 Clément Lassieur ;;; ;;; This file is part of Cuirass. ;;; ;;; Cuirass 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. ;;; ;;; Cuirass 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 Cuirass. If not, see . ;; Note: Do not use any Guix modules (see below). (use-modules (ice-9 match) (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 (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 #:input) 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)) (((#:input . 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 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 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 ;; file names work as expected. (chdir source) ;; Change '%load-path' once and for all. We need it to be effective ;; 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 file))) ;; From there on we can access Guix modules. (let ((store ((ref '(guix store) 'open-connection))) (set-build-options (ref '(guix store) 'set-build-options))) (unless (assoc-ref spec #:use-substitutes?) ;; Make sure we don't resort to substitutes. (set-build-options store #:use-substitutes? #f #:substitute-urls '())) ;; Grafts can trigger early builds. We do not want that to happen ;; during evaluation, so use a sledgehammer to catch such problems. ;; An exception, though, is the evaluation of Guix itself, which ;; requires building a "trampoline" program. (let ((real-build-things (ref '(guix store) 'build-things))) (module-set! (resolve-module '(guix store)) 'build-things (lambda (store . args) (simple-format stderr "warning: building things during evaluation~%") (simple-format stderr "'build-things' arguments: ~S~%" args) (apply real-build-things store args)))) ;; Call the entry point of FILE and print the resulting job sexp. (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 ,(map (lambda (thunk) (thunk)) thunks)) stdout))))) ((command _ ...) (simple-format (current-error-port) "Usage: ~A FILE Evaluate the Hydra jobs defined in FILE.~%" command) (exit 1))))