Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
425b0bfc | 2 | ;;; Copyright © 2012, 2013, 2014 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 (_ " |
e7fc17b5 | 122 | -c, --cores=N allow the use of up to N CPU cores for the build"))) |
14a1c319 | 123 | |
e7fc17b5 LC |
124 | (define (set-build-options-from-command-line store opts) |
125 | "Given OPTS, an alist as returned by 'args-fold' given | |
126 | '%standard-build-options', set the corresponding build options on STORE." | |
127 | ;; TODO: Add more options. | |
128 | (set-build-options store | |
129 | #:keep-failed? (assoc-ref opts 'keep-failed?) | |
130 | #:build-cores (or (assoc-ref opts 'cores) 0) | |
131 | #:fallback? (assoc-ref opts 'fallback?) | |
132 | #:use-substitutes? (assoc-ref opts 'substitutes?) | |
133 | #:use-build-hook? (assoc-ref opts 'build-hook?) | |
134 | #:max-silent-time (assoc-ref opts 'max-silent-time) | |
002622b6 | 135 | #:timeout (assoc-ref opts 'timeout) |
b6b097ac | 136 | #:print-build-trace (assoc-ref opts 'print-build-trace?) |
e7fc17b5 | 137 | #:verbosity (assoc-ref opts 'verbosity))) |
14a1c319 | 138 | |
e7fc17b5 LC |
139 | (define %standard-build-options |
140 | ;; List of standard command-line options for tools that build something. | |
300868ba LC |
141 | (list (option '(#\L "load-path") #t #f |
142 | (lambda (opt name arg result . rest) | |
143 | ;; XXX: Imperatively modify the search paths. | |
144 | (%package-module-path (cons arg (%package-module-path))) | |
145 | (set! %load-path (cons arg %load-path)) | |
146 | (set! %load-compiled-path (cons arg %load-compiled-path)) | |
147 | ||
148 | (apply values (cons result rest)))) | |
149 | (option '(#\K "keep-failed") #f #f | |
dd67b429 LC |
150 | (lambda (opt name arg result . rest) |
151 | (apply values | |
152 | (alist-cons 'keep-failed? #t result) | |
153 | rest))) | |
56b1f4b7 | 154 | (option '("fallback") #f #f |
dd67b429 LC |
155 | (lambda (opt name arg result . rest) |
156 | (apply values | |
157 | (alist-cons 'fallback? #t | |
158 | (alist-delete 'fallback? result)) | |
159 | rest))) | |
692c6c15 | 160 | (option '("no-substitutes") #f #f |
dd67b429 LC |
161 | (lambda (opt name arg result . rest) |
162 | (apply values | |
163 | (alist-cons 'substitutes? #f | |
164 | (alist-delete 'substitutes? result)) | |
165 | rest))) | |
425b0bfc | 166 | (option '("no-build-hook") #f #f |
dd67b429 LC |
167 | (lambda (opt name arg result . rest) |
168 | (apply values | |
169 | (alist-cons 'build-hook? #f | |
170 | (alist-delete 'build-hook? result)) | |
171 | rest))) | |
969e678e | 172 | (option '("max-silent-time") #t #f |
dd67b429 LC |
173 | (lambda (opt name arg result . rest) |
174 | (apply values | |
175 | (alist-cons 'max-silent-time (string->number* arg) | |
176 | result) | |
177 | rest))) | |
002622b6 LC |
178 | (option '("timeout") #t #f |
179 | (lambda (opt name arg result . rest) | |
180 | (apply values | |
181 | (alist-cons 'timeout (string->number* arg) result) | |
182 | rest))) | |
07ab4bf1 | 183 | (option '("verbosity") #t #f |
dd67b429 | 184 | (lambda (opt name arg result . rest) |
07ab4bf1 | 185 | (let ((level (string->number arg))) |
dd67b429 LC |
186 | (apply values |
187 | (alist-cons 'verbosity level | |
188 | (alist-delete 'verbosity result)) | |
189 | rest)))) | |
e7fc17b5 | 190 | (option '(#\c "cores") #t #f |
dd67b429 | 191 | (lambda (opt name arg result . rest) |
e7fc17b5 LC |
192 | (let ((c (false-if-exception (string->number arg)))) |
193 | (if c | |
dd67b429 | 194 | (apply values (alist-cons 'cores c result) rest) |
e7fc17b5 LC |
195 | (leave (_ "~a: not a number~%") arg))))))) |
196 | ||
197 | \f | |
198 | ;;; | |
199 | ;;; Command-line options. | |
200 | ;;; | |
201 | ||
202 | (define %default-options | |
203 | ;; Alist of default option values. | |
204 | `((system . ,(%current-system)) | |
05962f29 | 205 | (graft? . #t) |
e7fc17b5 LC |
206 | (substitutes? . #t) |
207 | (build-hook? . #t) | |
b6b097ac | 208 | (print-build-trace? . #t) |
e7fc17b5 LC |
209 | (max-silent-time . 3600) |
210 | (verbosity . 0))) | |
211 | ||
212 | (define (show-help) | |
213 | (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... | |
214 | Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) | |
215 | (display (_ " | |
216 | -e, --expression=EXPR build the package or derivation EXPR evaluates to")) | |
217 | (display (_ " | |
218 | -S, --source build the packages' source derivations")) | |
219 | (display (_ " | |
220 | -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) | |
221 | (display (_ " | |
222 | --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) | |
7f3673f2 LC |
223 | (display (_ " |
224 | --with-source=SOURCE | |
225 | use SOURCE when building the corresponding package")) | |
05962f29 LC |
226 | (display (_ " |
227 | --no-grafts do not graft packages")) | |
e7fc17b5 LC |
228 | (display (_ " |
229 | -d, --derivations return the derivation paths of the given packages")) | |
230 | (display (_ " | |
231 | -r, --root=FILE make FILE a symlink to the result, and register it | |
232 | as a garbage collector root")) | |
233 | (display (_ " | |
234 | --log-file return the log file names for the given derivations")) | |
235 | (newline) | |
236 | (show-build-options-help) | |
237 | (newline) | |
238 | (display (_ " | |
239 | -h, --help display this help and exit")) | |
240 | (display (_ " | |
241 | -V, --version display version information and exit")) | |
242 | (newline) | |
243 | (show-bug-report-information)) | |
244 | ||
245 | (define %options | |
246 | ;; Specifications of the command-line options. | |
247 | (cons* (option '(#\h "help") #f #f | |
248 | (lambda args | |
249 | (show-help) | |
250 | (exit 0))) | |
251 | (option '(#\V "version") #f #f | |
252 | (lambda args | |
253 | (show-version-and-exit "guix build"))) | |
254 | ||
255 | (option '(#\S "source") #f #f | |
256 | (lambda (opt name arg result) | |
257 | (alist-cons 'source? #t result))) | |
258 | (option '(#\s "system") #t #f | |
259 | (lambda (opt name arg result) | |
260 | (alist-cons 'system arg | |
261 | (alist-delete 'system result eq?)))) | |
262 | (option '("target") #t #f | |
263 | (lambda (opt name arg result) | |
264 | (alist-cons 'target arg | |
265 | (alist-delete 'target result eq?)))) | |
266 | (option '(#\d "derivations") #f #f | |
267 | (lambda (opt name arg result) | |
268 | (alist-cons 'derivations-only? #t result))) | |
269 | (option '(#\e "expression") #t #f | |
270 | (lambda (opt name arg result) | |
271 | (alist-cons 'expression arg result))) | |
272 | (option '(#\n "dry-run") #f #f | |
273 | (lambda (opt name arg result) | |
274 | (alist-cons 'dry-run? #t result))) | |
275 | (option '(#\r "root") #t #f | |
276 | (lambda (opt name arg result) | |
277 | (alist-cons 'gc-root arg result))) | |
278 | (option '("log-file") #f #f | |
279 | (lambda (opt name arg result) | |
280 | (alist-cons 'log-file? #t result))) | |
7f3673f2 LC |
281 | (option '("with-source") #t #f |
282 | (lambda (opt name arg result) | |
283 | (alist-cons 'with-source arg result))) | |
05962f29 LC |
284 | (option '("no-grafts") #f #f |
285 | (lambda (opt name arg result) | |
286 | (alist-cons 'graft? #f | |
287 | (alist-delete 'graft? result eq?)))) | |
e7fc17b5 LC |
288 | |
289 | %standard-build-options)) | |
14a1c319 | 290 | |
81fa80b2 LC |
291 | (define (options->derivations store opts) |
292 | "Given OPTS, the result of 'args-fold', return a list of derivations to | |
293 | build." | |
294 | (define package->derivation | |
295 | (match (assoc-ref opts 'target) | |
296 | (#f package-derivation) | |
297 | (triplet | |
298 | (cut package-cross-derivation <> <> triplet <>)))) | |
299 | ||
05962f29 LC |
300 | (define src? (assoc-ref opts 'source?)) |
301 | (define sys (assoc-ref opts 'system)) | |
302 | (define graft? (assoc-ref opts 'graft?)) | |
81fa80b2 | 303 | |
05962f29 LC |
304 | (parameterize ((%graft? graft?)) |
305 | (let ((opts (options/with-source store | |
306 | (options/resolve-packages store opts)))) | |
307 | (filter-map (match-lambda | |
308 | (('argument . (? package? p)) | |
309 | (if src? | |
310 | (let ((s (package-source p))) | |
311 | (package-source-derivation store s)) | |
312 | (package->derivation store p sys))) | |
313 | (('argument . (? derivation? drv)) | |
314 | drv) | |
315 | (('argument . (? derivation-path? drv)) | |
316 | (call-with-input-file drv read-derivation)) | |
317 | (('argument . (? store-path?)) | |
318 | ;; Nothing to do; maybe for --log-file. | |
319 | #f) | |
320 | (_ #f)) | |
321 | opts)))) | |
7f3673f2 | 322 | |
257b9341 | 323 | (define (options/resolve-packages store opts) |
7f3673f2 LC |
324 | "Return OPTS with package specification strings replaced by actual |
325 | packages." | |
257b9341 LC |
326 | (define system |
327 | (or (assoc-ref opts 'system) (%current-system))) | |
328 | ||
7f3673f2 LC |
329 | (map (match-lambda |
330 | (('argument . (? string? spec)) | |
331 | (if (store-path? spec) | |
332 | `(argument . ,spec) | |
333 | `(argument . ,(specification->package spec)))) | |
257b9341 LC |
334 | (('expression . str) |
335 | (match (read/eval str) | |
336 | ((? package? p) | |
337 | `(argument . ,p)) | |
338 | ((? procedure? proc) | |
339 | (let ((drv (run-with-store store (proc) #:system system))) | |
56b82106 LC |
340 | `(argument . ,drv))) |
341 | ((? gexp? gexp) | |
342 | (let ((drv (run-with-store store | |
343 | (gexp->derivation "gexp" gexp | |
344 | #:system system)))) | |
257b9341 | 345 | `(argument . ,drv))))) |
7f3673f2 LC |
346 | (opt opt)) |
347 | opts)) | |
348 | ||
349 | (define (options/with-source store opts) | |
350 | "Process with 'with-source' options in OPTS, replacing the relevant package | |
351 | arguments with packages that use the specified source." | |
352 | (define new-sources | |
353 | (filter-map (match-lambda | |
354 | (('with-source . uri) | |
355 | (cons (package-name->name+version (basename uri)) | |
356 | uri)) | |
357 | (_ #f)) | |
358 | opts)) | |
359 | ||
360 | (let loop ((opts opts) | |
361 | (sources new-sources) | |
362 | (result '())) | |
363 | (match opts | |
364 | (() | |
365 | (unless (null? sources) | |
366 | (warning (_ "sources do not match any package:~{ ~a~}~%") | |
367 | (match sources | |
368 | (((name . uri) ...) | |
369 | uri)))) | |
370 | (reverse result)) | |
371 | ((('argument . (? package? p)) tail ...) | |
372 | (let ((source (assoc-ref sources (package-name p)))) | |
373 | (loop tail | |
374 | (alist-delete (package-name p) sources) | |
375 | (alist-cons 'argument | |
376 | (if source | |
377 | (package-with-source store p source) | |
378 | p) | |
379 | result)))) | |
380 | ((('with-source . _) tail ...) | |
381 | (loop tail sources result)) | |
382 | ((head tail ...) | |
383 | (loop tail sources (cons head result)))))) | |
81fa80b2 | 384 | |
14a1c319 LC |
385 | \f |
386 | ;;; | |
387 | ;;; Entry point. | |
388 | ;;; | |
389 | ||
390 | (define (guix-build . args) | |
fa14d96e LC |
391 | (define (parse-options) |
392 | ;; Return the alist of option values. | |
a5975ced LC |
393 | (args-fold* args %options |
394 | (lambda (opt name arg result) | |
395 | (leave (_ "~A: unrecognized option~%") name)) | |
396 | (lambda (arg result) | |
397 | (alist-cons 'argument arg result)) | |
398 | %default-options)) | |
fa14d96e | 399 | |
073c34d7 | 400 | (with-error-handling |
bf421152 LC |
401 | ;; Ask for absolute file names so that .drv file names passed from the |
402 | ;; user to 'read-derivation' are absolute when it returns. | |
403 | (with-fluids ((%file-port-name-canonicalization 'absolute)) | |
81fa80b2 LC |
404 | (let* ((opts (parse-options)) |
405 | (store (open-connection)) | |
406 | (drv (options->derivations store opts)) | |
407 | (roots (filter-map (match-lambda | |
408 | (('gc-root . root) root) | |
409 | (_ #f)) | |
410 | opts))) | |
9bb2b96a | 411 | |
e7fc17b5 | 412 | (set-build-options-from-command-line store opts) |
bdff90a1 LC |
413 | (unless (assoc-ref opts 'log-file?) |
414 | (show-what-to-build store drv | |
415 | #:use-substitutes? (assoc-ref opts 'substitutes?) | |
416 | #:dry-run? (assoc-ref opts 'dry-run?))) | |
417 | ||
81fa80b2 LC |
418 | (cond ((assoc-ref opts 'log-file?) |
419 | (for-each (lambda (file) | |
420 | (let ((log (log-file store file))) | |
421 | (if log | |
422 | (format #t "~a~%" log) | |
423 | (leave (_ "no build log for '~a'~%") | |
424 | file)))) | |
425 | (delete-duplicates | |
426 | (append (map derivation-file-name drv) | |
427 | (filter-map (match-lambda | |
428 | (('argument | |
429 | . (? store-path? file)) | |
430 | file) | |
431 | (_ #f)) | |
432 | opts))))) | |
433 | ((assoc-ref opts 'derivations-only?) | |
434 | (format #t "~{~a~%~}" (map derivation-file-name drv)) | |
435 | (for-each (cut register-root store <> <>) | |
436 | (map (compose list derivation-file-name) drv) | |
437 | roots)) | |
438 | ((not (assoc-ref opts 'dry-run?)) | |
439 | (and (build-derivations store drv) | |
440 | (for-each (lambda (d) | |
441 | (format #t "~{~a~%~}" | |
442 | (map (match-lambda | |
443 | ((out-name . out) | |
444 | (derivation->output-path | |
445 | d out-name))) | |
446 | (derivation-outputs d)))) | |
447 | drv) | |
448 | (for-each (cut register-root store <> <>) | |
449 | (map (lambda (drv) | |
450 | (map cdr | |
451 | (derivation->output-paths drv))) | |
452 | drv) | |
453 | roots)))))))) |