Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
7d85fcde | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> |
dc5669cd | 3 | ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> |
14a1c319 | 4 | ;;; |
233e7676 | 5 | ;;; This file is part of GNU Guix. |
14a1c319 | 6 | ;;; |
233e7676 | 7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
14a1c319 LC |
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 | ;;; | |
233e7676 | 12 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
14a1c319 LC |
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 | |
233e7676 | 18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
14a1c319 | 19 | |
e49951eb | 20 | (define-module (guix scripts build) |
073c34d7 | 21 | #:use-module (guix ui) |
88981dd3 | 22 | #:use-module (guix scripts) |
14a1c319 LC |
23 | #:use-module (guix store) |
24 | #:use-module (guix derivations) | |
25 | #:use-module (guix packages) | |
7adf9b84 | 26 | #:use-module (guix grafts) |
9a2a2005 | 27 | |
3e30cdf1 LC |
28 | #:use-module (guix utils) |
29 | ||
9a2a2005 | 30 | ;; Use the procedure that destructures "NAME-VERSION" forms. |
3e30cdf1 LC |
31 | #:use-module ((guix build utils) |
32 | #:select ((package-name->name+version | |
33 | . hyphen-package-name->name+version))) | |
9a2a2005 | 34 | |
ac5de156 | 35 | #:use-module (guix monads) |
56b82106 | 36 | #:use-module (guix gexp) |
3f208ad7 | 37 | #:autoload (guix http-client) (http-fetch http-get-error?) |
14a1c319 LC |
38 | #:use-module (ice-9 format) |
39 | #:use-module (ice-9 match) | |
dc5669cd | 40 | #:use-module (ice-9 vlist) |
14a1c319 | 41 | #:use-module (srfi srfi-1) |
5401dd75 | 42 | #:use-module (srfi srfi-11) |
14a1c319 | 43 | #:use-module (srfi srfi-26) |
07783858 | 44 | #:use-module (srfi srfi-34) |
14a1c319 | 45 | #:use-module (srfi srfi-37) |
300868ba | 46 | #:autoload (gnu packages) (specification->package %package-module-path) |
7f3673f2 | 47 | #:autoload (guix download) (download-to-store) |
257b9341 | 48 | #:export (%standard-build-options |
e7fc17b5 | 49 | set-build-options-from-command-line |
2d977638 | 50 | set-build-options-from-command-line* |
e7fc17b5 | 51 | show-build-options-help |
88ad6ded LC |
52 | |
53 | %transformation-options | |
629a064f | 54 | options->transformation |
88ad6ded | 55 | show-transformation-options-help |
e7fc17b5 | 56 | |
1c6b2d3f | 57 | guix-build |
a09b45da CM |
58 | register-root |
59 | register-root*)) | |
14a1c319 | 60 | |
3f208ad7 LC |
61 | (define %default-log-urls |
62 | ;; Default base URLs for build logs. | |
63 | '("http://hydra.gnu.org/log")) | |
64 | ||
65 | ;; XXX: The following procedure cannot be in (guix store) because of the | |
66 | ;; dependency on (guix derivations). | |
67 | (define* (log-url store file #:key (base-urls %default-log-urls)) | |
68 | "Return a URL under one of the BASE-URLS where a build log for FILE can be | |
69 | found. Return #f if no build log was found." | |
70 | (define (valid-url? url) | |
71 | ;; Probe URL and return #t if it is accessible. | |
7d85fcde | 72 | (catch #t |
c22a4757 LC |
73 | (lambda () |
74 | (guard (c ((http-get-error? c) #f)) | |
75 | (close-port (http-fetch url #:buffered? #f)) | |
76 | #t)) | |
7d85fcde LC |
77 | (match-lambda* |
78 | (('getaddrinfo-error . _) | |
79 | #f) | |
80 | (('tls-certificate-error args ...) | |
81 | (report-error (G_ "cannot access build log at '~a':~%") url) | |
82 | (print-exception (current-error-port) #f | |
83 | 'tls-certificate-error args) | |
84 | (exit 1)) | |
85 | ((key . args) | |
86 | (apply throw key args))))) | |
3f208ad7 LC |
87 | |
88 | (define (find-url file) | |
89 | (let ((base (basename file))) | |
90 | (any (lambda (base-url) | |
91 | (let ((url (string-append base-url "/" base))) | |
92 | (and (valid-url? url) url))) | |
93 | base-urls))) | |
94 | ||
95 | (cond ((derivation-path? file) | |
96 | (catch 'system-error | |
97 | (lambda () | |
98 | ;; Usually we'll have more luck with the output file name since | |
99 | ;; the deriver that was used by the server could be different, so | |
100 | ;; try one of the output file names. | |
015f17e8 | 101 | (let ((drv (read-derivation-from-file file))) |
3f208ad7 LC |
102 | (or (find-url (derivation->output-path drv)) |
103 | (find-url file)))) | |
104 | (lambda args | |
105 | ;; As a last resort, try the .drv. | |
106 | (if (= ENOENT (system-error-errno args)) | |
107 | (find-url file) | |
108 | (apply throw args))))) | |
109 | (else | |
110 | (find-url file)))) | |
111 | ||
81fa80b2 LC |
112 | (define (register-root store paths root) |
113 | "Register ROOT as an indirect GC root for all of PATHS." | |
840f38ba LC |
114 | (let* ((root (if (string-prefix? "/" root) |
115 | root | |
116 | (string-append (canonicalize-path (dirname root)) | |
117 | "/" root)))) | |
81fa80b2 LC |
118 | (catch 'system-error |
119 | (lambda () | |
120 | (match paths | |
121 | ((path) | |
122 | (symlink path root) | |
123 | (add-indirect-root store root)) | |
124 | ((paths ...) | |
125 | (fold (lambda (path count) | |
126 | (let ((root (string-append root | |
127 | "-" | |
128 | (number->string count)))) | |
129 | (symlink path root) | |
130 | (add-indirect-root store root)) | |
131 | (+ 1 count)) | |
132 | 0 | |
133 | paths)))) | |
134 | (lambda args | |
69daee23 | 135 | (leave (G_ "failed to create GC root `~a': ~a~%") |
81fa80b2 LC |
136 | root (strerror (system-error-errno args))))))) |
137 | ||
a09b45da CM |
138 | (define register-root* |
139 | (store-lift register-root)) | |
140 | ||
3e30cdf1 LC |
141 | (define (numeric-extension? file-name) |
142 | "Return true if FILE-NAME ends with digits." | |
143 | (string-every char-set:hex-digit (file-extension file-name))) | |
144 | ||
145 | (define (tarball-base-name file-name) | |
146 | "Return the \"base\" of FILE-NAME, removing '.tar.gz' or similar | |
147 | extensions." | |
148 | ;; TODO: Factorize. | |
149 | (cond ((not (file-extension file-name)) | |
150 | file-name) | |
151 | ((numeric-extension? file-name) | |
152 | file-name) | |
153 | ((string=? (file-extension file-name) "tar") | |
154 | (file-sans-extension file-name)) | |
155 | ((file-extension file-name) | |
156 | => | |
157 | (match-lambda | |
158 | ("scm" file-name) | |
159 | (else (tarball-base-name (file-sans-extension file-name))))) | |
160 | (else | |
161 | file-name))) | |
162 | ||
163 | (define* (package-with-source store p uri #:optional version) | |
7f3673f2 LC |
164 | "Return a package based on P but with its source taken from URI. Extract |
165 | the new package's version number from URI." | |
7f3673f2 | 166 | (let ((base (tarball-base-name (basename uri)))) |
3e30cdf1 LC |
167 | (let-values (((_ version*) |
168 | (hyphen-package-name->name+version base))) | |
7f3673f2 | 169 | (package (inherit p) |
3e30cdf1 LC |
170 | (version (or version version* |
171 | (package-version p))) | |
a43b55f1 LC |
172 | |
173 | ;; Use #:recursive? #t to allow for directories. | |
174 | (source (download-to-store store uri | |
7c247809 LC |
175 | #:recursive? #t)) |
176 | ||
177 | ;; Override the replacement, otherwise '--with-source' would | |
178 | ;; have no effect. | |
179 | (replacement #f))))) | |
7f3673f2 | 180 | |
14a1c319 | 181 | \f |
88ad6ded LC |
182 | ;;; |
183 | ;;; Transformations. | |
184 | ;;; | |
185 | ||
186 | (define (transform-package-source sources) | |
187 | "Return a transformation procedure that replaces package sources with the | |
188 | matching URIs given in SOURCES." | |
189 | (define new-sources | |
190 | (map (lambda (uri) | |
3e30cdf1 LC |
191 | (match (string-index uri #\=) |
192 | (#f | |
193 | ;; Determine the package name and version from URI. | |
194 | (call-with-values | |
195 | (lambda () | |
196 | (hyphen-package-name->name+version | |
197 | (tarball-base-name (basename uri)))) | |
198 | (lambda (name version) | |
199 | (list name version uri)))) | |
200 | (index | |
201 | ;; What's before INDEX is a "PKG@VER" or "PKG" spec. | |
202 | (call-with-values | |
203 | (lambda () | |
204 | (package-name->name+version (string-take uri index))) | |
205 | (lambda (name version) | |
206 | (list name version | |
207 | (string-drop uri (+ 1 index)))))))) | |
88ad6ded LC |
208 | sources)) |
209 | ||
210 | (lambda (store obj) | |
211 | (let loop ((sources new-sources) | |
212 | (result '())) | |
213 | (match obj | |
214 | ((? package? p) | |
3e30cdf1 LC |
215 | (match (assoc-ref sources (package-name p)) |
216 | ((version source) | |
217 | (package-with-source store p source version)) | |
218 | (#f | |
219 | p))) | |
88ad6ded LC |
220 | (_ |
221 | obj))))) | |
222 | ||
5cf01aa5 LC |
223 | (define (evaluate-replacement-specs specs proc) |
224 | "Parse SPECS, a list of strings like \"guile=guile@2.1\", and invoke PROC on | |
225 | each package pair specified by SPECS. Return the resulting list. Raise an | |
226 | error if an element of SPECS uses invalid syntax, or if a package it refers to | |
227 | could not be found." | |
47c0f92c LC |
228 | (define not-equal |
229 | (char-set-complement (char-set #\=))) | |
230 | ||
5cf01aa5 LC |
231 | (map (lambda (spec) |
232 | (match (string-tokenize spec not-equal) | |
233 | ((old new) | |
234 | (proc (specification->package old) | |
235 | (specification->package new))) | |
236 | (x | |
69daee23 | 237 | (leave (G_ "invalid replacement specification: ~s~%") spec)))) |
5cf01aa5 LC |
238 | specs)) |
239 | ||
240 | (define (transform-package-inputs replacement-specs) | |
241 | "Return a procedure that, when passed a package, replaces its direct | |
242 | dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of | |
243 | strings like \"guile=guile@2.1\" meaning that, any dependency on a package | |
244 | called \"guile\" must be replaced with a dependency on a version 2.1 of | |
245 | \"guile\"." | |
246 | (let* ((replacements (evaluate-replacement-specs replacement-specs cons)) | |
247 | (rewrite (package-input-rewriting replacements))) | |
4e49163f LC |
248 | (lambda (store obj) |
249 | (if (package? obj) | |
250 | (rewrite obj) | |
251 | obj)))) | |
47c0f92c | 252 | |
645b9df8 LC |
253 | (define (transform-package-inputs/graft replacement-specs) |
254 | "Return a procedure that, when passed a package, replaces its direct | |
255 | dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of | |
256 | strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the | |
257 | current 'gnutls' package, after which version 3.5.4 is grafted onto them." | |
258 | (define (replacement-pair old new) | |
259 | (cons old | |
260 | (package (inherit old) (replacement new)))) | |
261 | ||
262 | (let* ((replacements (evaluate-replacement-specs replacement-specs | |
263 | replacement-pair)) | |
264 | (rewrite (package-input-rewriting replacements))) | |
265 | (lambda (store obj) | |
266 | (if (package? obj) | |
267 | (rewrite obj) | |
268 | obj)))) | |
269 | ||
88ad6ded LC |
270 | (define %transformations |
271 | ;; Transformations that can be applied to things to build. The car is the | |
272 | ;; key used in the option alist, and the cdr is the transformation | |
273 | ;; procedure; it is called with two arguments: the store, and a list of | |
274 | ;; things to build. | |
47c0f92c | 275 | `((with-source . ,transform-package-source) |
645b9df8 LC |
276 | (with-input . ,transform-package-inputs) |
277 | (with-graft . ,transform-package-inputs/graft))) | |
88ad6ded LC |
278 | |
279 | (define %transformation-options | |
280 | ;; The command-line interface to the above transformations. | |
31c2fd1e LC |
281 | (let ((parser (lambda (symbol) |
282 | (lambda (opt name arg result . rest) | |
283 | (apply values | |
284 | (alist-cons symbol arg result) | |
285 | rest))))) | |
286 | (list (option '("with-source") #t #f | |
287 | (parser 'with-source)) | |
288 | (option '("with-input") #t #f | |
645b9df8 LC |
289 | (parser 'with-input)) |
290 | (option '("with-graft") #t #f | |
291 | (parser 'with-graft))))) | |
88ad6ded LC |
292 | |
293 | (define (show-transformation-options-help) | |
69daee23 | 294 | (display (G_ " |
88ad6ded | 295 | --with-source=SOURCE |
47c0f92c | 296 | use SOURCE when building the corresponding package")) |
69daee23 | 297 | (display (G_ " |
47c0f92c | 298 | --with-input=PACKAGE=REPLACEMENT |
645b9df8 | 299 | replace dependency PACKAGE by REPLACEMENT")) |
69daee23 | 300 | (display (G_ " |
645b9df8 LC |
301 | --with-graft=PACKAGE=REPLACEMENT |
302 | graft REPLACEMENT on packages that refer to PACKAGE"))) | |
88ad6ded LC |
303 | |
304 | ||
305 | (define (options->transformation opts) | |
306 | "Return a procedure that, when passed an object to build (package, | |
307 | derivation, etc.), applies the transformations specified by OPTS." | |
308 | (define applicable | |
309 | ;; List of applicable transformations as symbol/procedure pairs. | |
310 | (filter-map (match-lambda | |
311 | ((key . transform) | |
312 | (match (filter-map (match-lambda | |
313 | ((k . arg) | |
314 | (and (eq? k key) arg))) | |
315 | opts) | |
316 | (() #f) | |
317 | (args (cons key (transform args)))))) | |
318 | %transformations)) | |
319 | ||
320 | (lambda (store obj) | |
321 | (fold (match-lambda* | |
322 | (((name . transform) obj) | |
323 | (let ((new (transform store obj))) | |
324 | (when (eq? new obj) | |
69daee23 | 325 | (warning (G_ "transformation '~a' had no effect on ~a~%") |
88ad6ded LC |
326 | name |
327 | (if (package? obj) | |
328 | (package-full-name obj) | |
329 | obj))) | |
330 | new))) | |
331 | obj | |
332 | applicable))) | |
333 | ||
334 | \f | |
14a1c319 | 335 | ;;; |
e7fc17b5 | 336 | ;;; Standard command-line build options. |
14a1c319 LC |
337 | ;;; |
338 | ||
e7fc17b5 LC |
339 | (define (show-build-options-help) |
340 | "Display on the current output port help about the standard command-line | |
341 | options handled by 'set-build-options-from-command-line', and listed in | |
342 | '%standard-build-options'." | |
69daee23 | 343 | (display (G_ " |
300868ba | 344 | -L, --load-path=DIR prepend DIR to the package module search path")) |
69daee23 | 345 | (display (G_ " |
14a1c319 | 346 | -K, --keep-failed keep build tree of failed builds")) |
69daee23 | 347 | (display (G_ " |
f4953019 | 348 | -k, --keep-going keep going when some of the derivations fail")) |
69daee23 | 349 | (display (G_ " |
14a1c319 | 350 | -n, --dry-run do not build the derivations")) |
69daee23 | 351 | (display (G_ " |
56b1f4b7 | 352 | --fallback fall back to building when the substituter fails")) |
69daee23 | 353 | (display (G_ " |
692c6c15 | 354 | --no-substitutes build instead of resorting to pre-built substitutes")) |
69daee23 | 355 | (display (G_ " |
f8a8e0fe LC |
356 | --substitute-urls=URLS |
357 | fetch substitute from URLS if they are authorized")) | |
69daee23 | 358 | (display (G_ " |
7573d30f | 359 | --no-grafts do not graft packages")) |
69daee23 | 360 | (display (G_ " |
425b0bfc | 361 | --no-build-hook do not attempt to offload builds via the build hook")) |
69daee23 | 362 | (display (G_ " |
969e678e LC |
363 | --max-silent-time=SECONDS |
364 | mark the build as failed after SECONDS of silence")) | |
69daee23 | 365 | (display (G_ " |
002622b6 | 366 | --timeout=SECONDS mark the build as failed after SECONDS of activity")) |
69daee23 | 367 | (display (G_ " |
07ab4bf1 | 368 | --verbosity=LEVEL use the given verbosity LEVEL")) |
69daee23 | 369 | (display (G_ " |
5b74fe06 | 370 | --rounds=N build N times in a row to detect non-determinism")) |
69daee23 | 371 | (display (G_ " |
f6526eb3 | 372 | -c, --cores=N allow the use of up to N CPU cores for the build")) |
69daee23 | 373 | (display (G_ " |
f6526eb3 | 374 | -M, --max-jobs=N allow at most N build jobs"))) |
14a1c319 | 375 | |
e7fc17b5 LC |
376 | (define (set-build-options-from-command-line store opts) |
377 | "Given OPTS, an alist as returned by 'args-fold' given | |
378 | '%standard-build-options', set the corresponding build options on STORE." | |
379 | ;; TODO: Add more options. | |
380 | (set-build-options store | |
381 | #:keep-failed? (assoc-ref opts 'keep-failed?) | |
f4953019 | 382 | #:keep-going? (assoc-ref opts 'keep-going?) |
5b74fe06 | 383 | #:rounds (assoc-ref opts 'rounds) |
d9da3a75 LC |
384 | #:build-cores (assoc-ref opts 'cores) |
385 | #:max-build-jobs (assoc-ref opts 'max-jobs) | |
e7fc17b5 LC |
386 | #:fallback? (assoc-ref opts 'fallback?) |
387 | #:use-substitutes? (assoc-ref opts 'substitutes?) | |
fb4bf72b | 388 | #:substitute-urls (assoc-ref opts 'substitute-urls) |
e7fc17b5 LC |
389 | #:use-build-hook? (assoc-ref opts 'build-hook?) |
390 | #:max-silent-time (assoc-ref opts 'max-silent-time) | |
002622b6 | 391 | #:timeout (assoc-ref opts 'timeout) |
b6b097ac | 392 | #:print-build-trace (assoc-ref opts 'print-build-trace?) |
e7fc17b5 | 393 | #:verbosity (assoc-ref opts 'verbosity))) |
14a1c319 | 394 | |
2d977638 DT |
395 | (define set-build-options-from-command-line* |
396 | (store-lift set-build-options-from-command-line)) | |
397 | ||
e7fc17b5 LC |
398 | (define %standard-build-options |
399 | ;; List of standard command-line options for tools that build something. | |
300868ba LC |
400 | (list (option '(#\L "load-path") #t #f |
401 | (lambda (opt name arg result . rest) | |
402 | ;; XXX: Imperatively modify the search paths. | |
403 | (%package-module-path (cons arg (%package-module-path))) | |
223d7939 | 404 | (%patch-path (cons arg (%patch-path))) |
300868ba LC |
405 | (set! %load-path (cons arg %load-path)) |
406 | (set! %load-compiled-path (cons arg %load-compiled-path)) | |
407 | ||
408 | (apply values (cons result rest)))) | |
409 | (option '(#\K "keep-failed") #f #f | |
dd67b429 LC |
410 | (lambda (opt name arg result . rest) |
411 | (apply values | |
412 | (alist-cons 'keep-failed? #t result) | |
413 | rest))) | |
f4953019 LC |
414 | (option '(#\k "keep-going") #f #f |
415 | (lambda (opt name arg result . rest) | |
416 | (apply values | |
417 | (alist-cons 'keep-going? #t result) | |
418 | rest))) | |
5b74fe06 LC |
419 | (option '("rounds") #t #f |
420 | (lambda (opt name arg result . rest) | |
421 | (apply values | |
422 | (alist-cons 'rounds (string->number* arg) | |
423 | result) | |
424 | rest))) | |
56b1f4b7 | 425 | (option '("fallback") #f #f |
dd67b429 LC |
426 | (lambda (opt name arg result . rest) |
427 | (apply values | |
428 | (alist-cons 'fallback? #t | |
429 | (alist-delete 'fallback? result)) | |
430 | rest))) | |
692c6c15 | 431 | (option '("no-substitutes") #f #f |
dd67b429 LC |
432 | (lambda (opt name arg result . rest) |
433 | (apply values | |
434 | (alist-cons 'substitutes? #f | |
435 | (alist-delete 'substitutes? result)) | |
436 | rest))) | |
f8a8e0fe LC |
437 | (option '("substitute-urls") #t #f |
438 | (lambda (opt name arg result . rest) | |
439 | (apply values | |
440 | (alist-cons 'substitute-urls | |
441 | (string-tokenize arg) | |
442 | (alist-delete 'substitute-urls result)) | |
443 | rest))) | |
7573d30f LC |
444 | (option '("no-grafts") #f #f |
445 | (lambda (opt name arg result . rest) | |
446 | (apply values | |
447 | (alist-cons 'graft? #f | |
448 | (alist-delete 'graft? result eq?)) | |
449 | rest))) | |
425b0bfc | 450 | (option '("no-build-hook") #f #f |
dd67b429 LC |
451 | (lambda (opt name arg result . rest) |
452 | (apply values | |
453 | (alist-cons 'build-hook? #f | |
454 | (alist-delete 'build-hook? result)) | |
455 | rest))) | |
969e678e | 456 | (option '("max-silent-time") #t #f |
dd67b429 LC |
457 | (lambda (opt name arg result . rest) |
458 | (apply values | |
459 | (alist-cons 'max-silent-time (string->number* arg) | |
460 | result) | |
461 | rest))) | |
002622b6 LC |
462 | (option '("timeout") #t #f |
463 | (lambda (opt name arg result . rest) | |
464 | (apply values | |
465 | (alist-cons 'timeout (string->number* arg) result) | |
466 | rest))) | |
07ab4bf1 | 467 | (option '("verbosity") #t #f |
dd67b429 | 468 | (lambda (opt name arg result . rest) |
07ab4bf1 | 469 | (let ((level (string->number arg))) |
dd67b429 LC |
470 | (apply values |
471 | (alist-cons 'verbosity level | |
472 | (alist-delete 'verbosity result)) | |
473 | rest)))) | |
e7fc17b5 | 474 | (option '(#\c "cores") #t #f |
dd67b429 | 475 | (lambda (opt name arg result . rest) |
e7fc17b5 LC |
476 | (let ((c (false-if-exception (string->number arg)))) |
477 | (if c | |
dd67b429 | 478 | (apply values (alist-cons 'cores c result) rest) |
69daee23 | 479 | (leave (G_ "not a number: '~a' option argument: ~a~%") |
f6526eb3 LC |
480 | name arg))))) |
481 | (option '(#\M "max-jobs") #t #f | |
482 | (lambda (opt name arg result . rest) | |
483 | (let ((c (false-if-exception (string->number arg)))) | |
484 | (if c | |
485 | (apply values (alist-cons 'max-jobs c result) rest) | |
69daee23 | 486 | (leave (G_ "not a number: '~a' option argument: ~a~%") |
f6526eb3 | 487 | name arg))))))) |
e7fc17b5 LC |
488 | |
489 | \f | |
490 | ;;; | |
491 | ;;; Command-line options. | |
492 | ;;; | |
493 | ||
494 | (define %default-options | |
495 | ;; Alist of default option values. | |
496 | `((system . ,(%current-system)) | |
a8d65643 | 497 | (build-mode . ,(build-mode normal)) |
05962f29 | 498 | (graft? . #t) |
e7fc17b5 LC |
499 | (substitutes? . #t) |
500 | (build-hook? . #t) | |
b6b097ac | 501 | (print-build-trace? . #t) |
e7fc17b5 LC |
502 | (verbosity . 0))) |
503 | ||
504 | (define (show-help) | |
69daee23 | 505 | (display (G_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... |
e7fc17b5 | 506 | Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) |
69daee23 | 507 | (display (G_ " |
e7fc17b5 | 508 | -e, --expression=EXPR build the package or derivation EXPR evaluates to")) |
69daee23 | 509 | (display (G_ " |
34a1783f DT |
510 | -f, --file=FILE build the package or derivation that the code within |
511 | FILE evaluates to")) | |
69daee23 | 512 | (display (G_ " |
e7fc17b5 | 513 | -S, --source build the packages' source derivations")) |
69daee23 | 514 | (display (G_ " |
2087023d | 515 | --sources[=TYPE] build source derivations; TYPE may optionally be one |
2cdfe13d | 516 | of \"package\", \"all\" (default), or \"transitive\"")) |
69daee23 | 517 | (display (G_ " |
e7fc17b5 | 518 | -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) |
69daee23 | 519 | (display (G_ " |
e7fc17b5 | 520 | --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) |
69daee23 | 521 | (display (G_ " |
e7fc17b5 | 522 | -d, --derivations return the derivation paths of the given packages")) |
69daee23 | 523 | (display (G_ " |
a8d65643 | 524 | --check rebuild items to check for non-determinism issues")) |
69daee23 | 525 | (display (G_ " |
6da5bb7b | 526 | --repair repair the specified items")) |
69daee23 | 527 | (display (G_ " |
e7fc17b5 LC |
528 | -r, --root=FILE make FILE a symlink to the result, and register it |
529 | as a garbage collector root")) | |
69daee23 | 530 | (display (G_ " |
5284339d | 531 | -q, --quiet do not show the build log")) |
69daee23 | 532 | (display (G_ " |
e7fc17b5 LC |
533 | --log-file return the log file names for the given derivations")) |
534 | (newline) | |
535 | (show-build-options-help) | |
536 | (newline) | |
88ad6ded LC |
537 | (show-transformation-options-help) |
538 | (newline) | |
69daee23 | 539 | (display (G_ " |
e7fc17b5 | 540 | -h, --help display this help and exit")) |
69daee23 | 541 | (display (G_ " |
e7fc17b5 LC |
542 | -V, --version display version information and exit")) |
543 | (newline) | |
544 | (show-bug-report-information)) | |
545 | ||
546 | (define %options | |
547 | ;; Specifications of the command-line options. | |
548 | (cons* (option '(#\h "help") #f #f | |
549 | (lambda args | |
550 | (show-help) | |
551 | (exit 0))) | |
552 | (option '(#\V "version") #f #f | |
553 | (lambda args | |
554 | (show-version-and-exit "guix build"))) | |
e7fc17b5 LC |
555 | (option '(#\S "source") #f #f |
556 | (lambda (opt name arg result) | |
2cdfe13d EB |
557 | (alist-cons 'source #t result))) |
558 | (option '("sources") #f #t | |
559 | (lambda (opt name arg result) | |
560 | (match arg | |
561 | ("package" | |
562 | (alist-cons 'source #t result)) | |
563 | ((or "all" #f) | |
564 | (alist-cons 'source package-direct-sources result)) | |
565 | ("transitive" | |
566 | (alist-cons 'source package-transitive-sources result)) | |
567 | (else | |
69daee23 | 568 | (leave (G_ "invalid argument: '~a' option argument: ~a, ~ |
2cdfe13d EB |
569 | must be one of 'package', 'all', or 'transitive'~%") |
570 | name arg))))) | |
88ad6ded LC |
571 | (option '("check") #f #f |
572 | (lambda (opt name arg result . rest) | |
573 | (apply values | |
574 | (alist-cons 'build-mode (build-mode check) | |
575 | result) | |
576 | rest))) | |
6da5bb7b LC |
577 | (option '("repair") #f #f |
578 | (lambda (opt name arg result . rest) | |
579 | (apply values | |
580 | (alist-cons 'build-mode (build-mode repair) | |
581 | result) | |
582 | rest))) | |
e7fc17b5 LC |
583 | (option '(#\s "system") #t #f |
584 | (lambda (opt name arg result) | |
585 | (alist-cons 'system arg | |
586 | (alist-delete 'system result eq?)))) | |
587 | (option '("target") #t #f | |
588 | (lambda (opt name arg result) | |
589 | (alist-cons 'target arg | |
590 | (alist-delete 'target result eq?)))) | |
591 | (option '(#\d "derivations") #f #f | |
592 | (lambda (opt name arg result) | |
593 | (alist-cons 'derivations-only? #t result))) | |
594 | (option '(#\e "expression") #t #f | |
595 | (lambda (opt name arg result) | |
596 | (alist-cons 'expression arg result))) | |
34a1783f DT |
597 | (option '(#\f "file") #t #f |
598 | (lambda (opt name arg result) | |
599 | (alist-cons 'file arg result))) | |
e7fc17b5 LC |
600 | (option '(#\n "dry-run") #f #f |
601 | (lambda (opt name arg result) | |
fd59105c | 602 | (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) |
e7fc17b5 LC |
603 | (option '(#\r "root") #t #f |
604 | (lambda (opt name arg result) | |
605 | (alist-cons 'gc-root arg result))) | |
5284339d LC |
606 | (option '(#\q "quiet") #f #f |
607 | (lambda (opt name arg result) | |
608 | (alist-cons 'quiet? #t result))) | |
e7fc17b5 LC |
609 | (option '("log-file") #f #f |
610 | (lambda (opt name arg result) | |
611 | (alist-cons 'log-file? #t result))) | |
612 | ||
88ad6ded LC |
613 | (append %transformation-options |
614 | %standard-build-options))) | |
14a1c319 | 615 | |
64ec0e29 LC |
616 | (define (options->things-to-build opts) |
617 | "Read the arguments from OPTS and return a list of high-level objects to | |
618 | build---packages, gexps, derivations, and so on." | |
20464dde LC |
619 | (define (validate-type x) |
620 | (unless (or (package? x) (derivation? x) (gexp? x) (procedure? x)) | |
69daee23 | 621 | (leave (G_ "~s: not something we can build~%") x))) |
20464dde LC |
622 | |
623 | (define (ensure-list x) | |
624 | (let ((lst (match x | |
625 | ((x ...) x) | |
626 | (x (list x))))) | |
627 | (for-each validate-type lst) | |
628 | lst)) | |
64ec0e29 LC |
629 | |
630 | (append-map (match-lambda | |
631 | (('argument . (? string? spec)) | |
632 | (cond ((derivation-path? spec) | |
015f17e8 | 633 | (list (read-derivation-from-file spec))) |
64ec0e29 LC |
634 | ((store-path? spec) |
635 | ;; Nothing to do; maybe for --log-file. | |
636 | '()) | |
637 | (else | |
638 | (list (specification->package spec))))) | |
639 | (('file . file) | |
07f80c27 | 640 | (ensure-list (load* file (make-user-module '())))) |
64ec0e29 LC |
641 | (('expression . str) |
642 | (ensure-list (read/eval str))) | |
643 | (('argument . (? derivation? drv)) | |
644 | drv) | |
64ec0e29 LC |
645 | (_ '())) |
646 | opts)) | |
647 | ||
81fa80b2 LC |
648 | (define (options->derivations store opts) |
649 | "Given OPTS, the result of 'args-fold', return a list of derivations to | |
650 | build." | |
64ec0e29 LC |
651 | (define transform |
652 | (options->transformation opts)) | |
653 | ||
81fa80b2 LC |
654 | (define package->derivation |
655 | (match (assoc-ref opts 'target) | |
656 | (#f package-derivation) | |
657 | (triplet | |
658 | (cut package-cross-derivation <> <> triplet <>)))) | |
659 | ||
2cdfe13d | 660 | (define src (assoc-ref opts 'source)) |
64ec0e29 | 661 | (define system (assoc-ref opts 'system)) |
05962f29 | 662 | (define graft? (assoc-ref opts 'graft?)) |
81fa80b2 | 663 | |
2d2f98ef LC |
664 | ;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields |
665 | ;; of user packages. Since 'guix build' is the primary tool for people | |
666 | ;; testing new packages, report such errors gracefully. | |
667 | (with-unbound-variable-handling | |
668 | (parameterize ((%graft? graft?)) | |
669 | (append-map (match-lambda | |
670 | ((? package? p) | |
671 | (let ((p (or (and graft? (package-replacement p)) p))) | |
672 | (match src | |
673 | (#f | |
674 | (list (package->derivation store p system))) | |
675 | (#t | |
676 | (match (package-source p) | |
677 | (#f | |
678 | (format (current-error-port) | |
679 | (G_ "~a: warning: \ | |
8a54c0ec | 680 | package '~a' has no source~%") |
2d2f98ef LC |
681 | (location->string (package-location p)) |
682 | (package-name p)) | |
683 | '()) | |
684 | (s | |
685 | (list (package-source-derivation store s))))) | |
686 | (proc | |
687 | (map (cut package-source-derivation store <>) | |
688 | (proc p)))))) | |
689 | ((? derivation? drv) | |
690 | (list drv)) | |
691 | ((? procedure? proc) | |
692 | (list (run-with-store store | |
693 | (mbegin %store-monad | |
694 | (set-guile-for-build (default-guile)) | |
695 | (proc)) | |
696 | #:system system))) | |
697 | ((? gexp? gexp) | |
698 | (list (run-with-store store | |
699 | (mbegin %store-monad | |
700 | (set-guile-for-build (default-guile)) | |
701 | (gexp->derivation "gexp" gexp | |
702 | #:system system)))))) | |
703 | (map (cut transform store <>) | |
704 | (options->things-to-build opts)))))) | |
64ec0e29 | 705 | |
841cb43c LC |
706 | (define (show-build-log store file urls) |
707 | "Show the build log for FILE, falling back to remote logs from URLS if | |
708 | needed." | |
709 | (let ((log (or (log-file store file) | |
710 | (log-url store file #:base-urls urls)))) | |
711 | (if log | |
712 | (format #t "~a~%" log) | |
69daee23 | 713 | (leave (G_ "no build log for '~a'~%") file)))) |
841cb43c | 714 | |
14a1c319 LC |
715 | \f |
716 | ;;; | |
717 | ;;; Entry point. | |
718 | ;;; | |
719 | ||
720 | (define (guix-build . args) | |
c8f9f247 LC |
721 | (define opts |
722 | (parse-command-line args %options | |
723 | (list %default-options))) | |
724 | ||
5284339d LC |
725 | (define quiet? |
726 | (assoc-ref opts 'quiet?)) | |
727 | ||
073c34d7 | 728 | (with-error-handling |
bf421152 LC |
729 | ;; Ask for absolute file names so that .drv file names passed from the |
730 | ;; user to 'read-derivation' are absolute when it returns. | |
731 | (with-fluids ((%file-port-name-canonicalization 'absolute)) | |
c8f9f247 LC |
732 | (with-store store |
733 | ;; Set the build options before we do anything else. | |
e7fc17b5 | 734 | (set-build-options-from-command-line store opts) |
c8f9f247 | 735 | |
5284339d LC |
736 | (parameterize ((current-build-output-port (if quiet? |
737 | (%make-void-port "w") | |
738 | (current-error-port)))) | |
739 | (let* ((mode (assoc-ref opts 'build-mode)) | |
740 | (drv (options->derivations store opts)) | |
741 | (urls (map (cut string-append <> "/log") | |
742 | (if (assoc-ref opts 'substitutes?) | |
743 | (or (assoc-ref opts 'substitute-urls) | |
744 | ;; XXX: This does not necessarily match the | |
745 | ;; daemon's substitute URLs. | |
746 | %default-substitute-urls) | |
747 | '()))) | |
748 | (items (filter-map (match-lambda | |
749 | (('argument . (? store-path? file)) | |
750 | file) | |
751 | (_ #f)) | |
752 | opts)) | |
753 | (roots (filter-map (match-lambda | |
754 | (('gc-root . root) root) | |
755 | (_ #f)) | |
756 | opts))) | |
757 | ||
6e94a574 LC |
758 | (unless (or (assoc-ref opts 'log-file?) |
759 | (assoc-ref opts 'derivations-only?)) | |
5284339d LC |
760 | (show-what-to-build store drv |
761 | #:use-substitutes? | |
762 | (assoc-ref opts 'substitutes?) | |
763 | #:dry-run? (assoc-ref opts 'dry-run?) | |
764 | #:mode mode)) | |
765 | ||
766 | (cond ((assoc-ref opts 'log-file?) | |
767 | (for-each (cut show-build-log store <> urls) | |
768 | (delete-duplicates | |
769 | (append (map derivation-file-name drv) | |
770 | items)))) | |
771 | ((assoc-ref opts 'derivations-only?) | |
772 | (format #t "~{~a~%~}" (map derivation-file-name drv)) | |
773 | (for-each (cut register-root store <> <>) | |
774 | (map (compose list derivation-file-name) drv) | |
775 | roots)) | |
776 | ((not (assoc-ref opts 'dry-run?)) | |
777 | (and (build-derivations store drv mode) | |
778 | (for-each show-derivation-outputs drv) | |
779 | (for-each (cut register-root store <> <>) | |
780 | (map (lambda (drv) | |
781 | (map cdr | |
782 | (derivation->output-paths drv))) | |
783 | drv) | |
784 | roots)))))))))) |