summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorCaleb Ristvedt <caleb.ristvedt@cune.org>2020-04-13 13:01:25 -0500
committerCaleb Ristvedt <caleb.ristvedt@cune.org>2020-04-13 13:14:31 -0500
commitbdc366cbdce59ddc22dfa1bc70d5c49a0b6dcf92 (patch)
treeb58a2665f102e3621a7deff4aa56016ea93dbe69
parent2fa04968afe204c61cd37d6c7b77d52818663062 (diff)
guix: split (guix store) and (guix derivations).
* guix/store.scm (&store-error, store-error?, %store-prefix, store-path, output-path, fixed-output-path, store-path?, direct-store-path?, derivation-path?, store-path-base, store-path-package-name, store-path-hash-part, direct-store-path, derivation-log-file): Moved to (guix store files) and re-exported from here. ((guix store files)): use it. * guix/store/files.scm: new module. above named variables: added. * guix/derivations.scm (&derivation-error, derivation-error?, derivation-error-derivation, &derivation-missing-output-error, derivation-missing-output-error?, derivation-missing-output, <derivation>, make-derivation, derivation?, derivation-outputs, derivation-inputs, derivation-sources, derivation-system, derivation-builder, derivation-builder-arguments, derivation-builder-environment-vars, derivation-file-name, <derivation-output>, derivation-output?, derivation-output-path, derivation-output-hash-algo, derivation-output-hash, derivation-output-recursive?, derivation-output-names, <derivation-input>, derivation-input?, derivation-input-derivation, derivation-input-sub-derivations, derivation-input-path, derivation-input, derivation-input-key, coalesce-duplicate-inputs, derivation-name, derivation-base16-hash, derivation-output-names, derivation-hash, derivation-properties, fixed-output-derivation?, offloadable-derivation?, substitutable-derivation?, derivation-input-fold, derivation-input<?, derivation-input-output-path, derivation-input-output-paths, derivation-output-paths, derivation->output-path, derivation->output-paths, derivation-path->output-path, derivation-path->output-paths, derivation-prerequisites, derivation/masked-inputs, read-derivation, read-derivation-from-file, derivation->bytevector, %derivation-cache, write-derivation, invalidate-derivation-caches!): Moved to (guix store derivations) and re-exported from here. ((guix store derivations)): use it. * guix/store/derivations.scm: new module. above named variables: added.
Diffstat
-rw-r--r--guix/derivations.scm621
-rw-r--r--guix/store.scm158
-rw-r--r--guix/store/derivations.scm612
-rw-r--r--guix/store/files.scm176
4 files changed, 868 insertions, 699 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm
index f6d6f7db25b..657c6da2e31 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -43,64 +43,15 @@
43 #:use-module (guix base32) 43 #:use-module (guix base32)
44 #:use-module (guix records) 44 #:use-module (guix records)
45 #:use-module (guix sets) 45 #:use-module (guix sets)
46 #:export (<derivation> 46 #:use-module (guix store derivations)
47 derivation? 47 #:export (derivation-build-plan
48 derivation-outputs 48 derivation-prerequisites-to-build ;deprecated
49 derivation-inputs
50 derivation-sources
51 derivation-system
52 derivation-builder
53 derivation-builder-arguments
54 derivation-builder-environment-vars
55 derivation-file-name
56 derivation-prerequisites
57 derivation-build-plan
58 derivation-prerequisites-to-build ;deprecated
59
60 <derivation-output>
61 derivation-output?
62 derivation-output-path
63 derivation-output-hash-algo
64 derivation-output-hash
65 derivation-output-recursive?
66
67 <derivation-input>
68 derivation-input?
69 derivation-input
70 derivation-input-path
71 derivation-input-derivation
72 derivation-input-sub-derivations
73 derivation-input-output-paths
74 derivation-input-output-path
75 valid-derivation-input? 49 valid-derivation-input?
76 50
77 &derivation-error
78 derivation-error?
79 derivation-error-derivation
80 &derivation-missing-output-error
81 derivation-missing-output-error?
82 derivation-missing-output
83
84 derivation-name
85 derivation-output-names
86 fixed-output-derivation?
87 offloadable-derivation?
88 substitutable-derivation?
89 derivation-input-fold
90 substitution-oracle 51 substitution-oracle
91 derivation-hash 52
92 derivation-properties
93
94 read-derivation
95 read-derivation-from-file
96 write-derivation
97 derivation->output-path
98 derivation->output-paths
99 derivation-path->output-path
100 derivation-path->output-paths
101 derivation 53 derivation
102 raw-derivation 54 raw-derivation
103 invalidate-derivation-caches!
104 55
105 map-derivation 56 map-derivation
106 57
@@ -116,119 +67,66 @@
116 build-expression->derivation) 67 build-expression->derivation)
117 68
118 ;; Re-export it from here for backward compatibility. 69 ;; Re-export it from here for backward compatibility.
119 #:re-export (%guile-for-build)) 70 #:re-export (%guile-for-build
120 71
121;;; 72 &derivation-error
122;;; Error conditions. 73 derivation-error?
123;;; 74 derivation-error-derivation
124 75
125(define-condition-type &derivation-error &store-error 76 &derivation-missing-output-error
126 derivation-error? 77 derivation-missing-output-error?
127 (derivation derivation-error-derivation)) 78 derivation-missing-output
128 79
129(define-condition-type &derivation-missing-output-error &derivation-error 80 <derivation>
130 derivation-missing-output-error? 81 derivation?
131 (output derivation-missing-output)) 82 derivation-outputs
83 derivation-inputs
84 derivation-sources
85 derivation-system
86 derivation-builder
87 derivation-builder-arguments
88 derivation-builder-environment-vars
89 derivation-file-name
90
91 <derivation-output>
92 derivation-output?
93 derivation-output-path
94 derivation-output-hash-algo
95 derivation-output-hash
96 derivation-output-recursive?
97 derivation-output-names
98
99 <derivation-input>
100 derivation-input?
101 derivation-input-derivation
102 derivation-input-sub-derivations
103 derivation-input-path
104 derivation-input
105
106 derivation-name
107 derivation-output-names
108 derivation-hash
109 derivation-properties
110 fixed-output-derivation?
111 offloadable-derivation?
112 substitutable-derivation?
113
114 derivation-input<?
115 derivation-input-output-path
116 derivation-input-output-paths
117 derivation-input-fold
118 derivation->output-path
119 derivation->output-paths
120 derivation-path->output-path
121 derivation-path->output-paths
122
123 derivation-prerequisites
124
125 read-derivation
126 read-derivation-from-file
127 write-derivation
128 invalidate-derivation-caches!))
132 129
133;;;
134;;; Nix derivations, as implemented in Nix's `derivations.cc'.
135;;;
136
137(define-immutable-record-type <derivation>
138 (make-derivation outputs inputs sources system builder args env-vars
139 file-name)
140 derivation?
141 (outputs derivation-outputs) ; list of name/<derivation-output> pairs
142 (inputs derivation-inputs) ; list of <derivation-input>
143 (sources derivation-sources) ; list of store paths
144 (system derivation-system) ; string
145 (builder derivation-builder) ; store path
146 (args derivation-builder-arguments) ; list of strings
147 (env-vars derivation-builder-environment-vars) ; list of name/value pairs
148 (file-name derivation-file-name)) ; the .drv file name
149
150(define-immutable-record-type <derivation-output>
151 (make-derivation-output path hash-algo hash recursive?)
152 derivation-output?
153 (path derivation-output-path) ; store path
154 (hash-algo derivation-output-hash-algo) ; symbol | #f
155 (hash derivation-output-hash) ; bytevector | #f
156 (recursive? derivation-output-recursive?)) ; Boolean
157
158(define-immutable-record-type <derivation-input>
159 (make-derivation-input drv sub-derivations)
160 derivation-input?
161 (drv derivation-input-derivation) ; <derivation>
162 (sub-derivations derivation-input-sub-derivations)) ; list of strings
163
164
165(define (derivation-input-path input)
166 "Return the file name of the derivation INPUT refers to."
167 (derivation-file-name (derivation-input-derivation input)))
168
169(define* (derivation-input drv #:optional
170 (outputs (derivation-output-names drv)))
171 "Return a <derivation-input> for the OUTPUTS of DRV."
172 ;; This is a public interface meant to be more convenient than
173 ;; 'make-derivation-input' and giving us more control.
174 (make-derivation-input drv outputs))
175
176(define (derivation-input-key input)
177 "Return an object for which 'equal?' and 'hash' are constant-time, and which
178can thus be used as a key for INPUT in lookup tables."
179 (cons (derivation-input-path input)
180 (derivation-input-sub-derivations input)))
181
182(set-record-type-printer! <derivation>
183 (lambda (drv port)
184 (format port "#<derivation ~a => ~a ~a>"
185 (derivation-file-name drv)
186 (string-join
187 (map (match-lambda
188 ((_ . output)
189 (derivation-output-path output)))
190 (derivation-outputs drv)))
191 (number->string (object-address drv) 16))))
192
193(define (derivation-name drv)
194 "Return the base name of DRV."
195 (let ((base (store-path-package-name (derivation-file-name drv))))
196 (string-drop-right base 4)))
197
198(define (derivation-output-names drv)
199 "Return the names of the outputs of DRV."
200 (match (derivation-outputs drv)
201 (((names . _) ...)
202 names)))
203
204(define (fixed-output-derivation? drv)
205 "Return #t if DRV is a fixed-output derivation, such as the result of a
206download with a fixed hash (aka. `fetchurl')."
207 (match drv
208 (($ <derivation>
209 (("out" . ($ <derivation-output> _ (? symbol?) (? bytevector?)))))
210 #t)
211 (_ #f)))
212
213(define (derivation-input<? input1 input2)
214 "Compare INPUT1 and INPUT2, two <derivation-input>."
215 (string<? (derivation-input-path input1)
216 (derivation-input-path input2)))
217
218(define (derivation-input-output-paths input)
219 "Return the list of output paths corresponding to INPUT, a
220<derivation-input>."
221 (match input
222 (($ <derivation-input> drv sub-drvs)
223 (map (cut derivation->output-path drv <>)
224 sub-drvs))))
225
226(define (derivation-input-output-path input)
227 "Return the output file name of INPUT. If INPUT has more than one outputs,
228an error is raised."
229 (match input
230 (($ <derivation-input> drv (output))
231 (derivation->output-path drv output))))
232 130
233(define (valid-derivation-input? store input) 131(define (valid-derivation-input? store input)
234 "Return true if INPUT is valid--i.e., if all the outputs it requests are in 132 "Return true if INPUT is valid--i.e., if all the outputs it requests are in
@@ -236,104 +134,6 @@ the store."
236 (every (cut valid-path? store <>) 134 (every (cut valid-path? store <>)
237 (derivation-input-output-paths input))) 135 (derivation-input-output-paths input)))
238 136
239(define (coalesce-duplicate-inputs inputs)
240 "Return a list of inputs, such that when INPUTS contains the same DRV twice,
241they are coalesced, with their sub-derivations merged. This is needed because
242Nix itself keeps only one of them."
243 (define (find pred lst) ;inlinable copy of 'find'
244 (let loop ((lst lst))
245 (match lst
246 (() #f)
247 ((head . tail)
248 (if (pred head) head (loop tail))))))
249
250 (fold (lambda (input result)
251 (match input
252 (($ <derivation-input> (= derivation-file-name path) sub-drvs)
253 ;; XXX: quadratic
254 (match (find (match-lambda
255 (($ <derivation-input> (= derivation-file-name p)
256 s)
257 (string=? p path)))
258 result)
259 (#f
260 (cons input result))
261 ((and dup ($ <derivation-input> drv sub-drvs2))
262 ;; Merge DUP with INPUT.
263 (let ((sub-drvs (delete-duplicates
264 (append sub-drvs sub-drvs2))))
265 (cons (make-derivation-input drv (sort sub-drvs string<?))
266 (delq dup result))))))))
267 '()
268 inputs))
269
270(define* (derivation-prerequisites drv #:optional (cut? (const #f)))
271 "Return the list of derivation-inputs required to build DRV, recursively.
272
273CUT? is a predicate that is passed a derivation-input and returns true to
274eliminate the given input and its dependencies from the search. An example of
275such a predicate is 'valid-derivation-input?'; when it is used as CUT?, the
276result is the set of prerequisites of DRV not already in valid."
277 (let loop ((drv drv)
278 (result '())
279 (input-set (set)))
280 (let ((inputs (remove (lambda (input)
281 (or (set-contains? input-set
282 (derivation-input-key input))
283 (cut? input)))
284 (derivation-inputs drv))))
285 (fold2 loop
286 (append inputs result)
287 (fold set-insert input-set
288 (map derivation-input-key inputs))
289 (map derivation-input-derivation inputs)))))
290
291(define (offloadable-derivation? drv)
292 "Return true if DRV can be offloaded, false otherwise."
293 (match (assoc "preferLocalBuild"
294 (derivation-builder-environment-vars drv))
295 (("preferLocalBuild" . "1") #f)
296 (_ #t)))
297
298(define (substitutable-derivation? drv)
299 "Return #t if DRV can be substituted."
300 (match (assoc "allowSubstitutes"
301 (derivation-builder-environment-vars drv))
302 (("allowSubstitutes" . value)
303 (string=? value "1"))
304 (_ #t)))
305
306(define (derivation-output-paths drv sub-drvs)
307 "Return the output paths of outputs SUB-DRVS of DRV."
308 (match drv
309 (($ <derivation> outputs)
310 (map (lambda (sub-drv)
311 (derivation-output-path (assoc-ref outputs sub-drv)))
312 sub-drvs))))
313
314(define* (derivation-input-fold proc seed inputs
315 #:key (cut? (const #f)))
316 "Perform a breadth-first traversal of INPUTS, calling PROC on each input
317with the current result, starting from SEED. Skip recursion on inputs that
318match CUT?."
319 (let loop ((inputs inputs)
320 (result seed)
321 (visited (set)))
322 (match inputs
323 (()
324 result)
325 ((input rest ...)
326 (let ((key (derivation-input-key input)))
327 (cond ((set-contains? visited key)
328 (loop rest result visited))
329 ((cut? input)
330 (loop rest result (set-insert key visited)))
331 (else
332 (let ((drv (derivation-input-derivation input)))
333 (loop (append (derivation-inputs drv) rest)
334 (proc input result)
335 (set-insert key visited))))))))))
336
337(define* (substitution-oracle store inputs-or-drv 137(define* (substitution-oracle store inputs-or-drv
338 #:key (mode (build-mode normal))) 138 #:key (mode (build-mode normal)))
339 "Return a one-argument procedure that, when passed a store file name, 139 "Return a one-argument procedure that, when passed a store file name,
@@ -456,287 +256,13 @@ by 'substitution-oracle'."
456 (list (derivation-input drv)) rest))) 256 (list (derivation-input drv)) rest)))
457 (values (map derivation-input build) download))) 257 (values (map derivation-input build) download)))
458 258
459(define* (read-derivation drv-port 259
460 #:optional (read-derivation-from-file
461 read-derivation-from-file))
462 "Read the derivation from DRV-PORT and return the corresponding <derivation>
463object. Call READ-DERIVATION-FROM-FILE to read derivations declared as inputs
464of the derivation being parsed.
465
466Most of the time you'll want to use 'read-derivation-from-file', which caches
467things as appropriate and is thus more efficient."
468
469 (define comma (string->symbol ","))
470
471 (define (ununquote x)
472 (match x
473 (('unquote x) (ununquote x))
474 ((x ...) (map ununquote x))
475 (_ x)))
476
477 (define (outputs->alist x)
478 (fold-right (lambda (output result)
479 (match output
480 ((name path "" "")
481 (alist-cons name
482 (make-derivation-output path #f #f #f)
483 result))
484 ((name path hash-algo hash)
485 ;; fixed-output
486 (let* ((rec? (string-prefix? "r:" hash-algo))
487 (algo (string->symbol
488 (if rec?
489 (string-drop hash-algo 2)
490 hash-algo)))
491 (hash (base16-string->bytevector hash)))
492 (alist-cons name
493 (make-derivation-output path algo
494 hash rec?)
495 result)))))
496 '()
497 x))
498
499 (define (make-input-drvs x)
500 (fold-right (lambda (input result)
501 (match input
502 ((path (sub-drvs ...))
503 (let ((drv (read-derivation-from-file path)))
504 (cons (make-derivation-input drv sub-drvs)
505 result)))))
506 '()
507 x))
508
509 ;; The contents of a derivation are typically ASCII, but choosing
510 ;; UTF-8 allows us to take the fast path for Guile's `scm_getc'.
511 (set-port-encoding! drv-port "UTF-8")
512
513 (let loop ((exp (read drv-port))
514 (result '()))
515 (match exp
516 ((? eof-object?)
517 (let ((result (reverse result)))
518 (match result
519 (('Derive ((outputs ...) (input-drvs ...)
520 (input-srcs ...)
521 (? string? system)
522 (? string? builder)
523 ((? string? args) ...)
524 ((var value) ...)))
525 (make-derivation (outputs->alist outputs)
526 (make-input-drvs input-drvs)
527 input-srcs
528 system builder args
529 (fold-right alist-cons '() var value)
530 (port-filename drv-port)))
531 (_
532 (error "failed to parse derivation" drv-port result)))))
533 ((? (cut eq? <> comma))
534 (loop (read drv-port) result))
535 (_
536 (loop (read drv-port)
537 (cons (ununquote exp) result))))))
538
539(define %derivation-cache
540 ;; Maps derivation file names to <derivation> objects.
541 ;; XXX: This is redundant with 'atts-cache' in the store.
542 (make-weak-value-hash-table 200))
543
544(define (read-derivation-from-file file)
545 "Read the derivation in FILE, a '.drv' file, and return the corresponding
546<derivation> object."
547 ;; Memoize that operation because 'read-derivation' is quite expensive,
548 ;; and because the same argument is read more than 15 times on average
549 ;; during something like (package-derivation s gdb).
550 (or (and file (hash-ref %derivation-cache file))
551 (let ((drv (call-with-input-file file read-derivation)))
552 (hash-set! %derivation-cache file drv)
553 drv)))
554
555(define-inlinable (write-sequence lst write-item port)
556 ;; Write each element of LST with WRITE-ITEM to PORT, separating them with a
557 ;; comma.
558 (match lst
559 (()
560 #t)
561 ((prefix (... ...) last)
562 (for-each (lambda (item)
563 (write-item item port)
564 (display "," port))
565 prefix)
566 (write-item last port))))
567
568(define-inlinable (write-list lst write-item port)
569 ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each
570 ;; element.
571 (display "[" port)
572 (write-sequence lst write-item port)
573 (display "]" port))
574
575(define-inlinable (write-tuple lst write-item port)
576 ;; Same, but write LST as a tuple.
577 (display "(" port)
578 (write-sequence lst write-item port)
579 (display ")" port))
580
581(define (write-derivation drv port)
582 "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of
583Eelco Dolstra's PhD dissertation for an overview of a previous version of
584that form."
585
586 ;; Make sure we're using the faster implementation.
587 (define format simple-format)
588
589 (define (write-string-list lst)
590 (write-list lst write port))
591
592 (define (write-output output port)
593 (match output
594 ((name . ($ <derivation-output> path hash-algo hash recursive?))
595 (write-tuple (list name path
596 (if hash-algo
597 (string-append (if recursive? "r:" "")
598 (symbol->string hash-algo))
599 "")
600 (or (and=> hash bytevector->base16-string)
601 ""))
602 write
603 port))))
604
605 (define (write-input input port)
606 (match input
607 (($ <derivation-input> obj sub-drvs)
608 (display "(\"" port)
609
610 ;; 'derivation/masked-inputs' produces objects that contain a string
611 ;; instead of a <derivation>, so we need to account for that.
612 (display (if (derivation? obj)
613 (derivation-file-name obj)
614 obj)
615 port)
616 (display "\"," port)
617 (write-string-list sub-drvs)
618 (display ")" port))))
619
620 (define (write-env-var env-var port)
621 (match env-var
622 ((name . value)
623 (display "(" port)
624 (write name port)
625 (display "," port)
626 (write value port)
627 (display ")" port))))
628
629 ;; Assume all the lists we are writing are already sorted.
630 (match drv
631 (($ <derivation> outputs inputs sources
632 system builder args env-vars)
633 (display "Derive(" port)
634 (write-list outputs write-output port)
635 (display "," port)
636 (write-list inputs write-input port)
637 (display "," port)
638 (write-string-list sources)
639 (simple-format port ",\"~a\",\"~a\"," system builder)
640 (write-string-list args)
641 (display "," port)
642 (write-list env-vars write-env-var port)
643 (display ")" port))))
644
645(define derivation->bytevector
646 (lambda (drv)
647 "Return the external representation of DRV as a UTF-8-encoded string."
648 (with-fluids ((%default-port-encoding "UTF-8"))
649 (call-with-values open-bytevector-output-port
650 (lambda (port get-bytevector)
651 (write-derivation drv port)
652 (get-bytevector))))))
653
654(define* (derivation->output-path drv #:optional (output "out"))
655 "Return the store path of its output OUTPUT. Raise a
656'&derivation-missing-output-error' condition if OUTPUT is not an output of
657DRV."
658 (let ((output* (assoc-ref (derivation-outputs drv) output)))
659 (if output*
660 (derivation-output-path output*)
661 (raise (condition (&derivation-missing-output-error
662 (derivation drv)
663 (output output)))))))
664
665(define (derivation->output-paths drv)
666 "Return the list of name/path pairs of the outputs of DRV."
667 (map (match-lambda
668 ((name . output)
669 (cons name (derivation-output-path output))))
670 (derivation-outputs drv)))
671
672(define derivation-path->output-path
673 ;; This procedure is called frequently, so memoize it.
674 (let ((memoized (mlambda (path output)
675 (derivation->output-path (read-derivation-from-file path)
676 output))))
677 (lambda* (path #:optional (output "out"))
678 "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
679path of its output OUTPUT."
680 (memoized path output))))
681
682(define (derivation-path->output-paths path)
683 "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
684list of name/path pairs of its outputs."
685 (derivation->output-paths (read-derivation-from-file path)))
686 260
687 261
688;;; 262;;;
689;;; Derivation primitive. 263;;; Derivation primitive.
690;;; 264;;;
691 265
692(define derivation-base16-hash
693 (mlambdaq (drv)
694 "Return a string containing the base16 representation of the hash of DRV."
695 (bytevector->base16-string (derivation-hash drv))))
696
697(define (derivation/masked-inputs drv)
698 "Assuming DRV is a regular derivation (not fixed-output), replace the file
699name of each input with that input's hash."
700 (match drv
701 (($ <derivation> outputs inputs sources
702 system builder args env-vars)
703 (let ((inputs (map (match-lambda
704 (($ <derivation-input> drv sub-drvs)
705 (let ((hash (derivation-base16-hash drv)))
706 (make-derivation-input hash sub-drvs))))
707 inputs)))
708 (make-derivation outputs
709 (sort (delete-duplicates inputs)
710 (lambda (drv1 drv2)
711 (string<? (derivation-input-derivation drv1)
712 (derivation-input-derivation drv2))))
713 sources
714 system builder args env-vars
715 #f)))))
716
717(define derivation-hash ; `hashDerivationModulo' in derivations.cc
718 (lambda (drv)
719 "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
720 (match drv
721 (($ <derivation> ((_ . ($ <derivation-output> path
722 (? symbol? hash-algo) (? bytevector? hash)
723 (? boolean? recursive?)))))
724 ;; A fixed-output derivation.
725 (sha256
726 (string->utf8
727 (string-append "fixed:out:"
728 (if recursive? "r:" "")
729 (symbol->string hash-algo)
730 ":" (bytevector->base16-string hash)
731 ":" path))))
732 (_
733
734 ;; XXX: At this point this remains faster than `port-sha256', because
735 ;; the SHA256 port's `write' method gets called for every single
736 ;; character.
737 (sha256 (derivation->bytevector (derivation/masked-inputs drv)))))))
738
739
740(define (warn-about-derivation-deprecation name) 266(define (warn-about-derivation-deprecation name)
741 ;; TRANSLATORS: 'derivation' must not be translated; it refers to the 267 ;; TRANSLATORS: 'derivation' must not be translated; it refers to the
742 ;; 'derivation' procedure. 268 ;; 'derivation' procedure.
@@ -935,25 +461,6 @@ derivation. It is kept as-is, uninterpreted, in the derivation."
935 (hash-set! %derivation-cache file drv*) 461 (hash-set! %derivation-cache file drv*)
936 drv*))))) 462 drv*)))))
937 463
938(define (invalidate-derivation-caches!)
939 "Invalidate internal derivation caches. This is mostly useful for
940long-running processes that know what they're doing. Use with care!"
941 ;; Typically this is meant to be used by Cuirass and Hydra, which can clear
942 ;; caches when they start evaluating packages for another architecture.
943 (invalidate-memoization! derivation-base16-hash)
944
945 ;; FIXME: Comment out to work around <https://bugs.gnu.org/36487>.
946 ;; (hash-clear! %derivation-cache)
947 )
948
949(define derivation-properties
950 (mlambdaq (drv)
951 "Return the property alist associated with DRV."
952 (match (assoc "guix properties"
953 (derivation-builder-environment-vars drv))
954 ((_ . str) (call-with-input-string str read))
955 (#f '()))))
956
957(define* (map-derivation store drv mapping 464(define* (map-derivation store drv mapping
958 #:key (system (%current-system))) 465 #:key (system (%current-system)))
959 "Given MAPPING, a list of pairs of derivations, return a derivation based on 466 "Given MAPPING, a list of pairs of derivations, return a derivation based on
diff --git a/guix/store.scm b/guix/store.scm
index fb4b92e0c49..261b700bfea 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -20,6 +20,7 @@
20;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. 20;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
21 21
22(define-module (guix store) 22(define-module (guix store)
23 #:use-module (guix store files)
23 #:use-module (guix utils) 24 #:use-module (guix utils)
24 #:use-module (guix config) 25 #:use-module (guix config)
25 #:use-module (guix deprecation) 26 #:use-module (guix deprecation)
@@ -69,7 +70,6 @@
69 current-store-protocol-version ;for internal use 70 current-store-protocol-version ;for internal use
70 mcached 71 mcached
71 72
72 &store-error store-error?
73 &store-connection-error store-connection-error? 73 &store-connection-error store-connection-error?
74 store-connection-error-file 74 store-connection-error-file
75 store-connection-error-code 75 store-connection-error-code
@@ -170,19 +170,20 @@
170 interned-file 170 interned-file
171 interned-file-tree 171 interned-file-tree
172 172
173 %store-prefix 173 log-file)
174 store-path 174 #:re-export (&store-error store-error?
175 output-path 175 %store-prefix
176 fixed-output-path 176 store-path
177 store-path? 177 output-path
178 direct-store-path? 178 fixed-output-path
179 derivation-path? 179 store-path?
180 store-path-base 180 direct-store-path?
181 store-path-package-name 181 derivation-path?
182 store-path-hash-part 182 store-path-base
183 direct-store-path 183 store-path-package-name
184 derivation-log-file 184 store-path-hash-part
185 log-file)) 185 direct-store-path
186 derivation-log-file))
186 187
187(define %protocol-version #x163) 188(define %protocol-version #x163)
188 189
@@ -396,9 +397,6 @@
396(define-deprecated/alias nix-server-socket store-connection-socket) 397(define-deprecated/alias nix-server-socket store-connection-socket)
397 398
398 399
399(define-condition-type &store-error &error
400 store-error?)
401
402(define-condition-type &store-connection-error &store-error 400(define-condition-type &store-connection-error &store-error
403 store-connection-error? 401 store-connection-error?
404 (file store-connection-error-file) 402 (file store-connection-error-file)
@@ -1982,131 +1980,7 @@ connection, and return the result."
1982 result)))) 1980 result))))
1983 1981
1984 1982
1985;;; 1983;; Uses VALID-DERIVERS, so can't go in (guix store files)
1986;;; Store paths.
1987;;;
1988
1989(define %store-prefix
1990 ;; Absolute path to the Nix store.
1991 (make-parameter %store-directory))
1992
1993(define (compressed-hash bv size) ; `compressHash'
1994 "Given the hash stored in BV, return a compressed version thereof that fits
1995in SIZE bytes."
1996 (define new (make-bytevector size 0))
1997 (define old-size (bytevector-length bv))
1998 (let loop ((i 0))
1999 (if (= i old-size)
2000 new
2001 (let* ((j (modulo i size))
2002 (o (bytevector-u8-ref new j)))
2003 (bytevector-u8-set! new j
2004 (logxor o (bytevector-u8-ref bv i)))
2005 (loop (+ 1 i))))))
2006
2007(define (store-path type hash name) ; makeStorePath
2008 "Return the store path for NAME/HASH/TYPE."
2009 (let* ((s (string-append type ":sha256:"
2010 (bytevector->base16-string hash) ":"
2011 (%store-prefix) ":" name))
2012 (h (sha256 (string->utf8 s)))
2013 (c (compressed-hash h 20)))
2014 (string-append (%store-prefix) "/"
2015 (bytevector->nix-base32-string c) "-"
2016 name)))
2017
2018(define (output-path output hash name) ; makeOutputPath
2019 "Return an output path for OUTPUT (the name of the output as a string) of
2020the derivation called NAME with hash HASH."
2021 (store-path (string-append "output:" output) hash
2022 (if (string=? output "out")
2023 name
2024 (string-append name "-" output))))
2025
2026(define* (fixed-output-path name hash
2027 #:key
2028 (output "out")
2029 (hash-algo 'sha256)
2030 (recursive? #t))
2031 "Return an output path for the fixed output OUTPUT defined by HASH of type
2032HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for
2033'add-to-store'."
2034 (if (and recursive? (eq? hash-algo 'sha256))
2035 (store-path "source" hash name)
2036 (let ((tag (string-append "fixed:" output ":"
2037 (if recursive? "r:" "")
2038 (symbol->string hash-algo) ":"
2039 (bytevector->base16-string hash) ":")))
2040 (store-path (string-append "output:" output)
2041 (sha256 (string->utf8 tag))
2042 name))))
2043
2044(define (store-path? path)
2045 "Return #t if PATH is a store path."
2046 ;; This is a lightweight check, compared to using a regexp, but this has to
2047 ;; be fast as it's called often in `derivation', for instance.
2048 ;; `isStorePath' in Nix does something similar.
2049 (string-prefix? (%store-prefix) path))
2050
2051(define (direct-store-path? path)
2052 "Return #t if PATH is a store path, and not a sub-directory of a store path.
2053This predicate is sometimes needed because files *under* a store path are not
2054valid inputs."
2055 (and (store-path? path)
2056 (not (string=? path (%store-prefix)))
2057 (let ((len (+ 1 (string-length (%store-prefix)))))
2058 (not (string-index (substring path len) #\/)))))
2059
2060(define (direct-store-path path)
2061 "Return the direct store path part of PATH, stripping components after
2062'/gnu/store/xxxx-foo'."
2063 (let ((prefix-length (+ (string-length (%store-prefix)) 35)))
2064 (if (> (string-length path) prefix-length)
2065 (let ((slash (string-index path #\/ prefix-length)))
2066 (if slash (string-take path slash) path))
2067 path)))
2068
2069(define (derivation-path? path)
2070 "Return #t if PATH is a derivation path."
2071 (and (store-path? path) (string-suffix? ".drv" path)))
2072
2073(define (store-path-base path)
2074 "Return the base path of a path in the store."
2075 (and (string-prefix? (%store-prefix) path)
2076 (let ((base (string-drop path (+ 1 (string-length (%store-prefix))))))
2077 (and (> (string-length base) 33)
2078 (not (string-index base #\/))
2079 base))))
2080
2081(define (store-path-package-name path)
2082 "Return the package name part of PATH, a file name in the store."
2083 (let ((base (store-path-base path)))
2084 (string-drop base (+ 32 1)))) ;32 hash part + 1 hyphen
2085
2086(define (store-path-hash-part path)
2087 "Return the hash part of PATH as a base32 string, or #f if PATH is not a
2088syntactically valid store path."
2089 (let* ((base (store-path-base path))
2090 (hash (string-take base 32)))
2091 (and (string-every %nix-base32-charset hash)
2092 hash)))
2093
2094(define (derivation-log-file drv)
2095 "Return the build log file for DRV, a derivation file name, or #f if it
2096could not be found."
2097 (let* ((base (basename drv))
2098 (log (string-append (or (getenv "GUIX_LOG_DIRECTORY")
2099 (string-append %localstatedir "/log/guix"))
2100 "/drvs/"
2101 (string-take base 2) "/"
2102 (string-drop base 2)))
2103 (log.gz (string-append log ".gz"))
2104 (log.bz2 (string-append log ".bz2")))
2105 (cond ((file-exists? log.gz) log.gz)
2106 ((file-exists? log.bz2) log.bz2)
2107 ((file-exists? log) log)
2108 (else #f))))
2109
2110(define (log-file store file) 1984(define (log-file store file)
2111 "Return the build log file for FILE, or #f if none could be found. FILE 1985 "Return the build log file for FILE, or #f if none could be found. FILE
2112must be an absolute store file name, or a derivation file name." 1986must be an absolute store file name, or a derivation file name."
diff --git a/guix/store/derivations.scm b/guix/store/derivations.scm
new file mode 100644
index 00000000000..188396953db
--- /dev/null
+++ b/guix/store/derivations.scm
@@ -0,0 +1,612 @@
1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
3;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
4;;; Copyright © 2019 Caleb Ristvedt <caleb.ristvedt@cune.org>
5;;;
6;;; This file is part of GNU Guix.
7;;;
8;;; GNU Guix is free software; you can redistribute it and/or modify it
9;;; under the terms of the GNU General Public License as published by
10;;; the Free Software Foundation; either version 3 of the License, or (at
11;;; your option) any later version.
12;;;
13;;; GNU Guix is distributed in the hope that it will be useful, but
14;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;;; GNU General Public License for more details.
17;;;
18;;; You should have received a copy of the GNU General Public License
19;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20
21
22(define-module (guix store derivations)
23 #:use-module (ice-9 match)
24 #:use-module (rnrs io ports)
25 #:use-module (rnrs bytevectors)
26 #:use-module (srfi srfi-1)
27 #:use-module (srfi srfi-9)
28 #:use-module (srfi srfi-9 gnu)
29 #:use-module (srfi srfi-26)
30 #:use-module (srfi srfi-34)
31 #:use-module (srfi srfi-35)
32 #:use-module (gcrypt hash)
33 #:use-module (guix base16)
34 #:use-module (guix combinators)
35 #:use-module (guix memoization)
36 #:use-module (guix sets)
37 #:use-module (guix store files)
38 #:export (&derivation-error
39 derivation-error?
40 derivation-error-derivation
41
42 &derivation-missing-output-error
43 derivation-missing-output-error?
44 derivation-missing-output
45
46 <derivation>
47 make-derivation
48 derivation?
49 derivation-outputs
50 derivation-inputs
51 derivation-sources
52 derivation-system
53 derivation-builder
54 derivation-builder-arguments
55 derivation-builder-environment-vars
56 derivation-file-name
57
58 <derivation-output>
59 make-derivation-output
60 derivation-output?
61 derivation-output-path
62 derivation-output-hash-algo
63 derivation-output-hash
64 derivation-output-recursive?
65 derivation-output-names
66
67 <derivation-input>
68 make-derivation-input
69 derivation-input?
70 derivation-input-derivation
71 derivation-input-sub-derivations
72 derivation-input-path
73 derivation-input
74 derivation-input-key
75 coalesce-duplicate-inputs
76
77 derivation-name
78 derivation-base16-hash
79 derivation-output-names
80 derivation-hash
81 derivation-properties
82 fixed-output-derivation?
83 offloadable-derivation?
84 substitutable-derivation?
85
86 derivation-input<?
87 derivation-input-output-path
88 derivation-input-output-paths
89 derivation-output-paths
90 derivation-input-fold
91 derivation->output-path
92 derivation->output-paths
93 derivation-path->output-path
94 derivation-path->output-paths
95
96 derivation-prerequisites
97
98 derivation/masked-inputs
99 read-derivation
100 read-derivation-from-file
101 derivation->bytevector
102 %derivation-cache
103 write-derivation
104 invalidate-derivation-caches!))
105
106;;;
107;;; Nix derivations, as implemented in Nix's `derivations.cc'.
108;;;
109
110(define-immutable-record-type <derivation>
111 (make-derivation outputs inputs sources system builder args env-vars
112 file-name)
113 derivation?
114 (outputs derivation-outputs) ; list of name/<derivation-output> pairs
115 (inputs derivation-inputs) ; list of <derivation-input>
116 (sources derivation-sources) ; list of store paths
117 (system derivation-system) ; string
118 (builder derivation-builder) ; store path
119 (args derivation-builder-arguments) ; list of strings
120 (env-vars derivation-builder-environment-vars) ; list of name/value pairs
121 (file-name derivation-file-name)) ; the .drv file name
122
123(define-immutable-record-type <derivation-output>
124 (make-derivation-output path hash-algo hash recursive?)
125 derivation-output?
126 (path derivation-output-path) ; store path
127 (hash-algo derivation-output-hash-algo) ; symbol | #f
128 (hash derivation-output-hash) ; bytevector | #f
129 (recursive? derivation-output-recursive?)) ; Boolean
130
131(define-immutable-record-type <derivation-input>
132 (make-derivation-input drv sub-derivations)
133 derivation-input?
134 (drv derivation-input-derivation) ; <derivation>
135 (sub-derivations derivation-input-sub-derivations)) ; list of strings
136
137
138(define (derivation-input-path input)
139 "Return the file name of the derivation INPUT refers to."
140 (derivation-file-name (derivation-input-derivation input)))
141
142(define* (derivation-input drv #:optional
143 (outputs (derivation-output-names drv)))
144 "Return a <derivation-input> for the OUTPUTS of DRV."
145 ;; This is a public interface meant to be more convenient than
146 ;; 'make-derivation-input' and giving us more control.
147 (make-derivation-input drv outputs))
148
149(define (derivation-input-key input)
150 "Return an object for which 'equal?' and 'hash' are constant-time, and which
151can thus be used as a key for INPUT in lookup tables."
152 (cons (derivation-input-path input)
153 (derivation-input-sub-derivations input)))
154
155(set-record-type-printer! <derivation>
156 (lambda (drv port)
157 (format port "#<derivation ~a => ~a ~a>"
158 (derivation-file-name drv)
159 (string-join
160 (map (match-lambda
161 ((_ . output)
162 (derivation-output-path output)))
163 (derivation-outputs drv)))
164 (number->string (object-address drv)
165 16))))
166
167;;;
168;;; Error conditions.
169;;;
170
171(define-condition-type &derivation-error &store-error
172 derivation-error?
173 (derivation derivation-error-derivation))
174
175(define-condition-type &derivation-missing-output-error &derivation-error
176 derivation-missing-output-error?
177 (output derivation-missing-output))
178
179
180(define (derivation-name drv)
181 "Return the base name of DRV."
182 (let ((base (store-path-package-name (derivation-file-name drv))))
183 (string-drop-right base 4)))
184
185(define (derivation-output-names drv)
186 "Return the names of the outputs of DRV."
187 (match (derivation-outputs drv)
188 (((names . _) ...)
189 names)))
190
191(define (fixed-output-derivation? drv)
192 "Return #t if DRV is a fixed-output derivation, such as the result of a
193download with a fixed hash (aka. `fetchurl')."
194 (match drv
195 (($ <derivation>
196 (("out" . ($ <derivation-output> _ (? symbol?) (? bytevector?)))))
197 #t)
198 (_ #f)))
199
200(define (derivation-input<? input1 input2)
201 "Compare INPUT1 and INPUT2, two <derivation-input>."
202 (string<? (derivation-input-path input1)
203 (derivation-input-path input2)))
204
205(define (coalesce-duplicate-inputs inputs)
206 "Return a list of inputs, such that when INPUTS contains the same DRV twice,
207they are coalesced, with their sub-derivations merged. This is needed because
208Nix itself keeps only one of them."
209 (define (find pred lst) ;inlinable copy of 'find'
210 (let loop ((lst lst))
211 (match lst
212 (() #f)
213 ((head . tail)
214 (if (pred head) head (loop tail))))))
215
216 (fold (lambda (input result)
217 (match input
218 (($ <derivation-input> (= derivation-file-name path) sub-drvs)
219 ;; XXX: quadratic
220 (match (find (match-lambda
221 (($ <derivation-input> (= derivation-file-name p)
222 s)
223 (string=? p path)))
224 result)
225 (#f
226 (cons input result))
227 ((and dup ($ <derivation-input> drv sub-drvs2))
228 ;; Merge DUP with INPUT.
229 (let ((sub-drvs (delete-duplicates
230 (append sub-drvs sub-drvs2))))
231 (cons (make-derivation-input drv (sort sub-drvs string<?))
232 (delq dup result))))))))
233 '()
234 inputs))
235
236(define* (derivation-prerequisites drv #:optional (cut? (const #f)))
237 "Return the list of derivation-inputs required to build DRV, recursively.
238
239CUT? is a predicate that is passed a derivation-input and returns true to
240eliminate the given input and its dependencies from the search. An example of
241such a predicate is 'valid-derivation-input?'; when it is used as CUT?, the
242result is the set of prerequisites of DRV not already in valid."
243 (let loop ((drv drv)
244 (result '())
245 (input-set (set)))
246 (let ((inputs (remove (lambda (input)
247 (or (set-contains? input-set
248 (derivation-input-key input))
249 (cut? input)))
250 (derivation-inputs drv))))
251 (fold2 loop
252 (append inputs result)
253 (fold set-insert input-set
254 (map derivation-input-key inputs))
255 (map derivation-input-derivation inputs)))))
256
257(define (offloadable-derivation? drv)
258 "Return true if DRV can be offloaded, false otherwise."
259 (match (assoc "preferLocalBuild"
260 (derivation-builder-environment-vars drv))
261 (("preferLocalBuild" . "1") #f)
262 (_ #t)))
263
264(define (substitutable-derivation? drv)
265 "Return #t if DRV can be substituted."
266 (match (assoc "allowSubstitutes"
267 (derivation-builder-environment-vars drv))
268 (("allowSubstitutes" . value)
269 (string=? value "1"))
270 (_ #t)))
271
272(define (derivation-output-paths drv sub-drvs)
273 "Return the output paths of outputs SUB-DRVS of DRV."
274 (match drv
275 (($ <derivation> outputs)
276 (map (lambda (sub-drv)
277 (derivation-output-path (assoc-ref outputs sub-drv)))
278 sub-drvs))))
279
280(define* (derivation-input-fold proc seed inputs
281 #:key (cut? (const #f)))
282 "Perform a breadth-first traversal of INPUTS, calling PROC on each input
283with the current result, starting from SEED. Skip recursion on inputs that
284match CUT?."
285 (let loop ((inputs inputs)
286 (result seed)
287 (visited (set)))
288 (match inputs
289 (()
290 result)
291 ((input rest ...)
292 (let ((key (derivation-input-key input)))
293 (cond ((set-contains? visited key)
294 (loop rest result visited))
295 ((cut? input)
296 (loop rest result (set-insert key visited)))
297 (else
298 (let ((drv (derivation-input-derivation input)))
299 (loop (append (derivation-inputs drv) rest)
300 (proc input result)
301 (set-insert key visited))))))))))
302
303(define derivation-base16-hash
304 (mlambdaq (drv)
305 "Return a string containing the base16 representation of the hash of DRV."
306 (bytevector->base16-string (derivation-hash drv))))
307
308(define (derivation/masked-inputs drv)
309 "Assuming DRV is a regular derivation (not fixed-output), replace the file
310name of each input with that input's hash."
311 (match drv
312 (($ <derivation> outputs inputs sources
313 system builder args env-vars)
314 (let ((inputs (map (match-lambda
315 (($ <derivation-input> drv sub-drvs)
316 (let ((hash (derivation-base16-hash drv)))
317 (make-derivation-input hash sub-drvs))))
318 inputs)))
319 (make-derivation outputs
320 (sort inputs
321 (lambda (drv1 drv2)
322 (string<? (derivation-input-derivation drv1)
323 (derivation-input-derivation drv2))))
324 sources
325 system builder args env-vars
326 #f)))))
327
328(define derivation-hash ; `hashDerivationModulo' in derivations.cc
329 (lambda (drv)
330 "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
331 (match drv
332 (($ <derivation> ((_ . ($ <derivation-output> path
333 (? symbol? hash-algo) (? bytevector? hash)
334 (? boolean? recursive?)))))
335 ;; A fixed-output derivation.
336 (sha256
337 (string->utf8
338 (string-append "fixed:out:"
339 (if recursive? "r:" "")
340 (symbol->string hash-algo)
341 ":" (bytevector->base16-string hash)
342 ":" path))))
343 (_
344
345 ;; XXX: At this point this remains faster than `port-sha256', because
346 ;; the SHA256 port's `write' method gets called for every single
347 ;; character.
348 (sha256 (derivation->bytevector (derivation/masked-inputs drv)))))))
349
350(define (invalidate-derivation-caches!)
351 "Invalidate internal derivation caches. This is mostly useful for
352long-running processes that know what they're doing. Use with care!"
353 ;; Typically this is meant to be used by Cuirass and Hydra, which can clear
354 ;; caches when they start evaluating packages for another architecture.
355 (invalidate-memoization! derivation->bytevector)
356 (invalidate-memoization! derivation-base16-hash)
357
358 ;; FIXME: Comment out to work around <https://bugs.gnu.org/36487>.
359 ;; (hash-clear! %derivation-cache)
360 )
361
362(define derivation-properties
363 (mlambdaq (drv)
364 "Return the property alist associated with DRV."
365 (match (assoc "guix properties"
366 (derivation-builder-environment-vars drv))
367 ((_ . str) (call-with-input-string str read))
368 (#f '()))))
369
370(define (derivation-input-output-path input)
371 "Return the output file name of INPUT. If INPUT has more than one outputs,
372an error is raised."
373 (match input
374 (($ <derivation-input> drv (output))
375 (derivation->output-path drv output))))
376
377(define (derivation-input-output-paths input)
378 "Return the list of output paths corresponding to INPUT, a
379<derivation-input>."
380 (match input
381 (($ <derivation-input> drv sub-drvs)
382 (map (cut derivation->output-path drv <>)
383 sub-drvs))))
384
385(define* (derivation->output-path drv #:optional (output "out"))
386 "Return the store path of its output OUTPUT. Raise a
387'&derivation-missing-output-error' condition if OUTPUT is not an output of
388DRV."
389 (let ((output* (assoc-ref (derivation-outputs drv) output)))
390 (if output*
391 (derivation-output-path output*)
392 (raise (condition (&derivation-missing-output-error
393 (derivation drv)
394 (output output)))))))
395
396(define (derivation->output-paths drv)
397 "Return the list of name/path pairs of the outputs of DRV."
398 (map (match-lambda
399 ((name . output)
400 (cons name (derivation-output-path output))))
401 (derivation-outputs drv)))
402
403(define derivation-path->output-path
404 ;; This procedure is called frequently, so memoize it.
405 (let ((memoized (mlambda (path output)
406 (derivation->output-path (read-derivation-from-file path)
407 output))))
408 (lambda* (path #:optional (output "out"))
409 "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
410path of its output OUTPUT."
411 (memoized path output))))
412
413(define (derivation-path->output-paths path)
414 "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
415list of name/path pairs of its outputs."
416 (derivation->output-paths (read-derivation-from-file path)))
417
418
419(define* (read-derivation drv-port
420 #:optional (read-derivation-from-file
421 read-derivation-from-file))
422 "Read the derivation from DRV-PORT and return the corresponding <derivation>
423object. Call READ-DERIVATION-FROM-FILE to read derivations declared as inputs
424of the derivation being parsed.
425
426Most of the time you'll want to use 'read-derivation-from-file', which caches
427things as appropriate and is thus more efficient."
428
429 (define comma (string->symbol ","))
430
431 (define (ununquote x)
432 (match x
433 (('unquote x) (ununquote x))
434 ((x ...) (map ununquote x))
435 (_ x)))
436
437 (define (outputs->alist x)
438 (fold-right (lambda (output result)
439 (match output
440 ((name path "" "")
441 (alist-cons name
442 (make-derivation-output path #f #f #f)
443 result))
444 ((name path hash-algo hash)
445 ;; fixed-output
446 (let* ((rec? (string-prefix? "r:" hash-algo))
447 (algo (string->symbol
448 (if rec?
449 (string-drop hash-algo 2)
450 hash-algo)))
451 (hash (base16-string->bytevector hash)))
452 (alist-cons name
453 (make-derivation-output path algo
454 hash rec?)
455 result)))))
456 '()
457 x))
458
459 (define (make-input-drvs x)
460 (fold-right (lambda (input result)
461 (match input
462 ((path (sub-drvs ...))
463 (let ((drv (read-derivation-from-file path)))
464 (cons (make-derivation-input drv sub-drvs)
465 result)))))
466 '()
467 x))
468
469 ;; The contents of a derivation are typically ASCII, but choosing
470 ;; UTF-8 allows us to take the fast path for Guile's `scm_getc'.
471 (set-port-encoding! drv-port "UTF-8")
472
473 (let loop ((exp (read drv-port))
474 (result '()))
475 (match exp
476 ((? eof-object?)
477 (let ((result (reverse result)))
478 (match result
479 (('Derive ((outputs ...) (input-drvs ...)
480 (input-srcs ...)
481 (? string? system)
482 (? string? builder)
483 ((? string? args) ...)
484 ((var value) ...)))
485 (make-derivation (outputs->alist outputs)
486 (make-input-drvs input-drvs)
487 input-srcs
488 system builder args
489 (fold-right alist-cons '() var value)
490 (port-filename drv-port)))
491 (_
492 (error "failed to parse derivation" drv-port result)))))
493 ((? (cut eq? <> comma))
494 (loop (read drv-port) result))
495 (_
496 (loop (read drv-port)
497 (cons (ununquote exp) result))))))
498
499(define %derivation-cache
500 ;; Maps derivation file names to <derivation> objects.
501 ;; XXX: This is redundant with 'atts-cache' in the store.
502 (make-weak-value-hash-table 200))
503
504(define (read-derivation-from-file file)
505 "Read the derivation in FILE, a '.drv' file, and return the corresponding
506<derivation> object."
507 ;; Memoize that operation because 'read-derivation' is quite expensive,
508 ;; and because the same argument is read more than 15 times on average
509 ;; during something like (package-derivation s gdb).
510 (or (and file (hash-ref %derivation-cache file))
511 (let ((drv (call-with-input-file file read-derivation)))
512 (hash-set! %derivation-cache file drv)
513 drv)))
514
515(define-inlinable (write-sequence lst write-item port)
516 ;; Write each element of LST with WRITE-ITEM to PORT, separating them with a
517 ;; comma.
518 (match lst
519 (()
520 #t)
521 ((prefix (... ...) last)
522 (for-each (lambda (item)
523 (write-item item port)
524 (display "," port))
525 prefix)
526 (write-item last port))))
527
528(define-inlinable (write-list lst write-item port)
529 ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each
530 ;; element.
531 (display "[" port)
532 (write-sequence lst write-item port)
533 (display "]" port))
534
535(define-inlinable (write-tuple lst write-item port)
536 ;; Same, but write LST as a tuple.
537 (display "(" port)
538 (write-sequence lst write-item port)
539 (display ")" port))
540
541(define (write-derivation drv port)
542 "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of
543Eelco Dolstra's PhD dissertation for an overview of a previous version of
544that form."
545
546 ;; Make sure we're using the faster implementation.
547 (define format simple-format)
548
549 (define (write-string-list lst)
550 (write-list lst write port))
551
552 (define (write-output output port)
553 (match output
554 ((name . ($ <derivation-output> path hash-algo hash recursive?))
555 (write-tuple (list name path
556 (if hash-algo
557 (string-append (if recursive? "r:" "")
558 (symbol->string hash-algo))
559 "")
560 (or (and=> hash bytevector->base16-string)
561 ""))
562 write
563 port))))
564
565 (define (write-input input port)
566 (match input
567 (($ <derivation-input> obj sub-drvs)
568 (display "(\"" port)
569
570 ;; 'derivation/masked-inputs' produces objects that contain a string
571 ;; instead of a <derivation>, so we need to account for that.
572 (display (if (derivation? obj)
573 (derivation-file-name obj)
574 obj)
575 port)
576 (display "\"," port)
577 (write-string-list sub-drvs)
578 (display ")" port))))
579
580 (define (write-env-var env-var port)
581 (match env-var
582 ((name . value)
583 (display "(" port)
584 (write name port)
585 (display "," port)
586 (write value port)
587 (display ")" port))))
588
589 ;; Assume all the lists we are writing are already sorted.
590 (match drv
591 (($ <derivation> outputs inputs sources
592 system builder args env-vars)
593 (display "Derive(" port)
594 (write-list outputs write-output port)
595 (display "," port)
596 (write-list inputs write-input port)
597 (display "," port)
598 (write-string-list sources)
599 (simple-format port ",\"~a\",\"~a\"," system builder)
600 (write-string-list args)
601 (display "," port)
602 (write-list env-vars write-env-var port)
603 (display ")" port))))
604
605(define derivation->bytevector
606 (mlambda (drv)
607 "Return the external representation of DRV as a UTF-8-encoded string."
608 (with-fluids ((%default-port-encoding "UTF-8"))
609 (call-with-values open-bytevector-output-port
610 (lambda (port get-bytevector)
611 (write-derivation drv port)
612 (get-bytevector))))))
diff --git a/guix/store/files.scm b/guix/store/files.scm
new file mode 100644
index 00000000000..84ea7374ef7
--- /dev/null
+++ b/guix/store/files.scm
@@ -0,0 +1,176 @@
1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
3;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
4;;; Copyright © 2019 Caleb Ristvedt <caleb.ristvedt@cune.org>
5;;;
6;;; This file is part of GNU Guix.
7;;;
8;;; GNU Guix is free software; you can redistribute it and/or modify it
9;;; under the terms of the GNU General Public License as published by
10;;; the Free Software Foundation; either version 3 of the License, or (at
11;;; your option) any later version.
12;;;
13;;; GNU Guix is distributed in the hope that it will be useful, but
14;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;;; GNU General Public License for more details.
17;;;
18;;; You should have received a copy of the GNU General Public License
19;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20
21(define-module (guix store files)
22 #:use-module (ice-9 regex)
23 #:use-module (rnrs bytevectors)
24 #:use-module (srfi srfi-26)
25 #:use-module (srfi srfi-35)
26 #:use-module (gcrypt hash)
27 #:use-module (guix base32)
28 #:use-module (guix base16)
29 #:use-module (guix config)
30 #:use-module (guix memoization)
31 #:export (&store-error
32 store-error?
33 %store-prefix
34 store-path
35 output-path
36 fixed-output-path
37 store-path?
38 direct-store-path?
39 derivation-path?
40 store-path-base
41 store-path-package-name
42 store-path-hash-part
43 direct-store-path
44 derivation-log-file
45 log-file
46 compressed-hash))
47
48(define-condition-type &store-error &error
49 store-error?)
50
51;;;
52;;; Store paths.
53;;;
54
55(define %store-prefix
56 ;; Absolute path to the Nix store.
57 (make-parameter %store-directory))
58
59(define (compressed-hash bv size) ; `compressHash'
60 "Given the hash stored in BV, return a compressed version thereof that fits
61in SIZE bytes."
62 (define new (make-bytevector size 0))
63 (define old-size (bytevector-length bv))
64 (let loop ((i 0))
65 (if (= i old-size)
66 new
67 (let* ((j (modulo i size))
68 (o (bytevector-u8-ref new j)))
69 (bytevector-u8-set! new j
70 (logxor o (bytevector-u8-ref bv i)))
71 (loop (+ 1 i))))))
72
73(define (store-path type hash name) ; makeStorePath
74 "Return the store path for NAME/HASH/TYPE."
75 (let* ((s (string-append type ":sha256:"
76 (bytevector->base16-string hash) ":"
77 (%store-prefix) ":" name))
78 (h (sha256 (string->utf8 s)))
79 (c (compressed-hash h 20)))
80 (string-append (%store-prefix) "/"
81 (bytevector->nix-base32-string c) "-"
82 name)))
83
84(define (output-path output hash name) ; makeOutputPath
85 "Return an output path for OUTPUT (the name of the output as a string) of
86the derivation called NAME with hash HASH."
87 (store-path (string-append "output:" output) hash
88 (if (string=? output "out")
89 name
90 (string-append name "-" output))))
91
92(define* (fixed-output-path name hash
93 #:key
94 (output "out")
95 (hash-algo 'sha256)
96 (recursive? #t))
97 "Return an output path for the fixed output OUTPUT defined by HASH of type
98HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for
99'add-to-store'."
100 (if (and recursive? (eq? hash-algo 'sha256))
101 (store-path "source" hash name)
102 (let ((tag (string-append "fixed:" output ":"
103 (if recursive? "r:" "")
104 (symbol->string hash-algo) ":"
105 (bytevector->base16-string hash) ":")))
106 (store-path (string-append "output:" output)
107 (sha256 (string->utf8 tag))
108 name))))
109
110(define (store-path? path)
111 "Return #t if PATH is a store path."
112 ;; This is a lightweight check, compared to using a regexp, but this has to
113 ;; be fast as it's called often in `derivation', for instance.
114 ;; `isStorePath' in Nix does something similar.
115 (string-prefix? (%store-prefix) path))
116
117(define (direct-store-path? path)
118 "Return #t if PATH is a store path, and not a sub-directory of a store path.
119This predicate is sometimes needed because files *under* a store path are not
120valid inputs."
121 (and (store-path? path)
122 (not (string=? path (%store-prefix)))
123 (let ((len (+ 1 (string-length (%store-prefix)))))
124 (not (string-index (substring path len) #\/)))))
125
126(define (direct-store-path path)
127 "Return the direct store path part of PATH, stripping components after
128'/gnu/store/xxxx-foo'."
129 (let ((prefix-length (+ (string-length (%store-prefix)) 35)))
130 (if (> (string-length path) prefix-length)
131 (let ((slash (string-index path #\/ prefix-length)))
132 (if slash (string-take path slash) path))
133 path)))
134
135(define (derivation-path? path)
136 "Return #t if PATH is a derivation path."
137 (and (store-path? path) (string-suffix? ".drv" path)))
138
139(define (store-path-base path)
140 "Return the base path of a path in the store."
141 (and (string-prefix? (%store-prefix) path)
142 (let ((base (string-drop path (+ 1 (string-length (%store-prefix))))))
143 (and (> (string-length base) 33)
144 (not (string-index base #\/))
145 base))))
146
147(define (store-path-package-name path)
148 "Return the package name part of PATH, a file name in the store."
149 (let ((base (store-path-base path)))
150 (string-drop base (+ 32 1)))) ;32 hash part + 1 hyphen
151
152(define (store-path-hash-part path)
153 "Return the hash part of PATH as a base32 string, or #f if PATH is not a
154syntactically valid store path."
155 (let* ((base (store-path-base path))
156 (hash (string-take base 32)))
157 (and (string-every %nix-base32-charset hash)
158 hash)))
159
160(define (derivation-log-file drv)
161 "Return the build log file for DRV, a derivation file name, or #f if it
162could not be found."
163 (let* ((base (basename drv))
164 (log (string-append (or (getenv "GUIX_LOG_DIRECTORY")
165 (string-append %localstatedir "/log/guix"))
166 "/drvs/"
167 (string-take base 2) "/"
168 (string-drop base 2)))
169 (log.gz (string-append log ".gz"))
170 (log.bz2 (string-append log ".bz2")))
171 (cond ((file-exists? log.gz) log.gz)
172 ((file-exists? log.bz2) log.bz2)
173 ((file-exists? log) log)
174 (else #f))))
175
176
generated by cgit v1.2.3 (git 2.25.1) at 2026-09-03 05:51:11 +0000