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) | |
65ff85dc LC |
25 | (guix git-download) |
26 | ((guix build utils) #:select (with-directory-excursion)) | |
89cbec89 LC |
27 | (srfi srfi-19) |
28 | (ice-9 match) | |
29 | (ice-9 pretty-print) | |
30 | (ice-9 format)) | |
31 | ||
49961951 LC |
32 | (define %top-srcdir |
33 | (and=> (assq-ref (current-source-location) 'filename) | |
34 | (lambda (file) | |
35 | (canonicalize-path | |
36 | (string-append (dirname file) "/../.."))))) | |
37 | ||
89cbec89 LC |
38 | (define %user-module |
39 | ;; Hydra user module. | |
40 | (let ((m (make-module))) | |
41 | (beautify-user-module! m) | |
42 | m)) | |
43 | ||
7f4da8ff LC |
44 | (cond-expand |
45 | (guile-2.2 | |
46 | ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and | |
47 | ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. | |
48 | (define time-monotonic time-tai)) | |
49 | (else #t)) | |
50 | ||
89cbec89 LC |
51 | (define (call-with-time thunk kont) |
52 | "Call THUNK and pass KONT the elapsed time followed by THUNK's return | |
53 | values." | |
54 | (let* ((start (current-time time-monotonic)) | |
55 | (result (call-with-values thunk list)) | |
56 | (end (current-time time-monotonic))) | |
57 | (apply kont (time-difference end start) result))) | |
58 | ||
59 | (define (call-with-time-display thunk) | |
60 | "Call THUNK and write to the current output port its duration." | |
61 | (call-with-time thunk | |
62 | (lambda (time . results) | |
63 | (format #t "~,3f seconds~%" | |
64 | (+ (time-second time) | |
65 | (/ (time-nanosecond time) 1e9))) | |
66 | (apply values results)))) | |
67 | ||
4c9243b6 LC |
68 | (define (assert-valid-job job thing) |
69 | "Raise an error if THING is not an alist with a valid 'derivation' entry. | |
70 | Otherwise return THING." | |
71 | (unless (and (list? thing) | |
72 | (and=> (assoc-ref thing 'derivation) | |
73 | (lambda (value) | |
74 | (and (string? value) | |
75 | (string-suffix? ".drv" value))))) | |
76 | (error "job did not produce a valid alist" job thing)) | |
77 | thing) | |
78 | ||
89cbec89 LC |
79 | \f |
80 | ;; Without further ado... | |
81 | (match (command-line) | |
454caca8 | 82 | ((command file cuirass? ...) |
89cbec89 | 83 | ;; Load FILE, a Scheme file that defines Hydra jobs. |
9fe95946 LC |
84 | (let ((port (current-output-port)) |
85 | (real-build-things build-things)) | |
89cbec89 LC |
86 | (with-store store |
87 | ;; Make sure we don't resort to substitutes. | |
88 | (set-build-options store | |
89 | #:use-substitutes? #f | |
90 | #:substitute-urls '()) | |
91 | ||
92 | ;; Grafts can trigger early builds. We do not want that to happen | |
93 | ;; during evaluation, so use a sledgehammer to catch such problems. | |
9fe95946 LC |
94 | ;; An exception, though, is the evaluation of Guix itself, which |
95 | ;; requires building a "trampoline" program. | |
89cbec89 LC |
96 | (set! build-things |
97 | (lambda (store . args) | |
98 | (format (current-error-port) | |
9fe95946 | 99 | "warning: building things during evaluation~%") |
89cbec89 LC |
100 | (format (current-error-port) |
101 | "'build-things' arguments: ~s~%" args) | |
9fe95946 | 102 | (apply real-build-things store args))) |
89cbec89 | 103 | |
65ff85dc LC |
104 | ;; Add %TOP-SRCDIR to the store with a proper Git predicate so we work |
105 | ;; from a clean checkout | |
106 | (let ((source (add-to-store store "guix-source" #t | |
107 | "sha256" %top-srcdir | |
108 | #:select? (git-predicate %top-srcdir)))) | |
109 | (with-directory-excursion source | |
110 | (save-module-excursion | |
111 | (lambda () | |
112 | (set-current-module %user-module) | |
113 | (format (current-error-port) | |
114 | "loading '~a' relative to '~a'...~%" | |
115 | file source) | |
116 | (primitive-load file)))) | |
117 | ||
118 | ;; Call the entry point of FILE and print the resulting job sexp. | |
119 | (pretty-print | |
120 | (match ((module-ref %user-module | |
121 | (if (equal? cuirass? "cuirass") | |
122 | 'cuirass-jobs | |
123 | 'hydra-jobs)) | |
124 | store `((guix | |
125 | . ((file-name . ,source))))) | |
126 | (((names . thunks) ...) | |
127 | (map (lambda (job thunk) | |
128 | (format (current-error-port) "evaluating '~a'... " job) | |
129 | (force-output (current-error-port)) | |
130 | (cons job | |
131 | (assert-valid-job job | |
132 | (call-with-time-display thunk)))) | |
133 | names thunks))) | |
134 | port))))) | |
89cbec89 | 135 | ((command _ ...) |
454caca8 JN |
136 | (format (current-error-port) "Usage: ~a FILE [cuirass] |
137 | Evaluate the Hydra or Cuirass jobs defined in FILE.~%" | |
89cbec89 LC |
138 | command) |
139 | (exit 1))) | |
140 | ||
141 | ;;; Local Variables: | |
142 | ;;; eval: (put 'call-with-time 'scheme-indent-function 1) | |
143 | ;;; End: | |
144 |