Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
e87f0591 | 2 | ;;; Copyright © 2012, 2013, 2014, 2015 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) |
14a1c319 LC |
22 | #:use-module (guix store) |
23 | #:use-module (guix derivations) | |
24 | #:use-module (guix packages) | |
07783858 | 25 | #:use-module (guix utils) |
ac5de156 | 26 | #:use-module (guix monads) |
56b82106 | 27 | #:use-module (guix gexp) |
14a1c319 LC |
28 | #:use-module (ice-9 format) |
29 | #:use-module (ice-9 match) | |
dc5669cd | 30 | #:use-module (ice-9 vlist) |
14a1c319 | 31 | #:use-module (srfi srfi-1) |
5401dd75 | 32 | #:use-module (srfi srfi-11) |
14a1c319 | 33 | #:use-module (srfi srfi-26) |
07783858 | 34 | #:use-module (srfi srfi-34) |
14a1c319 | 35 | #:use-module (srfi srfi-37) |
300868ba | 36 | #:autoload (gnu packages) (specification->package %package-module-path) |
7f3673f2 | 37 | #:autoload (guix download) (download-to-store) |
257b9341 | 38 | #:export (%standard-build-options |
e7fc17b5 LC |
39 | set-build-options-from-command-line |
40 | show-build-options-help | |
41 | ||
760c60d6 | 42 | guix-build)) |
14a1c319 | 43 | |
81fa80b2 LC |
44 | (define (register-root store paths root) |
45 | "Register ROOT as an indirect GC root for all of PATHS." | |
46 | (let* ((root (string-append (canonicalize-path (dirname root)) | |
47 | "/" root))) | |
48 | (catch 'system-error | |
49 | (lambda () | |
50 | (match paths | |
51 | ((path) | |
52 | (symlink path root) | |
53 | (add-indirect-root store root)) | |
54 | ((paths ...) | |
55 | (fold (lambda (path count) | |
56 | (let ((root (string-append root | |
57 | "-" | |
58 | (number->string count)))) | |
59 | (symlink path root) | |
60 | (add-indirect-root store root)) | |
61 | (+ 1 count)) | |
62 | 0 | |
63 | paths)))) | |
64 | (lambda args | |
65 | (leave (_ "failed to create GC root `~a': ~a~%") | |
66 | root (strerror (system-error-errno args))))))) | |
67 | ||
7f3673f2 LC |
68 | (define (package-with-source store p uri) |
69 | "Return a package based on P but with its source taken from URI. Extract | |
70 | the new package's version number from URI." | |
71 | (define (numeric-extension? file-name) | |
72 | ;; Return true if FILE-NAME ends with digits. | |
73 | (string-every char-set:hex-digit (file-extension file-name))) | |
74 | ||
75 | (define (tarball-base-name file-name) | |
76 | ;; Return the "base" of FILE-NAME, removing '.tar.gz' or similar | |
77 | ;; extensions. | |
78 | ;; TODO: Factorize. | |
79 | (cond ((numeric-extension? file-name) | |
80 | file-name) | |
81 | ((string=? (file-extension file-name) "tar") | |
82 | (file-sans-extension file-name)) | |
83 | (else | |
84 | (tarball-base-name (file-sans-extension file-name))))) | |
85 | ||
86 | (let ((base (tarball-base-name (basename uri)))) | |
87 | (let-values (((name version) | |
88 | (package-name->name+version base))) | |
89 | (package (inherit p) | |
90 | (version (or version (package-version p))) | |
91 | (source (download-to-store store uri)))))) | |
92 | ||
14a1c319 LC |
93 | \f |
94 | ;;; | |
e7fc17b5 | 95 | ;;; Standard command-line build options. |
14a1c319 LC |
96 | ;;; |
97 | ||
e7fc17b5 LC |
98 | (define (show-build-options-help) |
99 | "Display on the current output port help about the standard command-line | |
100 | options handled by 'set-build-options-from-command-line', and listed in | |
101 | '%standard-build-options'." | |
300868ba LC |
102 | (display (_ " |
103 | -L, --load-path=DIR prepend DIR to the package module search path")) | |
609354bf | 104 | (display (_ " |
14a1c319 LC |
105 | -K, --keep-failed keep build tree of failed builds")) |
106 | (display (_ " | |
107 | -n, --dry-run do not build the derivations")) | |
56b1f4b7 LC |
108 | (display (_ " |
109 | --fallback fall back to building when the substituter fails")) | |
1c3972da | 110 | (display (_ " |
692c6c15 | 111 | --no-substitutes build instead of resorting to pre-built substitutes")) |
425b0bfc LC |
112 | (display (_ " |
113 | --no-build-hook do not attempt to offload builds via the build hook")) | |
969e678e LC |
114 | (display (_ " |
115 | --max-silent-time=SECONDS | |
116 | mark the build as failed after SECONDS of silence")) | |
002622b6 LC |
117 | (display (_ " |
118 | --timeout=SECONDS mark the build as failed after SECONDS of activity")) | |
07ab4bf1 LC |
119 | (display (_ " |
120 | --verbosity=LEVEL use the given verbosity LEVEL")) | |
bf421152 | 121 | (display (_ " |
f6526eb3 LC |
122 | -c, --cores=N allow the use of up to N CPU cores for the build")) |
123 | (display (_ " | |
124 | -M, --max-jobs=N allow at most N build jobs"))) | |
14a1c319 | 125 | |
e7fc17b5 LC |
126 | (define (set-build-options-from-command-line store opts) |
127 | "Given OPTS, an alist as returned by 'args-fold' given | |
128 | '%standard-build-options', set the corresponding build options on STORE." | |
129 | ;; TODO: Add more options. | |
130 | (set-build-options store | |
131 | #:keep-failed? (assoc-ref opts 'keep-failed?) | |
132 | #:build-cores (or (assoc-ref opts 'cores) 0) | |
f6526eb3 | 133 | #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1) |
e7fc17b5 LC |
134 | #:fallback? (assoc-ref opts 'fallback?) |
135 | #:use-substitutes? (assoc-ref opts 'substitutes?) | |
136 | #:use-build-hook? (assoc-ref opts 'build-hook?) | |
137 | #:max-silent-time (assoc-ref opts 'max-silent-time) | |
002622b6 | 138 | #:timeout (assoc-ref opts 'timeout) |
b6b097ac | 139 | #:print-build-trace (assoc-ref opts 'print-build-trace?) |
e7fc17b5 | 140 | #:verbosity (assoc-ref opts 'verbosity))) |
14a1c319 | 141 | |
e7fc17b5 LC |
142 | (define %standard-build-options |
143 | ;; List of standard command-line options for tools that build something. | |
300868ba LC |
144 | (list (option '(#\L "load-path") #t #f |
145 | (lambda (opt name arg result . rest) | |
146 | ;; XXX: Imperatively modify the search paths. | |
147 | (%package-module-path (cons arg (%package-module-path))) | |
148 | (set! %load-path (cons arg %load-path)) | |
149 | (set! %load-compiled-path (cons arg %load-compiled-path)) | |
150 | ||
151 | (apply values (cons result rest)))) | |
152 | (option '(#\K "keep-failed") #f #f | |
dd67b429 LC |
153 | (lambda (opt name arg result . rest) |
154 | (apply values | |
155 | (alist-cons 'keep-failed? #t result) | |
156 | rest))) | |
56b1f4b7 | 157 | (option '("fallback") #f #f |
dd67b429 LC |
158 | (lambda (opt name arg result . rest) |
159 | (apply values | |
160 | (alist-cons 'fallback? #t | |
161 | (alist-delete 'fallback? result)) | |
162 | rest))) | |
692c6c15 | 163 | (option '("no-substitutes") #f #f |
dd67b429 LC |
164 | (lambda (opt name arg result . rest) |
165 | (apply values | |
166 | (alist-cons 'substitutes? #f | |
167 | (alist-delete 'substitutes? result)) | |
168 | rest))) | |
425b0bfc | 169 | (option '("no-build-hook") #f #f |
dd67b429 LC |
170 | (lambda (opt name arg result . rest) |
171 | (apply values | |
172 | (alist-cons 'build-hook? #f | |
173 | (alist-delete 'build-hook? result)) | |
174 | rest))) | |
969e678e | 175 | (option '("max-silent-time") #t #f |
dd67b429 LC |
176 | (lambda (opt name arg result . rest) |
177 | (apply values | |
178 | (alist-cons 'max-silent-time (string->number* arg) | |
179 | result) | |
180 | rest))) | |
002622b6 LC |
181 | (option '("timeout") #t #f |
182 | (lambda (opt name arg result . rest) | |
183 | (apply values | |
184 | (alist-cons 'timeout (string->number* arg) result) | |
185 | rest))) | |
07ab4bf1 | 186 | (option '("verbosity") #t #f |
dd67b429 | 187 | (lambda (opt name arg result . rest) |
07ab4bf1 | 188 | (let ((level (string->number arg))) |
dd67b429 LC |
189 | (apply values |
190 | (alist-cons 'verbosity level | |
191 | (alist-delete 'verbosity result)) | |
192 | rest)))) | |
e7fc17b5 | 193 | (option '(#\c "cores") #t #f |
dd67b429 | 194 | (lambda (opt name arg result . rest) |
e7fc17b5 LC |
195 | (let ((c (false-if-exception (string->number arg)))) |
196 | (if c | |
dd67b429 | 197 | (apply values (alist-cons 'cores c result) rest) |
f6526eb3 LC |
198 | (leave (_ "not a number: '~a' option argument: ~a~%") |
199 | name arg))))) | |
200 | (option '(#\M "max-jobs") #t #f | |
201 | (lambda (opt name arg result . rest) | |
202 | (let ((c (false-if-exception (string->number arg)))) | |
203 | (if c | |
204 | (apply values (alist-cons 'max-jobs c result) rest) | |
205 | (leave (_ "not a number: '~a' option argument: ~a~%") | |
206 | name arg))))))) | |
e7fc17b5 LC |
207 | |
208 | \f | |
209 | ;;; | |
210 | ;;; Command-line options. | |
211 | ;;; | |
212 | ||
213 | (define %default-options | |
214 | ;; Alist of default option values. | |
215 | `((system . ,(%current-system)) | |
05962f29 | 216 | (graft? . #t) |
e7fc17b5 LC |
217 | (substitutes? . #t) |
218 | (build-hook? . #t) | |
b6b097ac | 219 | (print-build-trace? . #t) |
e7fc17b5 LC |
220 | (max-silent-time . 3600) |
221 | (verbosity . 0))) | |
222 | ||
223 | (define (show-help) | |
224 | (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... | |
225 | Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) | |
226 | (display (_ " | |
227 | -e, --expression=EXPR build the package or derivation EXPR evaluates to")) | |
228 | (display (_ " | |
229 | -S, --source build the packages' source derivations")) | |
230 | (display (_ " | |
231 | -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) | |
232 | (display (_ " | |
233 | --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) | |
7f3673f2 LC |
234 | (display (_ " |
235 | --with-source=SOURCE | |
236 | use SOURCE when building the corresponding package")) | |
05962f29 LC |
237 | (display (_ " |
238 | --no-grafts do not graft packages")) | |
e7fc17b5 LC |
239 | (display (_ " |
240 | -d, --derivations return the derivation paths of the given packages")) | |
241 | (display (_ " | |
242 | -r, --root=FILE make FILE a symlink to the result, and register it | |
243 | as a garbage collector root")) | |
244 | (display (_ " | |
245 | --log-file return the log file names for the given derivations")) | |
246 | (newline) | |
247 | (show-build-options-help) | |
248 | (newline) | |
249 | (display (_ " | |
250 | -h, --help display this help and exit")) | |
251 | (display (_ " | |
252 | -V, --version display version information and exit")) | |
253 | (newline) | |
254 | (show-bug-report-information)) | |
255 | ||
256 | (define %options | |
257 | ;; Specifications of the command-line options. | |
258 | (cons* (option '(#\h "help") #f #f | |
259 | (lambda args | |
260 | (show-help) | |
261 | (exit 0))) | |
262 | (option '(#\V "version") #f #f | |
263 | (lambda args | |
264 | (show-version-and-exit "guix build"))) | |
265 | ||
266 | (option '(#\S "source") #f #f | |
267 | (lambda (opt name arg result) | |
268 | (alist-cons 'source? #t result))) | |
269 | (option '(#\s "system") #t #f | |
270 | (lambda (opt name arg result) | |
271 | (alist-cons 'system arg | |
272 | (alist-delete 'system result eq?)))) | |
273 | (option '("target") #t #f | |
274 | (lambda (opt name arg result) | |
275 | (alist-cons 'target arg | |
276 | (alist-delete 'target result eq?)))) | |
277 | (option '(#\d "derivations") #f #f | |
278 | (lambda (opt name arg result) | |
279 | (alist-cons 'derivations-only? #t result))) | |
280 | (option '(#\e "expression") #t #f | |
281 | (lambda (opt name arg result) | |
282 | (alist-cons 'expression arg result))) | |
283 | (option '(#\n "dry-run") #f #f | |
284 | (lambda (opt name arg result) | |
285 | (alist-cons 'dry-run? #t result))) | |
286 | (option '(#\r "root") #t #f | |
287 | (lambda (opt name arg result) | |
288 | (alist-cons 'gc-root arg result))) | |
289 | (option '("log-file") #f #f | |
290 | (lambda (opt name arg result) | |
291 | (alist-cons 'log-file? #t result))) | |
7f3673f2 LC |
292 | (option '("with-source") #t #f |
293 | (lambda (opt name arg result) | |
294 | (alist-cons 'with-source arg result))) | |
05962f29 LC |
295 | (option '("no-grafts") #f #f |
296 | (lambda (opt name arg result) | |
297 | (alist-cons 'graft? #f | |
298 | (alist-delete 'graft? result eq?)))) | |
e7fc17b5 LC |
299 | |
300 | %standard-build-options)) | |
14a1c319 | 301 | |
81fa80b2 LC |
302 | (define (options->derivations store opts) |
303 | "Given OPTS, the result of 'args-fold', return a list of derivations to | |
304 | build." | |
305 | (define package->derivation | |
306 | (match (assoc-ref opts 'target) | |
307 | (#f package-derivation) | |
308 | (triplet | |
309 | (cut package-cross-derivation <> <> triplet <>)))) | |
310 | ||
05962f29 LC |
311 | (define src? (assoc-ref opts 'source?)) |
312 | (define sys (assoc-ref opts 'system)) | |
313 | (define graft? (assoc-ref opts 'graft?)) | |
81fa80b2 | 314 | |
05962f29 LC |
315 | (parameterize ((%graft? graft?)) |
316 | (let ((opts (options/with-source store | |
317 | (options/resolve-packages store opts)))) | |
318 | (filter-map (match-lambda | |
319 | (('argument . (? package? p)) | |
320 | (if src? | |
321 | (let ((s (package-source p))) | |
322 | (package-source-derivation store s)) | |
323 | (package->derivation store p sys))) | |
324 | (('argument . (? derivation? drv)) | |
325 | drv) | |
326 | (('argument . (? derivation-path? drv)) | |
327 | (call-with-input-file drv read-derivation)) | |
328 | (('argument . (? store-path?)) | |
329 | ;; Nothing to do; maybe for --log-file. | |
330 | #f) | |
331 | (_ #f)) | |
332 | opts)))) | |
7f3673f2 | 333 | |
257b9341 | 334 | (define (options/resolve-packages store opts) |
7f3673f2 LC |
335 | "Return OPTS with package specification strings replaced by actual |
336 | packages." | |
257b9341 LC |
337 | (define system |
338 | (or (assoc-ref opts 'system) (%current-system))) | |
339 | ||
7f3673f2 LC |
340 | (map (match-lambda |
341 | (('argument . (? string? spec)) | |
342 | (if (store-path? spec) | |
343 | `(argument . ,spec) | |
344 | `(argument . ,(specification->package spec)))) | |
257b9341 LC |
345 | (('expression . str) |
346 | (match (read/eval str) | |
347 | ((? package? p) | |
348 | `(argument . ,p)) | |
349 | ((? procedure? proc) | |
e87f0591 LC |
350 | (let ((drv (run-with-store store |
351 | (mbegin %store-monad | |
352 | (set-guile-for-build (default-guile)) | |
353 | (proc)) | |
354 | #:system system))) | |
56b82106 LC |
355 | `(argument . ,drv))) |
356 | ((? gexp? gexp) | |
357 | (let ((drv (run-with-store store | |
e87f0591 LC |
358 | (mbegin %store-monad |
359 | (set-guile-for-build (default-guile)) | |
360 | (gexp->derivation "gexp" gexp | |
361 | #:system system))))) | |
257b9341 | 362 | `(argument . ,drv))))) |
7f3673f2 LC |
363 | (opt opt)) |
364 | opts)) | |
365 | ||
366 | (define (options/with-source store opts) | |
367 | "Process with 'with-source' options in OPTS, replacing the relevant package | |
368 | arguments with packages that use the specified source." | |
369 | (define new-sources | |
370 | (filter-map (match-lambda | |
371 | (('with-source . uri) | |
372 | (cons (package-name->name+version (basename uri)) | |
373 | uri)) | |
374 | (_ #f)) | |
375 | opts)) | |
376 | ||
377 | (let loop ((opts opts) | |
378 | (sources new-sources) | |
379 | (result '())) | |
380 | (match opts | |
381 | (() | |
382 | (unless (null? sources) | |
383 | (warning (_ "sources do not match any package:~{ ~a~}~%") | |
384 | (match sources | |
385 | (((name . uri) ...) | |
386 | uri)))) | |
387 | (reverse result)) | |
388 | ((('argument . (? package? p)) tail ...) | |
389 | (let ((source (assoc-ref sources (package-name p)))) | |
390 | (loop tail | |
391 | (alist-delete (package-name p) sources) | |
392 | (alist-cons 'argument | |
393 | (if source | |
394 | (package-with-source store p source) | |
395 | p) | |
396 | result)))) | |
397 | ((('with-source . _) tail ...) | |
398 | (loop tail sources result)) | |
399 | ((head tail ...) | |
400 | (loop tail sources (cons head result)))))) | |
81fa80b2 | 401 | |
14a1c319 LC |
402 | \f |
403 | ;;; | |
404 | ;;; Entry point. | |
405 | ;;; | |
406 | ||
407 | (define (guix-build . args) | |
fa14d96e LC |
408 | (define (parse-options) |
409 | ;; Return the alist of option values. | |
847391fe DP |
410 | (append (parse-options-from args) |
411 | (parse-options-from (environment-build-options)))) | |
412 | ||
413 | (define (parse-options-from args) | |
414 | ;; Actual parsing takes place here. | |
415 | (args-fold* args %options | |
a5975ced LC |
416 | (lambda (opt name arg result) |
417 | (leave (_ "~A: unrecognized option~%") name)) | |
418 | (lambda (arg result) | |
419 | (alist-cons 'argument arg result)) | |
420 | %default-options)) | |
fa14d96e | 421 | |
073c34d7 | 422 | (with-error-handling |
bf421152 LC |
423 | ;; Ask for absolute file names so that .drv file names passed from the |
424 | ;; user to 'read-derivation' are absolute when it returns. | |
425 | (with-fluids ((%file-port-name-canonicalization 'absolute)) | |
81fa80b2 LC |
426 | (let* ((opts (parse-options)) |
427 | (store (open-connection)) | |
428 | (drv (options->derivations store opts)) | |
429 | (roots (filter-map (match-lambda | |
430 | (('gc-root . root) root) | |
431 | (_ #f)) | |
432 | opts))) | |
9bb2b96a | 433 | |
e7fc17b5 | 434 | (set-build-options-from-command-line store opts) |
bdff90a1 LC |
435 | (unless (assoc-ref opts 'log-file?) |
436 | (show-what-to-build store drv | |
437 | #:use-substitutes? (assoc-ref opts 'substitutes?) | |
438 | #:dry-run? (assoc-ref opts 'dry-run?))) | |
439 | ||
81fa80b2 LC |
440 | (cond ((assoc-ref opts 'log-file?) |
441 | (for-each (lambda (file) | |
442 | (let ((log (log-file store file))) | |
443 | (if log | |
444 | (format #t "~a~%" log) | |
445 | (leave (_ "no build log for '~a'~%") | |
446 | file)))) | |
447 | (delete-duplicates | |
448 | (append (map derivation-file-name drv) | |
449 | (filter-map (match-lambda | |
450 | (('argument | |
451 | . (? store-path? file)) | |
452 | file) | |
453 | (_ #f)) | |
454 | opts))))) | |
455 | ((assoc-ref opts 'derivations-only?) | |
456 | (format #t "~{~a~%~}" (map derivation-file-name drv)) | |
457 | (for-each (cut register-root store <> <>) | |
458 | (map (compose list derivation-file-name) drv) | |
459 | roots)) | |
460 | ((not (assoc-ref opts 'dry-run?)) | |
461 | (and (build-derivations store drv) | |
462 | (for-each (lambda (d) | |
463 | (format #t "~{~a~%~}" | |
464 | (map (match-lambda | |
465 | ((out-name . out) | |
466 | (derivation->output-path | |
467 | d out-name))) | |
468 | (derivation-outputs d)))) | |
469 | drv) | |
470 | (for-each (cut register-root store <> <>) | |
471 | (map (lambda (drv) | |
472 | (map cdr | |
473 | (derivation->output-paths drv))) | |
474 | drv) | |
475 | roots)))))))) |