| blob | 07803ca94f78b453290b1a2ee11e95e400dfbad5 |
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
4 ;;;
5 ;;; This file is part of GNU Guix.
6 ;;;
7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
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 ;;;
12 ;;; GNU Guix is distributed in the hope that it will be useful, but
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
18 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20 (define-module (guix derivations)
21 #:use-module (srfi srfi-1)
22 #:use-module (srfi srfi-9)
23 #:use-module (srfi srfi-9 gnu)
24 #:use-module (srfi srfi-26)
25 #:use-module (srfi srfi-34)
26 #:use-module (srfi srfi-35)
27 #:use-module (ice-9 binary-ports)
28 #:use-module (rnrs bytevectors)
29 #:use-module (ice-9 match)
30 #:use-module (ice-9 rdelim)
31 #:use-module (ice-9 vlist)
32 #:use-module (guix store)
33 #:use-module (guix utils)
34 #:use-module (guix base16)
35 #:use-module (guix memoization)
36 #:use-module (guix combinators)
37 #:use-module (guix monads)
38 #:use-module (guix hash)
39 #:use-module (guix base32)
40 #:use-module (guix records)
41 #:use-module (guix sets)
42 #:export (<derivation>
43 derivation?
44 derivation-outputs
45 derivation-inputs
46 derivation-sources
47 derivation-system
48 derivation-builder
49 derivation-builder-arguments
50 derivation-builder-environment-vars
51 derivation-file-name
52 derivation-prerequisites
53 derivation-prerequisites-to-build
55 <derivation-output>
56 derivation-output?
57 derivation-output-path
58 derivation-output-hash-algo
59 derivation-output-hash
60 derivation-output-recursive?
62 <derivation-input>
63 derivation-input?
64 derivation-input-path
65 derivation-input-sub-derivations
66 derivation-input-output-paths
67 valid-derivation-input?
69 &derivation-error
70 derivation-error?
71 derivation-error-derivation
72 &derivation-missing-output-error
73 derivation-missing-output-error?
74 derivation-missing-output
76 derivation-name
77 derivation-output-names
78 fixed-output-derivation?
79 offloadable-derivation?
80 substitutable-derivation?
81 substitution-oracle
82 derivation-hash
84 read-derivation
85 read-derivation-from-file
86 write-derivation
87 derivation->output-path
88 derivation->output-paths
89 derivation-path->output-path
90 derivation-path->output-paths
91 derivation
92 raw-derivation
94 map-derivation
96 build-derivations
97 built-derivations
99 file-search-error?
100 file-search-error-file-name
101 file-search-error-search-path
103 search-path*
104 module->source-file-name
105 build-expression->derivation)
107 ;; Re-export it from here for backward compatibility.
108 #:re-export (%guile-for-build))
110 ;;;
111 ;;; Error conditions.
112 ;;;
114 (define-condition-type &derivation-error &nix-error
115 derivation-error?
116 (derivation derivation-error-derivation))
118 (define-condition-type &derivation-missing-output-error &derivation-error
119 derivation-missing-output-error?
120 (output derivation-missing-output))
122 ;;;
123 ;;; Nix derivations, as implemented in Nix's `derivations.cc'.
124 ;;;
126 (define-immutable-record-type <derivation>
127 (make-derivation outputs inputs sources system builder args env-vars
128 file-name)
129 derivation?
130 (outputs derivation-outputs) ; list of name/<derivation-output> pairs
131 (inputs derivation-inputs) ; list of <derivation-input>
132 (sources derivation-sources) ; list of store paths
133 (system derivation-system) ; string
134 (builder derivation-builder) ; store path
135 (args derivation-builder-arguments) ; list of strings
136 (env-vars derivation-builder-environment-vars) ; list of name/value pairs
137 (file-name derivation-file-name)) ; the .drv file name
139 (define-record-type <derivation-output>
140 (make-derivation-output path hash-algo hash recursive?)
141 derivation-output?
142 (path derivation-output-path) ; store path
143 (hash-algo derivation-output-hash-algo) ; symbol | #f
144 (hash derivation-output-hash) ; bytevector | #f
145 (recursive? derivation-output-recursive?)) ; Boolean
147 (define-record-type <derivation-input>
148 (make-derivation-input path sub-derivations)
149 derivation-input?
150 (path derivation-input-path) ; store path
151 (sub-derivations derivation-input-sub-derivations)) ; list of strings
153 (set-record-type-printer! <derivation>
154 (lambda (drv port)
155 (format port "#<derivation ~a => ~a ~a>"
156 (derivation-file-name drv)
157 (string-join
158 (map (match-lambda
159 ((_ . output)
160 (derivation-output-path output)))
161 (derivation-outputs drv)))
162 (number->string (object-address drv) 16))))
164 (define (derivation-name drv)
165 "Return the base name of DRV."
166 (let ((base (store-path-package-name (derivation-file-name drv))))
167 (string-drop-right base 4)))
169 (define (derivation-output-names drv)
170 "Return the names of the outputs of DRV."
171 (match (derivation-outputs drv)
172 (((names . _) ...)
173 names)))
175 (define (fixed-output-derivation? drv)
176 "Return #t if DRV is a fixed-output derivation, such as the result of a
177 download with a fixed hash (aka. `fetchurl')."
178 (match drv
179 (($ <derivation>
180 (("out" . ($ <derivation-output> _ (? symbol?) (? bytevector?)))))
181 #t)
182 (_ #f)))
184 (define (derivation-input<? input1 input2)
185 "Compare INPUT1 and INPUT2, two <derivation-input>."
186 (string<? (derivation-input-path input1)
187 (derivation-input-path input2)))
189 (define (derivation-input-output-paths input)
190 "Return the list of output paths corresponding to INPUT, a
191 <derivation-input>."
192 (match input
193 (($ <derivation-input> path sub-drvs)
194 (map (cut derivation-path->output-path path <>)
195 sub-drvs))))
197 (define (valid-derivation-input? store input)
198 "Return true if INPUT is valid--i.e., if all the outputs it requests are in
199 the store."
200 (every (cut valid-path? store <>)
201 (derivation-input-output-paths input)))
203 (define (coalesce-duplicate-inputs inputs)
204 "Return a list of inputs, such that when INPUTS contains the same DRV twice,
205 they are coalesced, with their sub-derivations merged. This is needed because
206 Nix itself keeps only one of them."
207 (fold (lambda (input result)
208 (match input
209 (($ <derivation-input> path sub-drvs)
210 ;; XXX: quadratic
211 (match (find (match-lambda
212 (($ <derivation-input> p s)
213 (string=? p path)))
214 result)
215 (#f
216 (cons input result))
217 ((and dup ($ <derivation-input> _ sub-drvs2))
218 ;; Merge DUP with INPUT.
219 (let ((sub-drvs (delete-duplicates
220 (append sub-drvs sub-drvs2))))
221 (cons (make-derivation-input path
222 (sort sub-drvs string<?))
223 (delq dup result))))))))
224 '()
225 inputs))
227 (define* (derivation-prerequisites drv #:optional (cut? (const #f)))
228 "Return the list of derivation-inputs required to build DRV, recursively.
230 CUT? is a predicate that is passed a derivation-input and returns true to
231 eliminate the given input and its dependencies from the search. An example of
232 search a predicate is 'valid-derivation-input?'; when it is used as CUT?, the
233 result is the set of prerequisites of DRV not already in valid."
234 (let loop ((drv drv)
235 (result '())
236 (input-set (set)))
237 (let ((inputs (remove (lambda (input)
238 (or (set-contains? input-set input)
239 (cut? input)))
240 (derivation-inputs drv))))
241 (fold2 loop
242 (append inputs result)
243 (fold set-insert input-set inputs)
244 (map (lambda (i)
245 (read-derivation-from-file (derivation-input-path i)))
246 inputs)))))
248 (define (offloadable-derivation? drv)
249 "Return true if DRV can be offloaded, false otherwise."
250 (match (assoc "preferLocalBuild"
251 (derivation-builder-environment-vars drv))
252 (("preferLocalBuild" . "1") #f)
253 (_ #t)))
255 (define (substitutable-derivation? drv)
256 "Return #t if DRV can be substituted."
257 (match (assoc "allowSubstitutes"
258 (derivation-builder-environment-vars drv))
259 (("allowSubstitutes" . value)
260 (string=? value "1"))
261 (_ #t)))
263 (define (derivation-output-paths drv sub-drvs)
264 "Return the output paths of outputs SUB-DRVS of DRV."
265 (match drv
266 (($ <derivation> outputs)
267 (map (lambda (sub-drv)
268 (derivation-output-path (assoc-ref outputs sub-drv)))
269 sub-drvs))))
271 (define* (substitution-oracle store drv
272 #:key (mode (build-mode normal)))
273 "Return a one-argument procedure that, when passed a store file name,
274 returns a 'substitutable?' if it's substitutable and #f otherwise.
275 The returned procedure
276 knows about all substitutes for all the derivations listed in DRV, *except*
277 those that are already valid (that is, it won't bother checking whether an
278 item is substitutable if it's already on disk); it also knows about their
279 prerequisites, unless they are themselves substitutable.
281 Creating a single oracle (thus making a single 'substitutable-path-info' call) and
282 reusing it is much more efficient than calling 'has-substitutes?' or similar
283 repeatedly, because it avoids the costs associated with launching the
284 substituter many times."
285 (define valid?
286 (cut valid-path? store <>))
288 (define valid-input?
289 (cut valid-derivation-input? store <>))
291 (define (dependencies drv)
292 ;; Skip prerequisite sub-trees of DRV whose root is valid. This allows us
293 ;; to ask the substituter for just as much as needed, instead of asking it
294 ;; for the whole world, which can be significantly faster when substitute
295 ;; info is not already in cache.
296 ;; Also, skip derivations marked as non-substitutable.
297 (append-map (lambda (input)
298 (let ((drv (read-derivation-from-file
299 (derivation-input-path input))))
300 (if (substitutable-derivation? drv)
301 (derivation-input-output-paths input)
302 '())))
303 (derivation-prerequisites drv valid-input?)))
305 (let* ((paths (delete-duplicates
306 (concatenate
307 (fold (lambda (drv result)
308 (let ((self (match (derivation->output-paths drv)
309 (((names . paths) ...)
310 paths))))
311 (cond ((eqv? mode (build-mode check))
312 (cons (dependencies drv) result))
313 ((not (substitutable-derivation? drv))
314 (cons (dependencies drv) result))
315 ((every valid? self)
316 result)
317 (else
318 (cons* self (dependencies drv) result)))))
319 '()
320 drv))))
321 (subst (fold (lambda (subst vhash)
322 (vhash-cons (substitutable-path subst) subst
323 vhash))
324 vlist-null
325 (substitutable-path-info store paths))))
326 (lambda (item)
327 (match (vhash-assoc item subst)
328 (#f #f)
329 ((key . value) value)))))
331 (define* (derivation-prerequisites-to-build store drv
332 #:key
333 (mode (build-mode normal))
334 (outputs
335 (derivation-output-names drv))
336 (substitutable-info
337 (substitution-oracle store
338 (list drv)
339 #:mode mode)))
340 "Return two values: the list of derivation-inputs required to build the
341 OUTPUTS of DRV and not already available in STORE, recursively, and the list
342 of required store paths that can be substituted. SUBSTITUTABLE-INFO must be a
343 one-argument procedure similar to that returned by 'substitution-oracle'."
344 (define built?
345 (cut valid-path? store <>))
347 (define input-built?
348 (compose (cut any built? <>) derivation-input-output-paths))
350 (define input-substitutable?
351 ;; Return true if and only if all of SUB-DRVS are subsitutable. If at
352 ;; least one is missing, then everything must be rebuilt.
353 (compose (cut every substitutable-info <>) derivation-input-output-paths))
355 (define (derivation-built? drv* sub-drvs)
356 ;; In 'check' mode, assume that DRV is not built.
357 (and (not (and (eqv? mode (build-mode check))
358 (eq? drv* drv)))
359 (every built? (derivation-output-paths drv* sub-drvs))))
361 (define (derivation-substitutable-info drv sub-drvs)
362 (and (substitutable-derivation? drv)
363 (let ((info (filter-map substitutable-info
364 (derivation-output-paths drv sub-drvs))))
365 (and (= (length info) (length sub-drvs))
366 info))))
368 (let loop ((drv drv)
369 (sub-drvs outputs)
370 (build '()) ;list of <derivation-input>
371 (substitute '())) ;list of <substitutable>
372 (cond ((derivation-built? drv sub-drvs)
373 (values build substitute))
374 ((derivation-substitutable-info drv sub-drvs)
375 =>
376 (lambda (substitutables)
377 (values build
378 (append substitutables substitute))))
379 (else
380 (let ((build (if (substitutable-derivation? drv)
381 build
382 (cons (make-derivation-input
383 (derivation-file-name drv) sub-drvs)
384 build)))
385 (inputs (remove (lambda (i)
386 (or (member i build) ; XXX: quadratic
387 (input-built? i)
388 (input-substitutable? i)))
389 (derivation-inputs drv))))
390 (fold2 loop
391 (append inputs build)
392 (append (append-map (lambda (input)
393 (if (and (not (input-built? input))
394 (input-substitutable? input))
395 (map substitutable-info
396 (derivation-input-output-paths
397 input))
398 '()))
399 (derivation-inputs drv))
400 substitute)
401 (map (lambda (i)
402 (read-derivation-from-file
403 (derivation-input-path i)))
404 inputs)
405 (map derivation-input-sub-derivations inputs)))))))
407 (define (read-derivation drv-port)
408 "Read the derivation from DRV-PORT and return the corresponding <derivation>
409 object. Most of the time you'll want to use 'read-derivation-from-file',
410 which caches things as appropriate and is thus more efficient."
412 (define comma (string->symbol ","))
414 (define (ununquote x)
415 (match x
416 (('unquote x) (ununquote x))
417 ((x ...) (map ununquote x))
418 (_ x)))
420 (define (outputs->alist x)
421 (fold-right (lambda (output result)
422 (match output
423 ((name path "" "")
424 (alist-cons name
425 (make-derivation-output path #f #f #f)
426 result))
427 ((name path hash-algo hash)
428 ;; fixed-output
429 (let* ((rec? (string-prefix? "r:" hash-algo))
430 (algo (string->symbol
431 (if rec?
432 (string-drop hash-algo 2)
433 hash-algo)))
434 (hash (base16-string->bytevector hash)))
435 (alist-cons name
436 (make-derivation-output path algo
437 hash rec?)
438 result)))))
439 '()
440 x))
442 (define (make-input-drvs x)
443 (fold-right (lambda (input result)
444 (match input
445 ((path (sub-drvs ...))
446 (cons (make-derivation-input path sub-drvs)
447 result))))
448 '()
449 x))
451 ;; The contents of a derivation are typically ASCII, but choosing
452 ;; UTF-8 allows us to take the fast path for Guile's `scm_getc'.
453 (set-port-encoding! drv-port "UTF-8")
455 (let loop ((exp (read drv-port))
456 (result '()))
457 (match exp
458 ((? eof-object?)
459 (let ((result (reverse result)))
460 (match result
461 (('Derive ((outputs ...) (input-drvs ...)
462 (input-srcs ...)
463 (? string? system)
464 (? string? builder)
465 ((? string? args) ...)
466 ((var value) ...)))
467 (make-derivation (outputs->alist outputs)
468 (make-input-drvs input-drvs)
469 input-srcs
470 system builder args
471 (fold-right alist-cons '() var value)
472 (port-filename drv-port)))
473 (_
474 (error "failed to parse derivation" drv-port result)))))
475 ((? (cut eq? <> comma))
476 (loop (read drv-port) result))
477 (_
478 (loop (read drv-port)
479 (cons (ununquote exp) result))))))
481 (define %derivation-cache
482 ;; Maps derivation file names to <derivation> objects.
483 ;; XXX: This is redundant with 'atts-cache' in the store.
484 (make-weak-value-hash-table 200))
486 (define (read-derivation-from-file file)
487 "Read the derivation in FILE, a '.drv' file, and return the corresponding
488 <derivation> object."
489 ;; Memoize that operation because 'read-derivation' is quite expensive,
490 ;; and because the same argument is read more than 15 times on average
491 ;; during something like (package-derivation s gdb).
492 (or (and file (hash-ref %derivation-cache file))
493 (let ((drv (call-with-input-file file read-derivation)))
494 (hash-set! %derivation-cache file drv)
495 drv)))
497 (define-inlinable (write-sequence lst write-item port)
498 ;; Write each element of LST with WRITE-ITEM to PORT, separating them with a
499 ;; comma.
500 (match lst
501 (()
502 #t)
503 ((prefix (... ...) last)
504 (for-each (lambda (item)
505 (write-item item port)
506 (display "," port))
507 prefix)
508 (write-item last port))))
510 (define-inlinable (write-list lst write-item port)
511 ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each
512 ;; element.
513 (display "[" port)
514 (write-sequence lst write-item port)
515 (display "]" port))
517 (define-inlinable (write-tuple lst write-item port)
518 ;; Same, but write LST as a tuple.
519 (display "(" port)
520 (write-sequence lst write-item port)
521 (display ")" port))
523 (define (write-derivation drv port)
524 "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of
525 Eelco Dolstra's PhD dissertation for an overview of a previous version of
526 that form."
528 ;; Make sure we're using the faster implementation.
529 (define format simple-format)
531 (define (write-string-list lst)
532 (write-list lst write port))
534 (define (write-output output port)
535 (match output
536 ((name . ($ <derivation-output> path hash-algo hash recursive?))
537 (write-tuple (list name path
538 (if hash-algo
539 (string-append (if recursive? "r:" "")
540 (symbol->string hash-algo))
541 "")
542 (or (and=> hash bytevector->base16-string)
543 ""))
544 write
545 port))))
547 (define (write-input input port)
548 (match input
549 (($ <derivation-input> path sub-drvs)
550 (display "(\"" port)
551 (display path port)
552 (display "\"," port)
553 (write-string-list sub-drvs)
554 (display ")" port))))
556 (define (write-env-var env-var port)
557 (match env-var
558 ((name . value)
559 (display "(" port)
560 (write name port)
561 (display "," port)
562 (write value port)
563 (display ")" port))))
565 ;; Assume all the lists we are writing are already sorted.
566 (match drv
567 (($ <derivation> outputs inputs sources
568 system builder args env-vars)
569 (display "Derive(" port)
570 (write-list outputs write-output port)
571 (display "," port)
572 (write-list inputs write-input port)
573 (display "," port)
574 (write-string-list sources)
575 (simple-format port ",\"~a\",\"~a\"," system builder)
576 (write-string-list args)
577 (display "," port)
578 (write-list env-vars write-env-var port)
579 (display ")" port))))
581 (define derivation->bytevector
582 (mlambda (drv)
583 "Return the external representation of DRV as a UTF-8-encoded string."
584 (with-fluids ((%default-port-encoding "UTF-8"))
585 (call-with-values open-bytevector-output-port
586 (lambda (port get-bytevector)
587 (write-derivation drv port)
588 (get-bytevector))))))
590 (define* (derivation->output-path drv #:optional (output "out"))
591 "Return the store path of its output OUTPUT. Raise a
592 '&derivation-missing-output-error' condition if OUTPUT is not an output of
593 DRV."
594 (let ((output* (assoc-ref (derivation-outputs drv) output)))
595 (if output*
596 (derivation-output-path output*)
597 (raise (condition (&derivation-missing-output-error
598 (derivation drv)
599 (output output)))))))
601 (define (derivation->output-paths drv)
602 "Return the list of name/path pairs of the outputs of DRV."
603 (map (match-lambda
604 ((name . output)
605 (cons name (derivation-output-path output))))
606 (derivation-outputs drv)))
608 (define derivation-path->output-path
609 ;; This procedure is called frequently, so memoize it.
610 (let ((memoized (mlambda (path output)
611 (derivation->output-path (read-derivation-from-file path)
612 output))))
613 (lambda* (path #:optional (output "out"))
614 "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
615 path of its output OUTPUT."
616 (memoized path output))))
618 (define (derivation-path->output-paths path)
619 "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
620 list of name/path pairs of its outputs."
621 (derivation->output-paths (read-derivation-from-file path)))
623 \f
624 ;;;
625 ;;; Derivation primitive.
626 ;;;
628 (define derivation-path->base16-hash
629 (mlambda (file)
630 "Return a string containing the base16 representation of the hash of the
631 derivation at FILE."
632 (bytevector->base16-string
633 (derivation-hash (read-derivation-from-file file)))))
635 (define derivation-hash ; `hashDerivationModulo' in derivations.cc
636 (mlambda (drv)
637 "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
638 (match drv
639 (($ <derivation> ((_ . ($ <derivation-output> path
640 (? symbol? hash-algo) (? bytevector? hash)
641 (? boolean? recursive?)))))
642 ;; A fixed-output derivation.
643 (sha256
644 (string->utf8
645 (string-append "fixed:out:"
646 (if recursive? "r:" "")
647 (symbol->string hash-algo)
648 ":" (bytevector->base16-string hash)
649 ":" path))))
650 (($ <derivation> outputs inputs sources
651 system builder args env-vars)
652 ;; A regular derivation: replace the path of each input with that
653 ;; input's hash; return the hash of serialization of the resulting
654 ;; derivation.
655 (let* ((inputs (map (match-lambda
656 (($ <derivation-input> path sub-drvs)
657 (let ((hash (derivation-path->base16-hash path)))
658 (make-derivation-input hash sub-drvs))))
659 inputs))
660 (drv (make-derivation outputs
661 (sort (coalesce-duplicate-inputs inputs)
662 derivation-input<?)
663 sources
664 system builder args env-vars
665 #f)))
667 ;; XXX: At this point this remains faster than `port-sha256', because
668 ;; the SHA256 port's `write' method gets called for every single
669 ;; character.
670 (sha256 (derivation->bytevector drv)))))))
672 (define* (derivation store name builder args
673 #:key
674 (system (%current-system)) (env-vars '())
675 (inputs '()) (outputs '("out"))
676 hash hash-algo recursive?
677 references-graphs
678 allowed-references disallowed-references
679 leaked-env-vars local-build?
680 (substitutable? #t))
681 "Build a derivation with the given arguments, and return the resulting
682 <derivation> object. When HASH and HASH-ALGO are given, a
683 fixed-output derivation is created---i.e., one whose result is known in
684 advance, such as a file download. If, in addition, RECURSIVE? is true, then
685 that fixed output may be an executable file or a directory and HASH must be
686 the hash of an archive containing this output.
688 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
689 pairs. In that case, the reference graph of each store path is exported in
690 the build environment in the corresponding file, in a simple text format.
692 When ALLOWED-REFERENCES is true, it must be a list of store items or outputs
693 that the derivation's outputs may refer to. Likewise, DISALLOWED-REFERENCES,
694 if true, must be a list of things the outputs may not refer to.
696 When LEAKED-ENV-VARS is true, it must be a list of strings denoting
697 environment variables that are allowed to \"leak\" from the daemon's
698 environment to the build environment. This is only applicable to fixed-output
699 derivations--i.e., when HASH is true. The main use is to allow variables such
700 as \"http_proxy\" to be passed to derivations that download files.
702 When LOCAL-BUILD? is true, declare that the derivation is not a good candidate
703 for offloading and should rather be built locally. This is the case for small
704 derivations where the costs of data transfers would outweigh the benefits.
706 When SUBSTITUTABLE? is false, declare that substitutes of the derivation's
707 output should not be used."
708 (define (add-output-paths drv)
709 ;; Return DRV with an actual store path for each of its output and the
710 ;; corresponding environment variable.
711 (match drv
712 (($ <derivation> outputs inputs sources
713 system builder args env-vars)
714 (let* ((drv-hash (derivation-hash drv))
715 (outputs (map (match-lambda
716 ((output-name . ($ <derivation-output>
717 _ algo hash rec?))
718 (let ((path
719 (if hash
720 (fixed-output-path name hash
721 #:hash-algo algo
722 #:output output-name
723 #:recursive? rec?)
724 (output-path output-name
725 drv-hash name))))
726 (cons output-name
727 (make-derivation-output path algo
728 hash rec?)))))
729 outputs)))
730 (make-derivation outputs inputs sources system builder args
731 (map (match-lambda
732 ((name . value)
733 (cons name
734 (or (and=> (assoc-ref outputs name)
735 derivation-output-path)
736 value))))
737 env-vars)
738 #f)))))
740 (define (user+system-env-vars)
741 ;; Some options are passed to the build daemon via the env. vars of
742 ;; derivations (urgh!). We hide that from our API, but here is the place
743 ;; where we kludgify those options.
744 (let ((env-vars `(,@(if local-build?
745 `(("preferLocalBuild" . "1"))
746 '())
747 ,@(if (not substitutable?)
748 `(("allowSubstitutes" . "0"))
749 '())
750 ,@(if allowed-references
751 `(("allowedReferences"
752 . ,(string-join allowed-references)))
753 '())
754 ,@(if disallowed-references
755 `(("disallowedReferences"
756 . ,(string-join disallowed-references)))
757 '())
758 ,@(if leaked-env-vars
759 `(("impureEnvVars"
760 . ,(string-join leaked-env-vars)))
761 '())
762 ,@env-vars)))
763 (match references-graphs
764 (((file . path) ...)
765 (let ((value (map (cut string-append <> " " <>)
766 file path)))
767 ;; XXX: This all breaks down if an element of FILE or PATH contains
768 ;; white space.
769 `(("exportReferencesGraph" . ,(string-join value " "))
770 ,@env-vars)))
771 (#f
772 env-vars))))
774 (define (env-vars-with-empty-outputs env-vars)
775 ;; Return a variant of ENV-VARS where each OUTPUTS is associated with an
776 ;; empty string, even outputs that do not appear in ENV-VARS.
777 (let ((e (map (match-lambda
778 ((name . val)
779 (if (member name outputs)
780 (cons name "")
781 (cons name val))))
782 env-vars)))
783 (fold (lambda (output-name env-vars)
784 (if (assoc output-name env-vars)
785 env-vars
786 (append env-vars `((,output-name . "")))))
787 e
788 outputs)))
790 (define input->derivation-input
791 (match-lambda
792 (((? derivation? drv))
793 (make-derivation-input (derivation-file-name drv) '("out")))
794 (((? derivation? drv) sub-drvs ...)
795 (make-derivation-input (derivation-file-name drv) sub-drvs))
796 (((? direct-store-path? input))
797 (make-derivation-input input '("out")))
798 (((? direct-store-path? input) sub-drvs ...)
799 (make-derivation-input input sub-drvs))
800 ((input . _)
801 (let ((path (add-to-store store (basename input)
802 #t "sha256" input)))
803 (make-derivation-input path '())))))
805 ;; Note: lists are sorted alphabetically, to conform with the behavior of
806 ;; C++ `std::map' in Nix itself.
808 (let* ((outputs (map (lambda (name)
809 ;; Return outputs with an empty path.
810 (cons name
811 (make-derivation-output "" hash-algo
812 hash recursive?)))
813 (sort outputs string<?)))
814 (inputs (sort (coalesce-duplicate-inputs
815 (map input->derivation-input
816 (delete-duplicates inputs)))
817 derivation-input<?))
818 (env-vars (sort (env-vars-with-empty-outputs
819 (user+system-env-vars))
820 (lambda (e1 e2)
821 (string<? (car e1) (car e2)))))
822 (drv-masked (make-derivation outputs
823 (filter (compose derivation-path?
824 derivation-input-path)
825 inputs)
826 (filter-map (lambda (i)
827 (let ((p (derivation-input-path i)))
828 (and (not (derivation-path? p))
829 p)))
830 inputs)
831 system builder args env-vars #f))
832 (drv (add-output-paths drv-masked)))
834 (let* ((file (add-data-to-store store (string-append name ".drv")
835 (derivation->bytevector drv)
836 (map derivation-input-path inputs)))
837 (drv* (set-field drv (derivation-file-name) file)))
838 (hash-set! %derivation-cache file drv*)
839 drv*)))
841 (define* (map-derivation store drv mapping
842 #:key (system (%current-system)))
843 "Given MAPPING, a list of pairs of derivations, return a derivation based on
844 DRV where all the 'car's of MAPPING have been replaced by its 'cdr's,
845 recursively."
846 (define (substitute str initial replacements)
847 (fold (lambda (path replacement result)
848 (string-replace-substring result path
849 replacement))
850 str
851 initial replacements))
853 (define (substitute-file file initial replacements)
854 (define contents
855 (with-fluids ((%default-port-encoding #f))
856 (call-with-input-file file read-string)))
858 (let ((updated (substitute contents initial replacements)))
859 (if (string=? updated contents)
860 file
861 ;; XXX: permissions aren't preserved.
862 (add-text-to-store store (store-path-package-name file)
863 updated))))
865 (define input->output-paths
866 (match-lambda
867 (((? derivation? drv))
868 (list (derivation->output-path drv)))
869 (((? derivation? drv) sub-drvs ...)
870 (map (cut derivation->output-path drv <>)
871 sub-drvs))
872 ((file)
873 (list file))))
875 (let ((mapping (fold (lambda (pair result)
876 (match pair
877 (((? derivation? orig) . replacement)
878 (vhash-cons (derivation-file-name orig)
879 replacement result))
880 ((file . replacement)
881 (vhash-cons file replacement result))))
882 vlist-null
883 mapping)))
884 (define rewritten-input
885 ;; Rewrite the given input according to MAPPING, and return an input
886 ;; in the format used in 'derivation' calls.
887 (mlambda (input loop)
888 (match input
889 (($ <derivation-input> path (sub-drvs ...))
890 (match (vhash-assoc path mapping)
891 ((_ . (? derivation? replacement))
892 (cons replacement sub-drvs))
893 ((_ . replacement)
894 (list replacement))
895 (#f
896 (let* ((drv (loop (read-derivation-from-file path))))
897 (cons drv sub-drvs))))))))
899 (let loop ((drv drv))
900 (let* ((inputs (map (cut rewritten-input <> loop)
901 (derivation-inputs drv)))
902 (initial (append-map derivation-input-output-paths
903 (derivation-inputs drv)))
904 (replacements (append-map input->output-paths inputs))
906 ;; Sources typically refer to the output directories of the
907 ;; original inputs, INITIAL. Rewrite them by substituting
908 ;; REPLACEMENTS.
909 (sources (map (lambda (source)
910 (match (vhash-assoc source mapping)
911 ((_ . replacement)
912 replacement)
913 (#f
914 (substitute-file source
915 initial replacements))))
916 (derivation-sources drv)))
918 ;; Now augment the lists of initials and replacements.
919 (initial (append (derivation-sources drv) initial))
920 (replacements (append sources replacements))
921 (name (store-path-package-name
922 (string-drop-right (derivation-file-name drv)
923 4))))
924 (derivation store name
925 (substitute (derivation-builder drv)
926 initial replacements)
927 (map (cut substitute <> initial replacements)
928 (derivation-builder-arguments drv))
929 #:system system
930 #:env-vars (map (match-lambda
931 ((var . value)
932 `(,var
933 . ,(substitute value initial
934 replacements))))
935 (derivation-builder-environment-vars drv))
936 #:inputs (append (map list sources) inputs)
937 #:outputs (derivation-output-names drv)
938 #:hash (match (derivation-outputs drv)
939 ((($ <derivation-output> _ algo hash))
940 hash)
941 (_ #f))
942 #:hash-algo (match (derivation-outputs drv)
943 ((($ <derivation-output> _ algo hash))
944 algo)
945 (_ #f)))))))
947 \f
948 ;;;
949 ;;; Store compatibility layer.
950 ;;;
952 (define* (build-derivations store derivations
953 #:optional (mode (build-mode normal)))
954 "Build DERIVATIONS, a list of <derivation> objects or .drv file names, using
955 the specified MODE."
956 (build-things store (map (match-lambda
957 ((? string? file) file)
958 ((and drv ($ <derivation>))
959 (derivation-file-name drv)))
960 derivations)
961 mode))
963 \f
964 ;;;
965 ;;; Guile-based builders.
966 ;;;
968 (define (parent-directories file-name)
969 "Return the list of parent dirs of FILE-NAME, in the order in which an
970 `mkdir -p' implementation would make them."
971 (let ((not-slash (char-set-complement (char-set #\/))))
972 (reverse
973 (fold (lambda (dir result)
974 (match result
975 (()
976 (list dir))
977 ((prev _ ...)
978 (cons (string-append prev "/" dir)
979 result))))
980 '()
981 (remove (cut string=? <> ".")
982 (string-tokenize (dirname file-name) not-slash))))))
984 (define* (imported-files store files ;deprecated
985 #:key (name "file-import")
986 (system (%current-system))
987 (guile (%guile-for-build)))
988 "Return a derivation that imports FILES into STORE. FILES must be a list
989 of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
990 system, imported, and appears under FINAL-PATH in the resulting store path."
991 (let* ((files (map (match-lambda
992 ((final-path . file-name)
993 (list final-path
994 (add-to-store store (basename final-path) #f
995 "sha256" file-name))))
996 files))
997 (builder
998 `(begin
999 (mkdir %output) (chdir %output)
1000 ,@(append-map (match-lambda
1001 ((final-path store-path)
1002 (append (match (parent-directories final-path)
1003 (() '())
1004 ((head ... tail)
1005 (append (map (lambda (d)
1006 `(false-if-exception
1007 (mkdir ,d)))
1008 head)
1009 `((or (file-exists? ,tail)
1010 (mkdir ,tail))))))
1011 `((symlink ,store-path ,final-path)))))
1012 files))))
1013 (build-expression->derivation store name builder
1014 #:system system
1015 #:inputs files
1016 #:guile-for-build guile
1017 #:local-build? #t)))
1019 ;; The "file not found" error condition.
1020 (define-condition-type &file-search-error &error
1021 file-search-error?
1022 (file file-search-error-file-name)
1023 (path file-search-error-search-path))
1025 (define search-path*
1026 ;; A memoizing version of 'search-path' so 'imported-modules' does not end
1027 ;; up looking for the same files over and over again.
1028 (mlambda (path file)
1029 "Search for FILE in PATH and memoize the result. Raise a
1030 '&file-search-error' condition if it could not be found."
1031 (or (search-path path file)
1032 (raise (condition
1033 (&file-search-error (file file)
1034 (path path)))))))
1036 (define (module->source-file-name module)
1037 "Return the file name corresponding to MODULE, a Guile module name (a list
1038 of symbols.)"
1039 (string-append (string-join (map symbol->string module) "/")
1040 ".scm"))
1042 (define* (%imported-modules store modules ;deprecated
1043 #:key (name "module-import")
1044 (system (%current-system))
1045 (guile (%guile-for-build))
1046 (module-path %load-path))
1047 "Return a derivation that contains the source files of MODULES, a list of
1048 module names such as `(ice-9 q)'. All of MODULES must be in the MODULE-PATH
1049 search path."
1050 ;; TODO: Determine the closure of MODULES, build the `.go' files,
1051 ;; canonicalize the source files through read/write, etc.
1052 (let ((files (map (lambda (m)
1053 (let ((f (module->source-file-name m)))
1054 (cons f (search-path* module-path f))))
1055 modules)))
1056 (imported-files store files #:name name #:system system
1057 #:guile guile)))
1059 (define* (%compiled-modules store modules ;deprecated
1060 #:key (name "module-import-compiled")
1061 (system (%current-system))
1062 (guile (%guile-for-build))
1063 (module-path %load-path))
1064 "Return a derivation that builds a tree containing the `.go' files
1065 corresponding to MODULES. All the MODULES are built in a context where
1066 they can refer to each other."
1067 (let* ((module-drv (%imported-modules store modules
1068 #:system system
1069 #:guile guile
1070 #:module-path module-path))
1071 (module-dir (derivation->output-path module-drv))
1072 (files (map (lambda (m)
1073 (let ((f (string-join (map symbol->string m)
1074 "/")))
1075 (cons (string-append f ".go")
1076 (string-append module-dir "/" f ".scm"))))
1077 modules)))
1078 (define builder
1079 `(begin
1080 (use-modules (system base compile))
1081 (let ((out (assoc-ref %outputs "out")))
1082 (mkdir out)
1083 (chdir out))
1085 (set! %load-path
1086 (cons ,module-dir %load-path))
1088 ,@(map (match-lambda
1089 ((output . input)
1090 (let ((make-parent-dirs (map (lambda (dir)
1091 `(unless (file-exists? ,dir)
1092 (mkdir ,dir)))
1093 (parent-directories output))))
1094 `(begin
1095 ,@make-parent-dirs
1096 (compile-file ,input
1097 #:output-file ,output
1098 #:opts %auto-compilation-options)))))
1099 files)))
1101 (build-expression->derivation store name builder
1102 #:inputs `(("modules" ,module-drv))
1103 #:system system
1104 #:guile-for-build guile
1105 #:local-build? #t)))
1107 (define* (build-expression->derivation store name exp ;deprecated
1108 #:key
1109 (system (%current-system))
1110 (inputs '())
1111 (outputs '("out"))
1112 hash hash-algo recursive?
1113 (env-vars '())
1114 (modules '())
1115 guile-for-build
1116 references-graphs
1117 allowed-references
1118 disallowed-references
1119 local-build? (substitutable? #t))
1120 "Return a derivation that executes Scheme expression EXP as a builder
1121 for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV)
1122 tuples; when SUB-DRV is omitted, \"out\" is assumed. MODULES is a list
1123 of names of Guile modules from the current search path to be copied in
1124 the store, compiled, and made available in the load path during the
1125 execution of EXP.
1127 EXP is evaluated in an environment where %OUTPUT is bound to the main
1128 output path, %OUTPUTS is bound to a list of output/path pairs, and where
1129 %BUILD-INPUTS is bound to an alist of string/output-path pairs made from
1130 INPUTS. Optionally, ENV-VARS is a list of string pairs specifying the
1131 name and value of environment variables visible to the builder. The
1132 builder terminates by passing the result of EXP to `exit'; thus, when
1133 EXP returns #f, the build is considered to have failed.
1135 EXP is built using GUILE-FOR-BUILD (a derivation). When GUILE-FOR-BUILD is
1136 omitted or is #f, the value of the `%guile-for-build' fluid is used instead.
1138 See the `derivation' procedure for the meaning of REFERENCES-GRAPHS,
1139 ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?."
1140 (define guile-drv
1141 (or guile-for-build (%guile-for-build)))
1143 (define guile
1144 (string-append (derivation->output-path guile-drv)
1145 "/bin/guile"))
1147 (define module-form?
1148 (match-lambda
1149 (((or 'define-module 'use-modules) _ ...) #t)
1150 (_ #f)))
1152 (define source-path
1153 ;; When passed an input that is a source, return its path; otherwise
1154 ;; return #f.
1155 (match-lambda
1156 ((_ (? derivation?) _ ...)
1157 #f)
1158 ((_ path _ ...)
1159 (and (not (derivation-path? path))
1160 path))))
1162 (let* ((prologue `(begin
1163 ,@(match exp
1164 ((_ ...)
1165 ;; Module forms must appear at the top-level so
1166 ;; that any macros they export can be expanded.
1167 (filter module-form? exp))
1168 (_ `(,exp)))
1170 (define %output (getenv "out"))
1171 (define %outputs
1172 (map (lambda (o)
1173 (cons o (getenv o)))
1174 ',outputs))
1175 (define %build-inputs
1176 ',(map (match-lambda
1177 ((name drv . rest)
1178 (let ((sub (match rest
1179 (() "out")
1180 ((x) x))))
1181 (cons name
1182 (cond
1183 ((derivation? drv)
1184 (derivation->output-path drv sub))
1185 ((derivation-path? drv)
1186 (derivation-path->output-path drv
1187 sub))
1188 (else drv))))))
1189 inputs))
1191 ,@(if (null? modules)
1192 '()
1193 ;; Remove our own settings.
1194 '((unsetenv "GUILE_LOAD_COMPILED_PATH")))
1196 ;; Guile sets it, but remove it to avoid conflicts when
1197 ;; building Guile-using packages.
1198 (unsetenv "LD_LIBRARY_PATH")))
1199 (builder (add-text-to-store store
1200 (string-append name "-guile-builder")
1202 ;; Explicitly use UTF-8 for determinism,
1203 ;; and also because UTF-8 output is faster.
1204 (with-fluids ((%default-port-encoding
1205 "UTF-8"))
1206 (call-with-output-string
1207 (lambda (port)
1208 (write prologue port)
1209 (write
1210 `(exit
1211 ,(match exp
1212 ((_ ...)
1213 (remove module-form? exp))
1214 (_ `(,exp))))
1215 port))))
1217 ;; The references don't really matter
1218 ;; since the builder is always used in
1219 ;; conjunction with the drv that needs
1220 ;; it. For clarity, we add references
1221 ;; to the subset of INPUTS that are
1222 ;; sources, avoiding references to other
1223 ;; .drv; otherwise, BUILDER's hash would
1224 ;; depend on those, even if they are
1225 ;; fixed-output.
1226 (filter-map source-path inputs)))
1228 (mod-drv (and (pair? modules)
1229 (%imported-modules store modules
1230 #:guile guile-drv
1231 #:system system)))
1232 (mod-dir (and mod-drv
1233 (derivation->output-path mod-drv)))
1234 (go-drv (and (pair? modules)
1235 (%compiled-modules store modules
1236 #:guile guile-drv
1237 #:system system)))
1238 (go-dir (and go-drv
1239 (derivation->output-path go-drv))))
1240 (derivation store name guile
1241 `("--no-auto-compile"
1242 ,@(if mod-dir `("-L" ,mod-dir) '())
1243 ,builder)
1245 #:system system
1247 #:inputs `((,(or guile-for-build (%guile-for-build)))
1248 (,builder)
1249 ,@(map cdr inputs)
1250 ,@(if mod-drv `((,mod-drv) (,go-drv)) '()))
1252 ;; When MODULES is non-empty, shamelessly clobber
1253 ;; $GUILE_LOAD_COMPILED_PATH.
1254 #:env-vars (if go-dir
1255 `(("GUILE_LOAD_COMPILED_PATH" . ,go-dir)
1256 ,@(alist-delete "GUILE_LOAD_COMPILED_PATH"
1257 env-vars))
1258 env-vars)
1260 #:hash hash #:hash-algo hash-algo
1261 #:recursive? recursive?
1262 #:outputs outputs
1263 #:references-graphs references-graphs
1264 #:allowed-references allowed-references
1265 #:disallowed-references disallowed-references
1266 #:local-build? local-build?
1267 #:substitutable? substitutable?)))
1269 \f
1270 ;;;
1271 ;;; Monadic interface.
1272 ;;;
1274 (define built-derivations
1275 (store-lift build-derivations))
1277 (define raw-derivation
1278 (store-lift derivation))