Commit | Line | Data |
---|---|---|
89cbec89 | 1 | ;;; GNU Guix --- Functional package management for GNU |
9fe95946 | 2 | ;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> |
454caca8 | 3 | ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org> |
89cbec89 LC |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | ;;; This program replicates the behavior of Hydra's 'hydra-eval-guile-job'. | |
21 | ;;; It evaluates the Hydra job defined by the program passed as its first | |
22 | ;;; arguments and outputs an sexp of the jobs on standard output. | |
23 | ||
24 | (use-modules (guix store) | |
25 | (srfi srfi-19) | |
26 | (ice-9 match) | |
27 | (ice-9 pretty-print) | |
28 | (ice-9 format)) | |
29 | ||
49961951 LC |
30 | (define %top-srcdir |
31 | (and=> (assq-ref (current-source-location) 'filename) | |
32 | (lambda (file) | |
33 | (canonicalize-path | |
34 | (string-append (dirname file) "/../.."))))) | |
35 | ||
89cbec89 LC |
36 | (define %user-module |
37 | ;; Hydra user module. | |
38 | (let ((m (make-module))) | |
39 | (beautify-user-module! m) | |
40 | m)) | |
41 | ||
7f4da8ff LC |
42 | (cond-expand |
43 | (guile-2.2 | |
44 | ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and | |
45 | ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. | |
46 | (define time-monotonic time-tai)) | |
47 | (else #t)) | |
48 | ||
89cbec89 LC |
49 | (define (call-with-time thunk kont) |
50 | "Call THUNK and pass KONT the elapsed time followed by THUNK's return | |
51 | values." | |
52 | (let* ((start (current-time time-monotonic)) | |
53 | (result (call-with-values thunk list)) | |
54 | (end (current-time time-monotonic))) | |
55 | (apply kont (time-difference end start) result))) | |
56 | ||
57 | (define (call-with-time-display thunk) | |
58 | "Call THUNK and write to the current output port its duration." | |
59 | (call-with-time thunk | |
60 | (lambda (time . results) | |
61 | (format #t "~,3f seconds~%" | |
62 | (+ (time-second time) | |
63 | (/ (time-nanosecond time) 1e9))) | |
64 | (apply values results)))) | |
65 | ||
4c9243b6 LC |
66 | (define (assert-valid-job job thing) |
67 | "Raise an error if THING is not an alist with a valid 'derivation' entry. | |
68 | Otherwise return THING." | |
69 | (unless (and (list? thing) | |
70 | (and=> (assoc-ref thing 'derivation) | |
71 | (lambda (value) | |
72 | (and (string? value) | |
73 | (string-suffix? ".drv" value))))) | |
74 | (error "job did not produce a valid alist" job thing)) | |
75 | thing) | |
76 | ||
89cbec89 LC |
77 | \f |
78 | ;; Without further ado... | |
79 | (match (command-line) | |
454caca8 | 80 | ((command file cuirass? ...) |
89cbec89 | 81 | ;; Load FILE, a Scheme file that defines Hydra jobs. |
9fe95946 LC |
82 | (let ((port (current-output-port)) |
83 | (real-build-things build-things)) | |
89cbec89 LC |
84 | (save-module-excursion |
85 | (lambda () | |
86 | (set-current-module %user-module) | |
87 | (primitive-load file))) | |
88 | ||
89 | (with-store store | |
90 | ;; Make sure we don't resort to substitutes. | |
91 | (set-build-options store | |
92 | #:use-substitutes? #f | |
93 | #:substitute-urls '()) | |
94 | ||
95 | ;; Grafts can trigger early builds. We do not want that to happen | |
96 | ;; during evaluation, so use a sledgehammer to catch such problems. | |
9fe95946 LC |
97 | ;; An exception, though, is the evaluation of Guix itself, which |
98 | ;; requires building a "trampoline" program. | |
89cbec89 LC |
99 | (set! build-things |
100 | (lambda (store . args) | |
101 | (format (current-error-port) | |
9fe95946 | 102 | "warning: building things during evaluation~%") |
89cbec89 LC |
103 | (format (current-error-port) |
104 | "'build-things' arguments: ~s~%" args) | |
9fe95946 | 105 | (apply real-build-things store args))) |
89cbec89 LC |
106 | |
107 | ;; Call the entry point of FILE and print the resulting job sexp. | |
108 | (pretty-print | |
454caca8 JN |
109 | (match ((module-ref %user-module |
110 | (if (equal? cuirass? "cuirass") | |
111 | 'cuirass-jobs | |
112 | 'hydra-jobs)) | |
49961951 LC |
113 | store `((guix |
114 | . ((file-name . ,%top-srcdir))))) | |
89cbec89 LC |
115 | (((names . thunks) ...) |
116 | (map (lambda (job thunk) | |
117 | (format (current-error-port) "evaluating '~a'... " job) | |
118 | (force-output (current-error-port)) | |
4c9243b6 LC |
119 | (cons job |
120 | (assert-valid-job job | |
121 | (call-with-time-display thunk)))) | |
89cbec89 LC |
122 | names thunks))) |
123 | port)))) | |
124 | ((command _ ...) | |
454caca8 JN |
125 | (format (current-error-port) "Usage: ~a FILE [cuirass] |
126 | Evaluate the Hydra or Cuirass jobs defined in FILE.~%" | |
89cbec89 LC |
127 | command) |
128 | (exit 1))) | |
129 | ||
130 | ;;; Local Variables: | |
131 | ;;; eval: (put 'call-with-time 'scheme-indent-function 1) | |
132 | ;;; End: | |
133 |