2016-07-12 11:42:20 +02:00
|
|
|
#!/bin/sh
|
|
|
|
# -*- scheme -*-
|
2016-11-12 17:36:18 +01:00
|
|
|
# @configure_input@
|
2016-07-24 12:49:32 +02:00
|
|
|
GUILE_LOAD_PATH="$1${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH"
|
2016-07-12 11:42:20 +02:00
|
|
|
export GUILE_LOAD_PATH
|
|
|
|
exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
|
|
|
|
!#
|
2016-11-12 17:36:18 +01:00
|
|
|
;;;; evaluate -- convert a specification to a job list
|
2016-07-12 11:42:20 +02:00
|
|
|
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
|
2017-02-24 18:27:29 +01:00
|
|
|
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
|
2017-01-25 09:54:54 +01:00
|
|
|
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
2016-07-12 11:42:20 +02:00
|
|
|
;;;
|
|
|
|
;;; This file is part of Cuirass.
|
|
|
|
;;;
|
2016-07-23 12:10:04 +02:00
|
|
|
;;; 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.
|
2016-07-12 11:42:20 +02:00
|
|
|
;;;
|
2016-07-23 12:10:04 +02:00
|
|
|
;;; Cuirass is distributed in the hope that it will be useful,
|
|
|
|
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
2016-07-12 11:42:20 +02:00
|
|
|
;;; 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 <http://www.gnu.org/licenses/>.
|
|
|
|
|
2016-08-02 17:04:00 +02:00
|
|
|
(use-modules (cuirass)
|
2016-07-24 12:49:32 +02:00
|
|
|
(cuirass utils)
|
2016-07-12 11:42:20 +02:00
|
|
|
(ice-9 match)
|
|
|
|
(ice-9 pretty-print)
|
2016-07-24 12:49:32 +02:00
|
|
|
(guix store))
|
2016-07-12 11:42:20 +02:00
|
|
|
|
|
|
|
(define* (main #:optional (args (command-line)))
|
|
|
|
(match args
|
2017-01-25 09:54:54 +01:00
|
|
|
((command load-path guix-package-path cachedir specstr database)
|
2016-07-12 11:42:20 +02:00
|
|
|
;; Load FILE, a Scheme file that defines Hydra jobs.
|
2016-07-23 21:55:41 +02:00
|
|
|
(let ((%user-module (make-fresh-user-module))
|
|
|
|
(spec (with-input-from-string specstr read))
|
|
|
|
(stdout (current-output-port))
|
|
|
|
(stderr (current-error-port)))
|
2016-07-12 11:42:20 +02:00
|
|
|
(save-module-excursion
|
|
|
|
(λ ()
|
|
|
|
(set-current-module %user-module)
|
|
|
|
(with-directory-excursion
|
|
|
|
(string-append cachedir "/" (assq-ref spec #:name))
|
|
|
|
(primitive-load (assq-ref spec #:file)))))
|
|
|
|
(with-store store
|
2016-09-15 22:50:42 +02:00
|
|
|
(unless (assoc-ref spec #:use-substitutes?)
|
|
|
|
;; Make sure we don't resort to substitutes.
|
|
|
|
(set-build-options store #:use-substitutes? #f #:substitute-urls '()))
|
2016-07-12 11:42:20 +02:00
|
|
|
;; Grafts can trigger early builds. We do not want that to happen
|
|
|
|
;; during evaluation, so use a sledgehammer to catch such problems.
|
|
|
|
(set! build-things
|
|
|
|
(λ (store . args)
|
|
|
|
(display "error: trying to build things during evaluation!~%"
|
|
|
|
stderr)
|
2016-07-24 12:49:00 +02:00
|
|
|
(simple-format stderr "'build-things' arguments: ~S~%" args)
|
2016-07-12 11:42:20 +02:00
|
|
|
(exit 1)))
|
2016-09-15 22:50:42 +02:00
|
|
|
(parameterize ((%package-database database)
|
|
|
|
(%use-substitutes? (assoc-ref spec #:use-substitutes?)))
|
2017-01-25 09:54:54 +01:00
|
|
|
(unless (string-null? guix-package-path)
|
|
|
|
(set-guix-package-path! guix-package-path))
|
2016-07-24 17:48:03 +02:00
|
|
|
;; Call the entry point of FILE and print the resulting job sexp.
|
2016-09-14 23:14:57 +02:00
|
|
|
(let* ((proc-name (assq-ref spec #:proc))
|
|
|
|
(proc (module-ref %user-module proc-name))
|
2016-07-26 16:53:57 +02:00
|
|
|
(thunks (proc store (assq-ref spec #:arguments)))
|
|
|
|
(db (db-open))
|
2016-07-27 19:19:26 +02:00
|
|
|
(commit (assq-ref spec #:current-commit))
|
2017-02-24 18:27:29 +01:00
|
|
|
(eval `((#:specification . ,(assq-ref spec #:name))
|
2016-07-27 19:19:26 +02:00
|
|
|
(#:revision . ,commit)))
|
|
|
|
(eval-id (db-add-evaluation db eval)))
|
2016-07-24 17:48:03 +02:00
|
|
|
(pretty-print
|
|
|
|
(map (λ (thunk)
|
|
|
|
(let* ((job (call-with-time-display thunk))
|
|
|
|
;; Keep track of SPEC id in the returned jobs.
|
2016-07-26 16:53:57 +02:00
|
|
|
(job* (acons #:eval-id eval-id job)))
|
|
|
|
(db-add-derivation db job*)
|
2016-07-24 17:48:03 +02:00
|
|
|
job*))
|
|
|
|
thunks)
|
|
|
|
stdout)
|
|
|
|
(db-close db))))))
|
2016-07-12 11:42:20 +02:00
|
|
|
((command _ ...)
|
2016-07-24 12:49:00 +02:00
|
|
|
(simple-format (current-error-port) "Usage: ~A FILE
|
2016-07-12 11:42:20 +02:00
|
|
|
Evaluate the Hydra jobs defined in FILE.~%"
|
2016-07-24 17:48:03 +02:00
|
|
|
command)
|
2016-07-12 11:42:20 +02:00
|
|
|
(exit 1))))
|