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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
#!/bin/sh
# -*- scheme -*-
# @configure_input@
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, 2018 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; 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)
(srfi srfi-1)
(srfi srfi-26))
(define (ref module name)
"Dynamically link variable NAME under MODULE and return it."
(let ((m (resolve-interface module)))
(module-ref m name)))
(define (absolutize directory load-path)
(if (string-prefix? "/" load-path)
load-path
(string-append directory "/" load-path)))
(define (input-checkout checkouts input-name)
"Find in CHECKOUTS the CHECKOUT corresponding to INPUT-NAME, and return it."
(find (lambda (checkout)
(string=? (assq-ref checkout #:input)
input-name))
checkouts))
(define (spec-source spec checkouts)
"Find in CHECKOUTS the directory where the #:PROC-INPUT repository of SPEC
has been checked out, and return it."
(let* ((input-name (assq-ref spec #:proc-input))
(checkout (input-checkout checkouts input-name)))
(assq-ref checkout #:directory)))
(define (spec-load-path spec checkouts)
"Find in CHECKOUTS the load paths of each SPEC's #:LOAD-PATH-INPUTS and
return them as a list."
(map (lambda (input-name)
(let* ((checkout (input-checkout checkouts input-name))
(directory (assq-ref checkout #:directory))
(load-path (assq-ref checkout #:load-path)))
(absolutize directory load-path)))
(assq-ref spec #:load-path-inputs)))
(define (spec-package-path spec checkouts)
"Find in CHECKOUTS the package paths of each SPEC's #:PACKAGE-PATH-INPUTS
and return them as a colon separated string."
(let* ((input-names (assq-ref spec #:package-path-inputs))
(checkouts (map (cut input-checkout checkouts <>) input-names)))
(string-join
(map
(lambda (checkout)
(let ((directory (assq-ref checkout #:directory))
(load-path (assq-ref checkout #:load-path)))
(absolutize directory load-path)))
checkouts)
":")))
(define (format-checkouts checkouts)
"Format checkouts the way Hydra does: #:NAME becomes the key as a symbol,
#:DIRECTORY becomes FILE-NAME and #:COMMIT becomes REVISION. The other
entries are added because they could be useful during the evaluation."
(map
(lambda (checkout)
(let loop ((in checkout)
(out '())
(name #f))
(match in
(()
(cons name out))
(((#:input . val) . rest)
(loop rest out (string->symbol val)))
(((#:directory . val) . rest)
(loop rest (cons `(file-name . ,val) out) name))
(((#:commit . val) . rest)
(loop rest (cons `(revision . ,val) out) name))
(((keyword . val) . rest)
(loop rest (cons `(,(keyword->symbol keyword) . ,val) out) name)))))
checkouts))
(define* (main #:optional (args (command-line)))
(match args
((command spec-str checkouts-str)
;; Load FILE, a Scheme file that defines Hydra jobs.
;;
;; Until FILE is loaded, we must *not* load any Guix module because the
;; user may be providing its own with #:LOAD-PATH-INPUTS, which could
;; differ from ours. The 'ref' procedure helps us achieve this.
(let* ((%user-module (make-fresh-user-module))
(spec (with-input-from-string spec-str read))
(checkouts (with-input-from-string checkouts-str read))
(source (spec-source spec checkouts))
(file (assq-ref spec #:proc-file))
(stdout (current-output-port))
(stderr (current-error-port)))
(setenv "GUIX_PACKAGE_PATH" (spec-package-path spec checkouts))
;; Since we have relative file name canonicalization by default, better
;; change to SOURCE to make sure things like 'include' with relative
;; file names work as expected.
(chdir source)
;; Change '%load-path' once and for all. We need it to be effective
;; both when we load FILE and when we later call the thunks.
(set! %load-path (append (spec-load-path spec checkouts) %load-path))
(save-module-excursion
(lambda ()
(set-current-module %user-module)
(primitive-load file)))
;; 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.
(let* ((proc (module-ref %user-module (assq-ref spec #:proc)))
(args `(,@(format-checkouts checkouts)
,@(or (assq-ref spec #:proc-args) '())))
(thunks (proc store args)))
(pretty-print
`(evaluation ,(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))))
|