#!/bin/sh
# -*- scheme -*-
# @configure_input@
GUILE_LOAD_PATH="$1${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH"
export GUILE_LOAD_PATH
exec ${GUILE:-@GUILE@} --no-auto-compile -e main -s "$0" "$@"
!#
;;;; evaluate -- convert a specification to a job list
;;; Copyright © 2016, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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 <http://www.gnu.org/licenses/>.


;; Note: Do not use any Guix modules (see below).
(use-modules (ice-9 match)
             (ice-9 pretty-print))

(define (ref module name)
  "Dynamically link variable NAME under MODULE and return it."
  (let ((m (resolve-interface module)))
    (module-ref m name)))

(define-syntax-rule (with-directory-excursion dir body ...)
  "Run BODY with DIR as the process's current directory."
  (let ((init (getcwd)))
   (dynamic-wind
     (lambda ()
       (chdir dir))
     (lambda ()
       body ...)
     (lambda ()
       (chdir init)))))

(define %not-colon
  (char-set-complement (char-set #\:)))

(define* (main #:optional (args (command-line)))
  (match args
    ((command load-path guix-package-path source specstr)
     ;; 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))

       (save-module-excursion
        (lambda ()
          (set-current-module %user-module)
          (with-directory-excursion source
            (let ((original-path %load-path))
              (dynamic-wind
                (lambda ()
                  (set! %load-path (append load-path original-path)))
                (lambda ()
                  (primitive-load (assq-ref spec #:file)))
                (lambda ()
                  (set! %load-path original-path)))))))

       ;; 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.
         ;; 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    `((,(string->symbol name)
                            (revision . ,commit)
                            (file-name . ,source))
                           ,@(or (assq-ref spec #:arguments) '())))
                (thunks  (proc store args))
                (eval    `((#:specification . ,name)
                           (#:revision . ,commit))))
           (pretty-print
            `(evaluation ,eval
                         ,(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))))