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