1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
;;; This program replicates the behavior of Hydra's 'hydra-eval-guile-job'.
;;; It evaluates the Hydra job defined by the program passed as its first
;;; arguments and outputs an sexp of the jobs on standard output.
(use-modules (guix store)
(guix git-download)
((guix build utils) #:select (with-directory-excursion))
(srfi srfi-19)
(ice-9 match)
(ice-9 pretty-print)
(ice-9 format))
(define %top-srcdir
(and=> (assq-ref (current-source-location) 'filename)
(lambda (file)
(canonicalize-path
(string-append (dirname file) "/../..")))))
(define %user-module
;; Hydra user module.
(let ((m (make-module)))
(beautify-user-module! m)
m))
(cond-expand
(guile-2.2
;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
(define time-monotonic time-tai))
(else #t))
(define (call-with-time thunk kont)
"Call THUNK and pass KONT the elapsed time followed by THUNK's return
values."
(let* ((start (current-time time-monotonic))
(result (call-with-values thunk list))
(end (current-time time-monotonic)))
(apply kont (time-difference end start) result)))
(define (call-with-time-display thunk)
"Call THUNK and write to the current output port its duration."
(call-with-time thunk
(lambda (time . results)
(format #t "~,3f seconds~%"
(+ (time-second time)
(/ (time-nanosecond time) 1e9)))
(apply values results))))
(define (assert-valid-job job thing)
"Raise an error if THING is not an alist with a valid 'derivation' entry.
Otherwise return THING."
(unless (and (list? thing)
(and=> (assoc-ref thing 'derivation)
(lambda (value)
(and (string? value)
(string-suffix? ".drv" value)))))
(error "job did not produce a valid alist" job thing))
thing)
;; Without further ado...
(match (command-line)
((command file cuirass? ...)
;; Load FILE, a Scheme file that defines Hydra jobs.
(let ((port (current-output-port))
(real-build-things build-things))
(with-store store
;; 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.
(set! build-things
(lambda (store . args)
(format (current-error-port)
"warning: building things during evaluation~%")
(format (current-error-port)
"'build-things' arguments: ~s~%" args)
(apply real-build-things store args)))
;; Add %TOP-SRCDIR to the store with a proper Git predicate so we work
;; from a clean checkout
(let ((source (add-to-store store "guix-source" #t
"sha256" %top-srcdir
#:select? (git-predicate %top-srcdir))))
(with-directory-excursion source
(save-module-excursion
(lambda ()
(set-current-module %user-module)
(format (current-error-port)
"loading '~a' relative to '~a'...~%"
file source)
(primitive-load file))))
;; Call the entry point of FILE and print the resulting job sexp.
(pretty-print
(match ((module-ref %user-module
(if (equal? cuirass? "cuirass")
'cuirass-jobs
'hydra-jobs))
store `((guix
. ((file-name . ,source)))))
(((names . thunks) ...)
(map (lambda (job thunk)
(format (current-error-port) "evaluating '~a'... " job)
(force-output (current-error-port))
(cons job
(assert-valid-job job
(call-with-time-display thunk))))
names thunks)))
port)))))
((command _ ...)
(format (current-error-port) "Usage: ~a FILE [cuirass]
Evaluate the Hydra or Cuirass jobs defined in FILE.~%"
command)
(exit 1)))
;;; Local Variables:
;;; eval: (put 'call-with-time 'scheme-indent-function 1)
;;; End:
|